From 416d231c5ecb4eea4bdb121e1503a74111373256 Mon Sep 17 00:00:00 2001
From: "kr.angelov" <kr.angelov@gmail.com>
Date: Thu, 10 Nov 2011 14:09:41 +0000
Subject: Now PMCFG is compiled per module and at the end we only link it. The
 new compilation schema is few times faster.

---
 src/compiler/GF/Grammar/Printer.hs | 58 ++++++++++++++++++++++++++++++++------
 1 file changed, 49 insertions(+), 9 deletions(-)

(limited to 'src/compiler/GF/Grammar/Printer.hs')

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)
+
-- 
cgit v1.2.3