CFGtoPGF is now extended to support context-free grammars with primitive parameters

1 files changed, 59 insertions, 37 deletions

diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index 5bf1d1be1..f9ab8afcf 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -17,7 +17,7 @@ import Data.List
 -- the compiler ----------
 --------------------------
 
-cf2pgf :: FilePath -> CFG -> PGF
+cf2pgf :: FilePath -> ParamCFG -> PGF
 cf2pgf fpath cf = 
  let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
  in updateProductionIndices pgf
@@ -26,18 +26,21 @@ cf2pgf fpath cf =
    aname = mkCId (name ++ "Abs")
    cname = mkCId name
 
-cf2abstr :: CFG -> Abstr
+cf2abstr :: ParamCFG -> Abstr
 cf2abstr cfg = Abstr aflags afuns acats
   where
-    aflags = Map.singleton (mkCId "startcat") (LStr (cfgStartCat cfg))
-    acats = Map.fromList [(mkCId cat, ([], [(0,mkRuleName rule) 
-                                              | rule <- Set.toList rules], 0))
-                            | (cat,rules) <- Map.toList (cfgRules cfg)]
-    afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0))
-                            | (cat,rules) <- Map.toList (cfgRules cfg)
-                            , rule <- Set.toList rules]
-
-cf2concr :: CFG -> Concr
+    aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
+
+    acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
+                            | (cat,rules) <- (Map.toList . Map.fromListWith (++))
+                                                [(cat2id cat, catRules cfg cat) | 
+                                                     cat <- allCats' cfg]]
+    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
+                            | rule <- allRules cfg]
+
+    cat2id = mkCId . fst
+
+cf2concr :: ParamCFG -> Concr
 cf2concr cfg = Concr Map.empty Map.empty
                      cncfuns lindefsrefs lindefsrefs
                      sequences productions
@@ -46,51 +49,64 @@ cf2concr cfg = Concr Map.empty Map.empty
                      IntMap.empty
                      totalCats
   where
+    cats  = allCats' cfg
+    rules = allRules cfg
+
     sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
-                               [mkSequence rule | rules <- Map.elems (cfgRules cfg), rule <- Set.toList rules])
+                               map mkSequence rules)
     sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
 
     idFun = CncFun wildCId (listArray (0,0) [seqid])
       where
         seq   = listArray (0,0) [SymCat 0 0]
         seqid = binSearch seq sequences (bounds sequences)
-    ((fun_cnt,cncfuns0),productions0) = mapAccumL convertRules (1,[idFun]) (Map.toList (cfgRules cfg))
-    productions = IntMap.fromList productions0
+    ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
+    productions = foldl addProd IntMap.empty (concat (productions0++coercions))
     cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
 
     lbls = listArray (0,0) ["s"]
-    (totalCats,cnccats0) = mapAccumL mkCncCat 0 (Map.toList (cfgRules cfg))
-    cnccats = Map.fromList ((mkCId "Int",    CncCat fidInt    fidInt    lbls) :
-                            (mkCId "Float",  CncCat fidFloat  fidFloat  lbls) :
-                            (mkCId "String", CncCat fidString fidString lbls) :
-                            cnccats0)
+    (fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
+                              [(c,p) | (c,ps) <- cats, p <- ps]
+    ((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
+    cnccats = Map.fromList cnccats0
 
-    lindefsrefs = 
-       IntMap.fromList (map mkLinDefRef (Map.keys (cfgRules cfg)))
+    lindefsrefs =
+       IntMap.fromList (map mkLinDefRef cats)
 
-    convertRules st (cat,rules) =
-      let (st',prods) = mapAccumL convertRule st (Set.toList rules)
-      in (st',(cat2fid cat,Set.fromList prods))
-
-    convertRule (funid,funs) rule = 
-      let args   = [PArg [] (cat2fid c) | NonTerminal c <- ruleRhs rule]
+    convertRule cs (funid,funs) rule =
+      let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
           prod   = PApply funid args
           seqid  = binSearch (mkSequence rule) sequences (bounds sequences)
           fun    = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
           funid' = funid+1
-      in funid' `seq` ((funid',fun:funs),prod)
+      in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
 
     mkSequence rule = listArray (0,length syms-1) syms
       where
         syms   = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
 
-        convertSymbol d (NonTerminal c) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
-        convertSymbol d (Terminal t)    = (d,  SymKS t)
-
-    mkCncCat fid (cat,_) = (fid+1, (mkCId cat,CncCat fid fid lbls))
-
-    mkLinDefRef cat =
-      (cat2fid cat,[0])
+        convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
+        convertSymbol d (Terminal t)        = (d,  SymKS t)
+
+    mkCncCat fid (cat,n)
+      | cat == "Int"    = (fid, (mkCId cat, CncCat fidInt    fidInt    lbls))
+      | cat == "Float"  = (fid, (mkCId cat, CncCat fidFloat  fidFloat  lbls))
+      | cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
+      | otherwise       = let fid' = fid+n+1
+                          in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
+
+    mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
+    mkCoercions (fid,cs) c@(cat,ps ) =
+      let fid' = fid+1
+      in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
+
+    mkLinDefRef (cat,_) =
+      (cat2fid cat 0,[0])
+      
+    addProd prods (fid,prod) =
+      case IntMap.lookup fid prods of
+        Just set -> IntMap.insert fid (Set.insert prod set) prods
+        Nothing  -> IntMap.insert fid (Set.singleton prod)  prods
 
     binSearch v arr (i,j)
       | i <= j    = case compare v (arr ! k) of
@@ -101,11 +117,17 @@ cf2concr cfg = Concr Map.empty Map.empty
       where
         k = (i+j) `div` 2
 
-    cat2fid cat = 
+    cat2fid cat p =
       case Map.lookup (mkCId cat) cnccats of
-        Just (CncCat fid _ _) -> fid
+        Just (CncCat fid _ _) -> fid+p
         _                     -> error "cat2fid"
 
+    cat2arg c@(cat,[p]) = cat2fid cat p
+    cat2arg c@(cat,ps ) =
+      case Map.lookup c cs of
+        Just fid -> fid
+        Nothing  -> error "cat2arg"
+
 mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n