Now PMCFG is compiled per module and at the end we only link it. The new compilation schema is few times faster.

8 files changed, 134 insertions, 79 deletions

diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 1c9358816..38d3d9bcc 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -31,8 +31,8 @@ stripInfo i = case i of
   ResValue lt -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
-  CncCat mty mte mtf -> CncCat mty Nothing Nothing
-  CncFun mict mte mtf -> CncFun mict Nothing Nothing
+  CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
+  CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
   AnyInd b f -> i
 
 constantsInTerm :: Term -> [QIdent]
@@ -110,8 +110,8 @@ sizeInfo i = case i of
   ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
-  CncCat mty mte mtf -> 1 + msize mty   -- ignoring lindef and printname
-  CncFun mict mte mtf -> 1 + msize mte  -- ignoring type and printname
+  CncCat mty mte mtf _ -> 1 + msize mty   -- ignoring lindef and printname
+  CncFun mict mte mtf _ -> 1 + msize mte  -- ignoring type and printname
   AnyInd b f -> -1  -- just to ignore these in the size
   _ -> 0
  where 
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 2298ed018..d1a3ac413 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -18,6 +18,8 @@ import GF.Infra.Ident
 import GF.Infra.Option

 import GF.Grammar.Grammar

 

+import PGF.Binary hiding (decodingError)

+

 instance Binary Ident where

   put id = put (ident2bs id)

   get    = do bs <- get

@@ -30,9 +32,9 @@ instance Binary SourceGrammar where
   get = fmap mGrammar get

 

 instance Binary SourceModInfo where

-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)

-  get    = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get

-              return (ModInfo mtype mstatus flags extend mwith opens med src jments)

+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)

+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get

+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)

 

 instance Binary ModuleType where

   put MTAbstract       = putWord8 0

@@ -85,6 +87,19 @@ instance Binary Options where
              Ok  x   -> return x

              Bad msg -> fail msg

 

+instance Binary Production where

+  put (Production res funid args) = put (res,funid,args)

+  get = do res   <- get

+           funid <- get

+           args  <- get

+           return (Production res funid args)

+

+instance Binary PMCFG where

+  put (PMCFG prods funs) = put (prods,funs)

+  get = do prods <- get

+           funs  <- get

+           return (PMCFG prods funs)

+

 instance Binary Info where

   put (AbsCat x)       = putWord8 0 >> put x

   put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)

@@ -92,8 +107,8 @@ instance Binary Info where
   put (ResValue x)     = putWord8 3 >> put x

   put (ResOper x y)    = putWord8 4 >> put (x,y)

   put (ResOverload x y)= putWord8 5 >> put (x,y)

-  put (CncCat x y z)   = putWord8 6 >> put (x,y,z)

-  put (CncFun x y z)   = putWord8 7 >> put (x,y,z)

+  put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)

+  put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)

   put (AnyInd x y)     = putWord8 8 >> put (x,y)

   get = do tag <- getWord8

            case tag of

@@ -103,8 +118,8 @@ instance Binary Info where
              3 -> get >>= \x         -> return (ResValue x)

              4 -> get >>= \(x,y)     -> return (ResOper x y)

              5 -> get >>= \(x,y)     -> return (ResOverload x y)

-             6 -> get >>= \(x,y,z)   -> return (CncCat x y z)

-             7 -> get >>= \(x,y,z)   -> return (CncFun x y z)

+             6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)

+             7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)

              8 -> get >>= \(x,y)     -> return (AnyInd x y)

              _ -> decodingError

 

@@ -122,15 +137,6 @@ instance Binary a => Binary (L a) where
   put (L x y) = put (x,y)

   get = get >>= \(x,y) -> return (L x y)

 

-instance Binary BindType where

-  put Explicit = putWord8 0

-  put Implicit = putWord8 1

-  get = do tag <- getWord8

-           case tag of

-             0 -> return Explicit

-             1 -> return Implicit

-             _ -> decodingError

-

 instance Binary Term where

   put (Vr x)        = putWord8 0  >> put x

   put (Cn x)        = putWord8 1  >> put x

@@ -270,7 +276,7 @@ instance Binary Label where
 

 decodeModHeader :: FilePath -> IO SourceModule

 decodeModHeader fpath = do

-  (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath

-  return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)

+  (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- decodeFile fpath

+  return (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)

 

 decodingError = fail "This GFO file was compiled with different version of GF"

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 5a10612ec..2ef625131 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -83,8 +83,8 @@ type CFFun = String
 
 cf2gf :: FilePath -> CF -> SourceGrammar
 cf2gf fpath cf = mGrammar [
-  (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs),
-  (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc)
+  (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
+  (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
   ]
  where
    name = justModuleName fpath
@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
             _ -> error "empty CF" 
   cats  = [(cat, AbsCat (Just (L NoLoc []))) | 
              cat <- nub (concat (map cf2cat rules))] ----notPredef cat
-  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
+  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
   (funs,lins) = unzip (map cf2rule rules)
 
 cf2cat :: CFRule -> [Ident]
@@ -119,6 +119,7 @@ cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
                Nothing 
                (Just (L loc (mkAbs (map fst args) 
                       (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
+               Nothing
                Nothing)
   mkIt (v, Left _) = P (Vr v) theLinLabel
   mkIt (_, Right a) = K a
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index acf2153bc..5174b1695 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -32,7 +32,9 @@ module GF.Grammar.Grammar (
         abstractOfConcrete,
 
         ModuleStatus(..),
-
+        
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
+        
         Info(..),
         Location(..), L(..), unLoc,
         Type,
@@ -64,18 +66,25 @@ import GF.Infra.Option ---
 
 import GF.Data.Operations
 
+import PGF.Data (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
+
 import Data.List
+import Data.Array.IArray
+import Data.Array.Unboxed
 import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
 import qualified Data.ByteString.Char8 as BS
 import Text.PrettyPrint
 import System.FilePath
+import Control.Monad.Identity
+
 
 
 data SourceGrammar = MGrammar { 
     moduleMap :: Map.Map Ident SourceModInfo,
     modules :: [(Ident,SourceModInfo)]
   }
-  deriving Show
 
 data SourceModInfo = ModInfo {
     mtype   :: ModuleType,
@@ -86,9 +95,9 @@ data SourceModInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [Ident],
     msrc    :: FilePath,
+    mseqs   :: Maybe (Array SeqId Sequence),
     jments  :: Map.Map Ident Info
   }
-  deriving Show
 
 type SourceModule = (Ident, SourceModInfo)
 
@@ -116,9 +125,6 @@ isInherited c i = case c of
 inheritAll :: Ident -> (Ident,MInclude)
 inheritAll i = (i,MIAll)
 
-addOpenQualif :: Ident -> Ident -> SourceModInfo -> SourceModInfo
-addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
-
 data OpenSpec = 
    OSimple Ident
  | OQualif Ident Ident
@@ -313,6 +319,14 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
+data Production = Production {-# UNPACK #-} !FId
+                             {-# UNPACK #-} !FunId
+                             [[FId]]
+                  deriving (Eq,Ord,Show)
+
+data PMCFG = PMCFG [Production]
+                   (Array FunId (UArray LIndex SeqId)) 
+             deriving (Eq,Show)
 
 -- | the constructors are judgements in 
 --
@@ -336,8 +350,8 @@ data Info =
  | ResOverload [Ident] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -364,11 +378,6 @@ type Fun  = QIdent
 
 type QIdent = (Ident,Ident)
 
-data BindType = 
-    Explicit
-  | Implicit
-  deriving (Eq,Ord,Show)
-
 data Term =
    Vr Ident                      -- ^ variable
  | Cn Ident                      -- ^ constant
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 7e743dd16..0a06347d6 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -71,11 +71,11 @@ lookupResDef gr (m,c)
       case info of
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
-        CncCat (Just (L _ ty)) _ _ -> lock c ty
-        CncCat _ _ _         -> lock c defLinType
+        CncCat (Just (L _ ty)) _ _ _ -> lock c ty
+        CncCat _ _ _ _         -> lock c defLinType
       
-        CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
-        CncFun _                (Just (L _ tr)) _ -> return tr
+        CncFun (Just (cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun _                (Just (L _ tr)) _ _ -> return tr
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (QC (m,c))
@@ -89,8 +89,8 @@ lookupResType gr (m,c) = do
     ResOper (Just (L _ t)) _ -> return t
 
     -- used in reused concrete
-    CncCat _ _ _ -> return typeType
-    CncFun (Just (cat,cont,val)) _ _ -> do
+    CncCat _ _ _ _ -> return typeType
+    CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val 
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
@@ -119,10 +119,10 @@ lookupOrigInfo gr (m,c) = do
     AnyInd _ n  -> lookupOrigInfo gr (n,c)
     i           -> return (m,i)
 
-allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
 allOrigInfos gr m = errVal [] $ do
   mo <- lookupModule gr m
-  return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [lookupOrigInfo gr (m,c)]]
+  return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
 
 lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
 lookupParamValues gr c = do
@@ -163,9 +163,9 @@ lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
 lookupLincat gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
-    CncCat (Just (L _ t)) _ _ -> return t
-    AnyInd _ n                -> lookupLincat gr n c
-    _                         -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    CncCat (Just (L _ t)) _ _ _ -> return t
+    AnyInd _ n                  -> lookupLincat gr n c
+    _                           -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 8af343fc6..e8842375d 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -69,9 +69,8 @@ valTypeCnc typ = snd (typeFormCnc typ)
 
 typeSkeleton :: Type -> ([(Int,Cat)],Cat)
 typeSkeleton typ =
-  let (cont,cat,_) = typeForm typ
-      args = map (\(b,x,t) -> typeSkeleton t) cont
-  in ([(length c, v) | (c,v) <- args], cat)
+  let (ctxt,cat,_) = typeForm typ
+  in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)
 
 catSkeleton :: Type -> ([Cat],Cat)
 catSkeleton typ =
@@ -560,8 +559,8 @@ allDependencies ism b =
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
       ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
-      CncCat pty _ _ -> [pty]
-      CncFun _   pt _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      CncCat pty _ _ _ -> [pty]
+      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
       AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
       AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
       _              -> []
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 6c83d72a0..530795974 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -117,14 +117,14 @@ ModDef
                                       defs <- case buildAnyTree id jments of
                                                 Ok x    -> return x
                                                 Bad msg -> fail msg
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -219,11 +219,11 @@ TopDef
   | 'data'            ListDataDef     { Left  $2 }
   | 'param'           ListParamDef    { Left  $2 }
   | 'oper'            ListOperDef     { Left  $2 }
-  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing   ) | (f,e) <- $2] }
-  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing   ) | (f,e) <- $2] }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing Nothing) | (f,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing Nothing) | (f,e) <- $2] }
   | 'lin'             ListLinDef      { Left  $2 }
-  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e)) | (f,e) <- $3] }
-  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e) Nothing) | (f,e) <- $3] }
+  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
   | 'flags'           ListFlagDef     { Right $2 }
 
 CatDef :: { [(Ident,Info)] }
@@ -263,8 +263,8 @@ OperDef
 
 LinDef :: { [(Ident,Info)] }
 LinDef
-  : Posn ListName '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
-  | Posn Name ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] }
+  : Posn ListName '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing Nothing) | f <- $2] }
+  | Posn Name ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
 
 TermDef :: { [(Ident,L Term)] }
 TermDef
@@ -674,14 +674,14 @@ isOverloading t =
 
 checkInfoType mt jment@(id,info) =
   case info of
-    AbsCat pcont       -> ifAbstract mt (locPerh pcont)
-    AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
-    CncCat pty pd ppn  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
-    CncFun _   pd ppn  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
-    ResParam pparam _  -> ifResource mt (locPerh pparam)
-    ResValue ty        -> ifResource mt (locL ty)
-    ResOper  pty pt    -> ifOper mt pty pt
-    ResOverload _ xs   -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
+    AbsCat pcont         -> ifAbstract mt (locPerh pcont)
+    AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+    CncCat pty pd ppn _  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
+    CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
+    ResParam pparam _    -> ifResource mt (locPerh pparam)
+    ResValue ty          -> ifResource mt (locL ty)
+    ResOper  pty pt      -> ifOper mt pty pt
+    ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where
     locPerh = maybe [] locL
     locAll xs = [loc | L loc x <- xs]
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index f65d26f89..cf0bbf6e9 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -26,10 +26,15 @@ import GF.Infra.Option
 import GF.Grammar.Values

 import GF.Grammar.Grammar

 

+import PGF.Printer (ppFId, ppFunId, ppSeqId, ppSeq)

+

 import Text.PrettyPrint

 import Data.Maybe (maybe, isNothing)

 import Data.List  (intersperse)

 import qualified Data.Map as Map

+import qualified Data.IntMap as IntMap

+import qualified Data.Set as Set

+import qualified Data.Array.IArray as Array

 

 data TermPrintQual = Qualified | Unqualified

 

@@ -37,11 +42,13 @@ ppGrammar :: SourceGrammar -> Doc
 ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr

 

 ppModule :: TermPrintQual -> SourceModule -> Doc

-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =

-    hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr

+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =

+    hdr $$ 

+    nest 2 (ppOptions opts $$ 

+            vcat (map (ppJudgement q) (Map.toList jments)) $$

+            maybe empty ppSequences mseqs) $$

+    ftr

     where

-      defs = Map.toList jments

-

       hdr = complModDoc <+> modTypeDoc <+> equals <+> 

             hsep (intersperse (text "**") $

                   filter (not . isEmpty)  $ [ commaPunct ppExtends exts

@@ -108,7 +115,7 @@ ppJudgement q (id, ResOverload ids defs) =
   (text "overload" <+> lbrace $$

    nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$

    rbrace) <+> semi

-ppJudgement q (id, CncCat  ptype pexp pprn) =

+ppJudgement q (id, CncCat  ptype pexp pprn mpmcfg) =

   (case ptype of

      Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

      Nothing        -> empty) $$

@@ -116,17 +123,37 @@ ppJudgement q (id, CncCat  ptype pexp pprn) =
      Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

      Nothing        -> empty) $$

   (case pprn of

-     Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty) $$

+  (case mpmcfg of

+     Just (PMCFG prods funs)

+                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$

+                       nest 2 (vcat (map ppProduction prods) $$

+                               space $$

+                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 

+                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))

+                                         (Array.assocs funs))) $$

+                       char '}'

      Nothing        -> empty)

-ppJudgement q (id, CncFun  ptype pdef pprn) =

+ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =

   (case pdef of

      Just (L _ e) -> let (xs,e') = getAbs e

                      in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi

      Nothing      -> empty) $$

   (case pprn of

-     Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty) $$

+  (case mpmcfg of

+     Just (PMCFG prods funs)

+                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$

+                       nest 2 (vcat (map ppProduction prods) $$

+                               space $$

+                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 

+                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))

+                                         (Array.assocs funs))) $$

+                       char '}'

      Nothing        -> empty)

-ppJudgement q (id, AnyInd cann mid) = text "-- ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi

+ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi

 

 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)

                            in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')

@@ -277,6 +304,18 @@ ppLocation fpath (Local b e)
   | b == e    = text fpath <> colon <> int b

   | otherwise = text fpath <> colon <> int b <> text "-" <> int e

 

+ppProduction (Production fid funid args) =

+  ppFId fid <+> text "->" <+> ppFunId funid <> 

+  brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))

+

+ppSequences seqsArr

+  | null seqs = empty

+  | otherwise = text "sequences" <+> char '{' $$

+                nest 2 (vcat (map ppSeq seqs)) $$

+                char '}'

+  where

+    seqs = Array.assocs seqsArr

+

 commaPunct f ds = (hcat (punctuate comma (map f ds)))

 

 prec d1 d2 doc

@@ -299,3 +338,4 @@ getLet :: Term -> ([LocalDef], Term)
 getLet (Let l e) = let (ls,e') = getLet e

                    in (l:ls,e')

 getLet e         = ([],e)

+