added the linref construction in GF. The PGF version number is now bumped

1 files changed, 30 insertions, 18 deletions

diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index aa5c3d163..b8a4f36fa 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -6,7 +6,7 @@ import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
 
 import PGF.CId
-import PGF.Data(fidInt,fidFloat,fidString)
+import PGF.Data(fidInt,fidFloat,fidString,fidVar)
 import PGF.Optimize(updateProductionIndices)
 import qualified PGF.Macros as CM
 import qualified PGF.Data as C
@@ -67,7 +67,7 @@ mkCanon2pgf opts gr am = do
 
       (ex_seqs,cdefs) <- addMissingPMCFGs
                             Map.empty 
-                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
                              Look.allOrigInfos gr cm)
 
       let flags = Map.fromList [(mkCId f,if f == "beam_size" then C.LFlt (read x) else C.LStr x) | (f,x) <- optionsPGF cflags]
@@ -78,7 +78,7 @@ mkCanon2pgf opts gr am = do
           ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
 
           !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
-          !(!fid_cnt2,!productions,!lindefs,!cncfuns)
+          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
                                 = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
         
           printnames = genPrintNames cdefs
@@ -86,6 +86,7 @@ mkCanon2pgf opts gr am = do
                               printnames
                               cncfuns
                               lindefs
+                              linrefs
                               seqs
                               productions
                               IntMap.empty
@@ -178,7 +179,7 @@ genCncCats gr am cm cdefs =
   in (index, Map.fromList cats)
   where
     mkCncCats index []                                                = (index,[])
-    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs) 
+    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
       | id == cInt    = 
             let cc            = pgfCncCat gr lincat fidInt
                 (index',cats) = mkCncCats index cdefs
@@ -208,22 +209,24 @@ genCncFuns :: SourceGrammar
            -> (FId,
                IntMap.IntMap (Set.Set D.Production),
                IntMap.IntMap [FunId],
+               IntMap.IntMap [FunId],
                Array FunId D.CncFun)
 genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
-  let (fid_cnt1,funs_cnt1,funs1,lindefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty
-      (fid_cnt2,funs_cnt2,funs2,prods)   = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-  in (fid_cnt2,prods,lindefs,array (0,funs_cnt2-1) funs2)
+  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
   where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs =
-      (fid_cnt,funs_cnt,funs,lindefs)
-    mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs =
+    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
       let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
                        in funs_cnt+(e_funid-s_funid+1)
           lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
           funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
-      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs'
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs = 
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
 
     mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
       (fid_cnt,funs_cnt,funs,prods)
@@ -264,11 +267,20 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
 
     mkLinDefId id = prefixIdent "lindef " id
 
-    toLinDef res offs lindefs (Production fid0 funid0 _) =
-      IntMap.insertWith (++) fid [offs+funid0] lindefs
+    toLinDef res offs lindefs (Production fid0 funid0 args) =
+      if args == [[fidVar]]
+        then IntMap.insertWith (++) fid [offs+funid0] lindefs
+        else lindefs
       where
         fid = mkFId res fid0
 
+    toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
+      if fid0 == fidVar
+        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
+        else linrefs
+      where
+        fids = map (mkFId res) fargs
+
     mkFId (_,cat) fid0 =
       case Map.lookup (i2i cat) cnccats of
         Just (C.CncCat s e _) -> s+fid0
@@ -299,9 +311,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
 genPrintNames cdefs =
   Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
   where
-    prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn _                              = []
+    prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn _                                = []
 
     flatten (K s)      = s
     flatten (Alts x _) = flatten x