an API to the dependency graph visualization

src/compiler/GF/Command/Commands.hs

@@ -723,7 +723,7 @@ pgfCommands = Map.fromList [
        case toExprs arg of
          [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
                         Just fd -> do putStrLn $ render (ppFun id fd)
-                                      let (_,_,_,prob) = fd
+                                      let (_,_,_,_,prob) = fd
                                       putStrLn ("Probability: "++show prob)
                                       return void
                         Nothing -> case Map.lookup id (cats (abstract pgf)) of
@@ -732,7 +732,7 @@ pgfCommands = Map.fromList [
                                                                 if null (functionsToCat pgf id)
                                                                   then empty
                                                                   else ' ' $$
-                                                                       vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
+                                                                       vcat [ppFun fid (ty,[],0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
                                                                        ' ')
                                                      let (_,_,prob) = cd
                                                      putStrLn ("Probability: "++show prob)
@@ -909,7 +909,7 @@ pgfCommands = Map.fromList [
      | otherwise             = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
                                   return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
 
-   funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
+   funsigs pgf = [(f,ty) | (f,(ty,_,_,_,_)) <- Map.assocs (funs (abstract pgf))]
    showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
 
    morphos (Env pgf mos) opts s =

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -35,7 +35,7 @@ cf2abstr cfg = Abstr aflags afuns acats
                             | (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))
+    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), [], 0, Nothing, 0))
                             | rule <- allRules cfg]
 
     cat2id = mkCId . fst
@@ -56,7 +56,7 @@ cf2concr cfg = Concr Map.empty Map.empty
                                map mkSequence rules)
     sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
 
-    idFun = CncFun wildCId (listArray (0,0) [seqid])
+    idFun = CncFun [wildCId] (listArray (0,0) [seqid])
       where
         seq   = listArray (0,0) [SymCat 0 0]
         seqid = binSearch seq sequences (bounds sequences)
@@ -77,7 +77,7 @@ cf2concr cfg = Concr Map.empty Map.empty
       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])
+          fun    = CncFun [mkRuleName rule] (listArray (0,0) [seqid])
           funid' = funid+1
       in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
 

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -6,18 +6,15 @@ import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
 
 import PGF(CId,mkCId,utf8CId)
-import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
+import PGF.Internal(fidInt,fidFloat,fidString,fidVar,DepPragma(..))
 import PGF.Internal(updateProductionIndices)
---import qualified PGF.Macros as CM
 import qualified PGF.Internal as C
-import qualified PGF.Internal as D
 import GF.Grammar.Predef
 --import GF.Grammar.Printer
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
---import GF.Compile.GeneratePMCFG
 
 import GF.Infra.Ident
 import GF.Infra.Option
@@ -25,20 +22,24 @@ import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
 import Data.List
+import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
 
-mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
+mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE C.PGF
 mkCanon2pgf opts gr am = do
-  (an,abs) <- mkAbstr am
+  depconf  <- case flag optLabelsFile opts of
+                Nothing    -> return Map.empty
+                Just fpath -> readDepConfig fpath
+  (an,abs) <- mkAbstr am depconf
   cncs     <- mapM mkConcr (allConcretes gr am)
-  return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
+  return $ updateProductionIndices (C.PGF Map.empty an abs (Map.fromList cncs))
   where
     cenv = resourceValues opts gr
 
-    mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
+    mkAbstr am depconf = return (mi2i am, C.Abstr flags funs cats)
       where
         aflags = err (const noOptions) mflags (lookupModule gr am)
 
@@ -48,7 +49,7 @@ mkCanon2pgf opts gr am = do
 
         flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
 
-        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
+        funs = Map.fromList [(i2i f, (mkType [] ty, fromMaybe [] (Map.lookup (i2i f) depconf), arity, mkDef gr arity mdef, 0)) | 
                                    ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
                                    let arity = mkArity ma mdef ty]
 
@@ -78,7 +79,7 @@ mkCanon2pgf opts gr am = do
                                 = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
         
           printnames = genPrintNames cdefs
-      return (mi2i cm, D.Concr flags
+      return (mi2i cm, C.Concr flags
                               printnames
                               cncfuns
                               lindefs
@@ -189,54 +190,80 @@ genCncFuns :: Grammar
            -> Array SeqId Sequence
            -> [(QIdent, Info)]
            -> FId
-           -> Map.Map CId D.CncCat
+           -> Map.Map CId C.CncCat
            -> (FId,
-               IntMap.IntMap (Set.Set D.Production),
+               IntMap.IntMap (Set.Set C.Production),
                IntMap.IntMap [FunId],
                IntMap.IntMap [FunId],
-               Array FunId D.CncFun)
+               Array FunId C.CncFun)
 genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
-  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+  let (fid_cnt1,lindefs,linrefs,fun_st1) = mkCncCats cdefs fid_cnt IntMap.empty IntMap.empty Map.empty
-      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+      ((fid_cnt2,crc,prods),fun_st2)     = mkCncFuns cdefs lindefs ((fid_cnt1,Map.empty,IntMap.empty),fun_st1)
-  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
+  in (fid_cnt2,prods,lindefs,linrefs,array (0,Map.size fun_st2-1) (Map.elems fun_st2))
   where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
+    mkCncCats []                                                          fid_cnt lindefs linrefs fun_st =
-      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+      (fid_cnt,lindefs,linrefs,fun_st)
-    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt lindefs linrefs fun_st =
-      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+      let mseqs   = case lookupModule gr m of
-                       in funs_cnt+(e_funid-s_funid+1)
+                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+                      _                              -> ex_seqs
-          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
+          (lindefs',fun_st1) = foldl' (toLinDef (m,id) funs0 mseqs) (lindefs,fun_st ) prods0
-          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
+          (linrefs',fun_st2) = foldl' (toLinRef (m,id) funs0 mseqs) (linrefs,fun_st1) prods0
-      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+      in mkCncCats cdefs fid_cnt lindefs' linrefs' fun_st2
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+    mkCncCats (_                                                  :cdefs) fid_cnt lindefs linrefs fun_st =
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
+      mkCncCats cdefs fid_cnt lindefs linrefs fun_st
 
-    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
+    mkCncFuns []                                                        lindefs st = st
-      (fid_cnt,funs_cnt,funs,prods)
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) lindefs st =
-    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
+      let ty_C    = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
-      let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
+          mseqs   = case lookupModule gr m of
-          ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                      _                              -> ex_seqs
-                           in funs_cnt+(e_funid-s_funid+1)
+          bundles = [([(args0,res0) | Production res0 funid0 args0 <- prods0, funid0==funid],lins) | (funid,lins) <- assocs funs0]
-          !(fid_cnt',crc',prods') 
+          !st'    = foldl' (toProd id lindefs mseqs ty_C) st bundles
-                         = foldl' (toProd lindefs ty_C funs_cnt)
+      in mkCncFuns cdefs lindefs st'
-                                  (fid_cnt,crc,prods) prods0
+    mkCncFuns (_                                                :cdefs) lindefs st =
-          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
+      mkCncFuns cdefs lindefs st
-      in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
-    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
-      mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
 
-    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
+    toLinDef mid funs0 mseqs st@(lindefs,fun_st) (Production res0 funid0 [arg0])
-      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
+      | arg0 == [fidVar] =
-          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
+          let res  = mkFId mid res0
-          fid     = mkFId res_C fid0
+
-          !prods' = case IntMap.lookup fid prods of
+              lins = amap (newSeqId mseqs) (funs0 ! funid0)
-                     Just set -> IntMap.insert fid (Set.union set0 set) prods
+
-                     Nothing  -> IntMap.insert fid set0 prods
+              !funid    = Map.size fun_st
-      in (fid_cnt,crc,prods')
+              !fun_st'  = Map.insert ([([C.PArg [] fidVar],res)],lins) (funid, C.CncFun [] lins) fun_st
+
+              !lindefs' = IntMap.insertWith (++) res [funid] lindefs
+          in (lindefs',fun_st')
+    toLinDef res funs0 mseqs st _ = st
+
+    toLinRef mid funs0 mseqs st (Production res0 funid0 [arg0])
+      | res0 == fidVar  =
+          let arg  = map (mkFId mid) arg0
+
+              lins = amap (newSeqId mseqs) (funs0 ! funid0)
+
+          in foldr (\arg (linrefs,fun_st) -> 
+                          let !funid    = Map.size fun_st
+                              !fun_st'  = Map.insert ([([C.PArg [] arg],fidVar)],lins) (funid, C.CncFun [] lins) fun_st
+
+                              !linrefs' = IntMap.insertWith (++) arg [funid] linrefs
+                          in (linrefs',fun_st'))
+                   st arg
+    toLinRef res funs0 mseqs st _ = st
+
+    toProd id lindefs mseqs (ctxt_C,res_C,_) (prod_st,fun_st) (sigs0,lins0) =
+      let (prod_st',sigs) = mapAccumL mkCncSig prod_st sigs0
+          lins            = amap (newSeqId mseqs) lins0
+      in addBundle id (prod_st',fun_st) (concat sigs,lins)
       where
-        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
+        mkCncSig prod_st (args0,res0) =
+          let !(prod_st',args) = mapAccumL mkArg prod_st (zip ctxt_C args0)
+              res              = mkFId res_C res0
+          in (prod_st',[(args,res) | args <- sequence args])
+
+        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
           case fid0s of
             [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
             fid0s  -> case Map.lookup fids crc of
@@ -246,43 +273,16 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
                                     in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
           where
             (hargs_C,arg_C) = GM.catSkeleton ty
-            ctxt = mapM (mkCtxt lindefs) hargs_C
+            ctxt = mapM mkCtxt hargs_C
             fids = map (mkFId arg_C) fid0s
 
-    mkLinDefId id = prefixIdent "lindef " id
+        mkCtxt (_,cat) =
+          case Map.lookup (i2i cat) cnccats of
+            Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+            Nothing               -> error "GrammarToPGF.mkCtxt failed"
 
-    toLinDef res offs lindefs (Production fid0 funid0 args) =
+    newSeqId mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
-      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
-        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
-
-    mkCtxt lindefs (_,cat) =
-      case Map.lookup (i2i cat) cnccats of
-        Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
-        Nothing               -> error "GrammarToPGF.mkCtxt failed"
-
-    toCncFun offs (m,id) funs (funid0,lins0) =
-      let mseqs = case lookupModule gr m of
-                    Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-                    _                              -> ex_seqs
-      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
-      where
-        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
-           
         binSearch v arr (i,j)
           | i <= j    = case compare v (arr ! k) of
                           LT -> binSearch v arr (i,k-1)
@@ -292,6 +292,24 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
           where
             k = (i+j) `div` 2
 
+    addBundle id ((fid_cnt,crc,prods),fun_st) bundle@(sigs,lins) =
+      case Map.lookup bundle fun_st of
+        Just (funid, C.CncFun funs lins) -> 
+          let !fun_st' = Map.insert bundle (funid, C.CncFun (i2i id:funs) lins) fun_st
+              !prods'  = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
+          in ((fid_cnt,crc,prods'),fun_st')
+        Nothing                          -> 
+          let !funid   = Map.size fun_st
+              !fun_st' = Map.insert bundle (funid, C.CncFun [i2i id] lins) fun_st
+              !prods'  = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
+          in ((fid_cnt,crc,prods'),fun_st')
+
+    mkFId (_,cat) fid0 =
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> s+fid0
+        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+
+
 genPrintNames cdefs =
   Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
   where
@@ -306,3 +324,29 @@ genPrintNames cdefs =
 --mkArray    lst = listArray (0,length lst-1) lst
 mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
 mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
+
+
+
+readDepConfig :: FilePath -> IO (Map.Map CId [DepPragma])
+readDepConfig fpath =
+  fmap (Map.fromList . concatMap toEntry . lines) $ readFile fpath
+  where
+    toEntry l =
+      case words l of
+        []       -> []
+        ("--":_) -> []
+        (fun:ws) -> [(mkCId fun,[toPragma w | w <- ws])]
+
+    toPragma "head"                   = Head 0         ""
+    toPragma ('h':'e':'a':'d':':':cs) =
+      case break (==':') cs of
+        (lbl,[]    ) ->                 Head 0         lbl
+        (lbl,':':cs) ->                 Head (read cs) lbl
+    toPragma "rel"                    = Rel  0
+    toPragma ('r':'e':'l':':':cs)     = Rel  (read cs)
+    toPragma "_"                      = Skip
+    toPragma "anchor"                 = Anch
+    toPragma s                        =
+      case break (==':') s of
+        (lbl,[]    ) ->                 Mod  0         lbl
+        (lbl,':':cs) ->                 Mod  (read cs) lbl

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -273,7 +273,7 @@ hSkeleton gr =
    fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
    valtyps (_, (_,x)) (_, (_,y)) = compare x y
    valtypg (_, (_,x)) (_, (_,y)) = x == y
-   jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
+   jty (f,(ty,_,_,_,_)) = (f,catSkeleton ty)
 {-
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
 updateSkeleton cat skel rule =

src/compiler/GF/Compile/PGFtoJS.hs

@@ -32,8 +32,8 @@ pgf2js pgf =
 abstract2js :: String -> Abstr -> JS.Expr
 abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
 
-absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
+absdef2js :: (CId,(Type,[DepPragma],Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
-absdef2js (f,(typ,_,_,_)) =
+absdef2js (f,(typ,_,_,_,_)) =
   let (args,cat) = M.catSkeleton typ in 
     JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
 
@@ -78,7 +78,7 @@ frule2js (PCoerce arg)       = new "Coerce" [JS.EInt arg]
 
 farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
 
-ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))]
+ffun2js (CncFun fns lins) = new "CncFun" [JS.EArray (map (JS.EStr . showCId) fns), JS.EArray (map JS.EInt (Array.elems lins))]
 
 seq2js :: Array.Array DotPos Symbol -> JS.Expr
 seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]

src/compiler/GF/Compile/PGFtoProlog.hs

@@ -54,11 +54,11 @@ plAbstract name abs
                         let args = reverse [EFun x | (_,x) <- subst]] ++++
        plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
                    [[plp fun, plType cat args, plHypos hypos] |
-                    (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
+                    (fun, (typ, _, _, _, _)) <- Map.assocs (funs abs),
                     let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
        plFacts name "def" 2 "(?Fun, ?Expr)" 
                    [[plp fun, plp expr] |
-                    (fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
+                    (fun, (_, _, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
                     let (_, expr) = alphaConvert emptyEnv eqs]
       )
     where plType cat args = plTerm (plp cat) (map plp args)

src/compiler/GF/Compile/PGFtoPython.hs

@@ -40,8 +40,8 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
       abs = abstract pgf
       cncs = concretes pgf
 
-pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
+pyAbsdef :: (Type, [DepPragma], Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
-pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
+pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
     where (args, cat) = M.catSkeleton typ 
 
 pyLiteral :: Literal -> String
@@ -62,7 +62,7 @@ pyConcrete cnc = pyDict 3 pyStr id [
                  ]
     where pyProds prods = pyList 5 pyProduction (Set.toList prods)
           pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end]
-          pyCncFun (CncFun f lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyCId f]
+          pyCncFun (CncFun fns lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyList 0 pyCId fns]
           pySymbols syms = pyList 0 pySymbol (Array.elems syms)
 
 pyProduction :: Production -> String

src/compiler/GF/Infra/Option.hs

@@ -157,6 +157,7 @@ data Flags = Flags {
       optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
+      optLabelsFile      :: Maybe FilePath,
       optRetainResource  :: Bool,
       optName            :: Maybe String,
       optPreprocessors   :: [String],
@@ -268,6 +269,7 @@ defaultFlags = Flags {
       optDocumentRoot    = Nothing,
       optRecomp          = RecompIfNewer,
       optProbsFile       = Nothing,
+      optLabelsFile      = Nothing,
       optRetainResource  = False,
 
       optName            = Nothing,
@@ -349,8 +351,9 @@ optDescr =
      Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
                  "Never recompile from source, if there is already .gfo file.",
      Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
-     Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
+     Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from a file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     Option [] ["depconf"] (ReqArg labelsFile "file.labels") "Read a configuration for generation of syntactic dependency graphs from a file.",
+     Option ['n'] ["name"] (ReqArg name "NAME")
            (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
                      "with suffixes depending on the formats, and, when relevant, ",
                      "internally in the output."]),
@@ -428,6 +431,7 @@ optDescr =
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
+       labelsFile  x = set $ \o -> o { optLabelsFile = Just x }
 
        name        x = set $ \o -> o { optName = Just x }
        addLibDir   x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }

src/compiler/GF/Speech/PGFToCFG.hs

@@ -74,12 +74,15 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
 
     ruleToCFRule :: (FId,Production) -> [CFRule]
     ruleToCFRule (c,PApply funid args) = 
-        [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
+        [Rule (fcatToCat c l) (mkRhs row) term
            | (l,seqid) <- Array.assocs rhs
            , let row = sequences cnc ! seqid
-           , not (containsLiterals row)]
+           , not (containsLiterals row)
+           , f <- fns
+           , let term = profilesToTerm f [fixProfile row n | n <- [0..length args-1]]
+           ]
       where
-        CncFun f rhs = cncfuns cnc ! funid
+        CncFun fns rhs = cncfuns cnc ! funid
 
         mkRhs :: Array DotPos Symbol -> [CFSymbol]
         mkRhs = concatMap symbolToCFSymbol . Array.elems
@@ -111,8 +114,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
               getPos (SymLit j _) = [j]
               getPos _            = []
 
-        profilesToTerm :: [Profile] -> CFTerm
+        profilesToTerm :: CId -> [Profile] -> CFTerm
-        profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
+        profilesToTerm f ps = CFObj f (zipWith profileToTerm argTypes ps)
             where (argTypes,_) = catSkeleton $ lookType (abstract pgf) f
 
         profileToTerm :: CId -> Profile -> CFTerm

src/runtime/c/pgf/data.h

@@ -76,9 +76,27 @@ typedef GuSeq PgfEquations;
 
 typedef void *PgfFunction;
 
+typedef enum {
+	PGF_DEP_PRAGMA_HEAD,
+	PGF_DEP_PRAGMA_MOD,
+	PGF_DEP_PRAGMA_REL,
+	PGF_DEP_PRAGMA_SKIP,
+	PGF_DEP_PRAGMA_ANCH,
+	PGF_DEP_PRAGMA_TAGS
+} PgfDepPragmaTag;
+
+typedef struct {
+	PgfDepPragmaTag tag;
+	size_t   index;
+	GuString label;
+} PgfDepPragma;
+
+typedef GuSeq PgfDepPragmas;
+
 typedef struct {
 	PgfCId name;
 	PgfType* type;
+	PgfDepPragmas* pragmas;
 	int arity;
 	PgfEquations* defns; // maybe null
 	PgfExprProb ep;
@@ -119,7 +137,6 @@ typedef struct {
 	PgfFlags* aflags;
 	PgfAbsFuns* funs;
 	PgfAbsCats* cats;
-	PgfAbsFun* abs_lin_fun;
 	PgfEvalGates* eval_gates;
 } PgfAbstr;
 
@@ -262,8 +279,8 @@ typedef struct {
 typedef GuSeq PgfSequences;
 
 typedef struct {
-	PgfAbsFun* absfun;
+	GuSeq* absfuns;
-	PgfExprProb *ep;
+	prob_t prob;
     int funid;
 	size_t n_lins;
 	PgfSequence* lins[];

src/runtime/c/pgf/graphviz.c

@@ -413,3 +413,304 @@ pgf_graphviz_word_alignment(PgfConcr** concrs, size_t n_concrs, PgfExpr expr, Pg
 
 	gu_pool_free(tmp_pool);
 }
+
+typedef struct {
+	PgfPGF* pgf;
+	int next_fid;
+	GuBuf* anchors;
+	GuBuf* heads;
+    GuPool* pool;
+} PgfDepGenState;
+
+typedef struct {
+	int fid;
+	int visit;
+	PgfExpr expr;
+	GuBuf* edges;
+} PgfDepNode;
+
+typedef struct {
+	GuString label;
+	PgfDepNode* node;
+} PgfDepEdge;
+
+typedef struct {
+	bool   solved;
+	size_t start;
+	size_t end;
+	GuString label;
+} PgfDepStackRange;
+
+static void
+pgf_graphviz_dependency_graph_(PgfDepGenState* state,
+                               size_t parents_start,size_t parents_end,
+                               GuString head_label, GuString mod_label,
+                               PgfExpr expr);
+
+static bool
+pgf_graphviz_dependency_graph_apply(PgfDepGenState* state,
+                                    size_t parents_start,size_t parents_end,
+                                    GuString head_label, GuString mod_label,
+                                    GuBuf* args, GuSeq* pragmas)
+{
+	size_t n_args    = gu_buf_length(args);
+	size_t n_pragmas = pragmas ? gu_seq_length(pragmas) : 0;
+
+	size_t n_count = (n_args <= n_pragmas) ? n_args : n_pragmas;
+	PgfDepStackRange ranges[n_count+1];
+	for (size_t i = 0; i <= n_count; i++) {
+		ranges[i].solved = false;
+		ranges[i].label =
+			(i > 0) ? gu_seq_index(pragmas, PgfDepPragma, i-1)->label
+					: NULL;
+	}
+
+	ranges[0].start = gu_buf_length(state->heads);
+	ranges[0].end   = gu_buf_length(state->heads);
+
+    bool rel_solved = false;
+	size_t n_solved = 0;
+	size_t count = 0;
+	while (n_solved < n_count) {
+		if (!ranges[0].solved) {
+			ranges[0].start = gu_buf_length(state->heads);
+		}
+
+		for (size_t i = 0; i < n_count; i++) {
+			if (ranges[i+1].solved)
+				continue;
+
+			PgfExpr       arg    = gu_buf_get(args, PgfExpr, n_args-i-1);
+			PgfDepPragma* pragma = gu_seq_index(pragmas, PgfDepPragma, i);
+
+			switch (pragma->tag) {
+			case PGF_DEP_PRAGMA_MOD:
+				assert(pragma->index <= n_count);
+				if (ranges[0].solved && ranges[pragma->index].solved) {
+					ranges[i+1].start = gu_buf_length(state->heads);
+					pgf_graphviz_dependency_graph_(state,
+												   ranges[pragma->index].start, ranges[pragma->index].end,
+												   NULL, ranges[i+1].label,
+												   arg);
+					ranges[i+1].end   = gu_buf_length(state->heads);
+					ranges[i+1].solved= true;
+					n_solved++;
+				}
+				break;
+			case PGF_DEP_PRAGMA_REL:
+				ranges[i+1].solved = true;
+				ranges[i+1].start  = 0;
+				ranges[i+1].end    = 0;
+				n_solved++;
+
+				GuPool *tmp_pool = gu_local_pool();
+
+				GuStringBuf* sbuf =
+					gu_new_string_buf(tmp_pool);
+				GuOut* out = gu_string_buf_out(sbuf);
+				GuExn* err = gu_new_exn(tmp_pool);
+
+				pgf_print_expr(arg, NULL, 0, out, err);
+
+				ranges[pragma->index].label =
+					gu_string_buf_freeze(sbuf, state->pool);
+
+				gu_pool_free(tmp_pool);
+				break;
+			case PGF_DEP_PRAGMA_SKIP:
+				ranges[i+1].solved = true;
+				n_solved++;
+				break;
+			case PGF_DEP_PRAGMA_ANCH:
+				if (ranges[0].solved) {
+					ranges[i+1].start = gu_buf_length(state->heads);
+					pgf_graphviz_dependency_graph_(state,0,0,"ROOT","ROOT",arg);
+					ranges[i+1].end   = gu_buf_length(state->heads);
+					ranges[i+1].solved= true;
+					n_solved++;
+					count++;
+				}
+				break;
+			case PGF_DEP_PRAGMA_HEAD:
+				if (!rel_solved)
+					break;
+
+				if (!ranges[0].solved) {
+					GuString new_head_label = head_label;
+					GuString new_mod_label = mod_label;
+					if (pragma->label != NULL && *pragma->label && pragma->index == 0) {
+						new_head_label = pragma->label;
+						new_mod_label = "ROOT";
+					}
+					if (ranges[0].label != NULL)
+						new_mod_label = ranges[0].label;
+					ranges[i+1].start = gu_buf_length(state->heads);
+					pgf_graphviz_dependency_graph_(state,
+												   parents_start,parents_end,
+												   new_head_label, new_mod_label,
+												   arg);
+					ranges[i+1].end   = gu_buf_length(state->heads);
+					if (pragma->index == 0) {
+						ranges[i+1].solved = true;
+						n_solved++;
+					}
+					count++;
+				}
+				if (pragma->index != 0 && ranges[pragma->index].solved) {
+					for (size_t j = ranges[pragma->index].start; j < ranges[pragma->index].end; j++) {
+						PgfDepNode* parent = gu_buf_get(state->heads, PgfDepNode*, j);
+						for (size_t k = ranges[i+1].start; k < ranges[i+1].end; k++) {
+							PgfDepNode* child = gu_buf_get(state->heads, PgfDepNode*, k);
+							PgfDepEdge* edge = gu_buf_extend(parent->edges);
+							edge->label = pragma->label;
+							edge->node  = child;
+						}
+					}
+					ranges[i+1].solved = true;
+					n_solved++;
+				}
+				break;
+			default:
+				gu_impossible();
+			}
+		}
+
+		if (rel_solved) {
+			if (!ranges[0].solved) {
+				ranges[0].end = gu_buf_length(state->heads);
+				ranges[0].solved = true;
+			}
+		} else {
+			rel_solved = true;
+		}
+	}
+
+	gu_buf_trim_n(state->heads, gu_buf_length(state->heads)-ranges[0].end);
+
+	return (count > 0);
+}
+
+static void
+pgf_graphviz_dependency_graph_(PgfDepGenState* state,
+                               size_t parents_start,size_t parents_end,
+                               GuString head_label, GuString mod_label,
+                               PgfExpr expr)
+{
+	PgfExpr e = expr;
+	GuBuf* args = gu_new_buf(PgfDepNode*, state->pool);
+
+	for (;;) {
+		GuVariantInfo ei = gu_variant_open(e);
+		switch (ei.tag) {
+		case PGF_EXPR_APP: {
+			PgfExprApp* app = ei.data;
+			gu_buf_push(args, PgfExpr, app->arg);
+			e = app->fun;
+			break;
+		}
+		case PGF_EXPR_TYPED: {
+			PgfExprTyped* typed = ei.data;
+			e = typed->expr;
+			break;
+		}
+		case PGF_EXPR_IMPL_ARG: {
+			PgfExprImplArg* implarg = ei.data;
+			e = implarg->expr;
+			break;
+		}
+		case PGF_EXPR_FUN: {
+			PgfExprFun* fun = ei.data;
+			PgfAbsFun* absfun =
+				gu_seq_binsearch(state->pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, fun->fun);
+
+			if (pgf_graphviz_dependency_graph_apply(state,
+			                                        parents_start,parents_end,
+			                                        head_label,mod_label,
+			                                        args,absfun ? absfun->pragmas : NULL))
+				return;
+			// continue to default
+		}
+		default: {
+			PgfDepNode* node = gu_new(PgfDepNode, state->pool);
+			node->fid   = state->next_fid++;
+			node->visit = 0;
+			node->expr  = expr;
+			node->edges = gu_new_buf(PgfDepEdge, state->pool);
+
+			for (size_t i = parents_start; i < parents_end; i++) {
+				PgfDepNode* parent = gu_buf_get(state->heads, PgfDepNode*, i);
+				if (head_label == NULL) {
+					PgfDepEdge* edge = gu_buf_extend(parent->edges);
+					edge->label = mod_label;
+					edge->node  = node;
+				} else {
+					PgfDepEdge* edge = gu_buf_extend(node->edges);
+					edge->label = head_label;
+					edge->node  = parent;
+				}
+			}
+
+			gu_buf_push(state->heads, PgfDepNode*, node);
+			if (head_label != NULL)
+				gu_buf_push(state->anchors, PgfDepNode*, node);
+
+			return;
+		}
+		}
+	}
+}
+
+static void
+pgf_graphviz_print_graph(PgfGraphvizOptions* opts, PgfDepNode* node,
+                         GuOut* out, GuExn* err)
+{
+	if (node->visit++ > 0)
+		return;
+
+	gu_printf(out, err, "  n%d[label = \"", node->fid);
+	pgf_print_expr(node->expr, NULL, 0, out, err);
+	if (opts->nodeColor != NULL && *opts->nodeColor)
+		gu_printf(out, err, ", fontcolor = \"%s\"", opts->nodeColor);
+	if (opts->nodeFont != NULL && *opts->nodeFont)
+		gu_printf(out, err, ", fontname = \"%s\"", opts->nodeFont);
+	gu_puts("\"]\n", out, err);
+
+	size_t n_children = gu_buf_length(node->edges);
+	for (size_t i = 0; i < n_children; i++) {
+		PgfDepEdge* edge = gu_buf_index(node->edges, PgfDepEdge, n_children-i-1);
+		gu_printf(out, err, "  n%d -> n%d [label = \"%s\"",
+		          node->fid, edge->node->fid, edge->label);
+		if (opts->nodeEdgeStyle != NULL && *opts->nodeEdgeStyle)
+			gu_printf(out, err, ", style = \"%s\"", opts->nodeEdgeStyle);
+		if (opts->nodeColor != NULL && *opts->nodeColor)
+			gu_printf(out, err, ", color = \"%s\"", opts->nodeColor);
+		gu_puts("]\n", out, err);
+
+		if (edge->node->fid > node->fid)
+			pgf_graphviz_print_graph(opts, edge->node, out, err);
+	}
+}
+
+void
+pgf_graphviz_dependency_graph(PgfPGF* pgf, PgfExpr expr,
+                              PgfGraphvizOptions* opts,
+                              GuOut* out, GuExn* err,
+                              GuPool* pool)
+{
+	PgfDepGenState state;
+	state.pgf  = pgf;
+	state.next_fid = 1;
+	state.pool = pool;
+	state.anchors = gu_new_buf(PgfDepNode*, pool);
+	state.heads   = gu_new_buf(PgfDepNode*, pool);
+
+	pgf_graphviz_dependency_graph_(&state, 0, 0, "ROOT", "ROOT", expr);
+
+	gu_puts("digraph {\n", out, err);
+	size_t n_anchors = gu_buf_length(state.anchors);
+	for (size_t i = 0; i < n_anchors; i++) {
+		PgfDepNode* node = gu_buf_get(state.anchors, PgfDepNode*, i);
+		pgf_graphviz_print_graph(opts,node,out,err);
+	}
+	gu_puts("}", out, err);
+}

src/runtime/c/pgf/linearizer.c

@@ -40,15 +40,23 @@ pgf_lzr_index(PgfConcr* concr,
 	switch (gu_variant_tag(prod)) {
 	case PGF_PRODUCTION_APPLY: {
 		PgfProductionApply* papply = data;
-		PgfCncOverloadMap* overl_table =
+
-			gu_map_get(concr->fun_indices, papply->fun->absfun->name,
+		size_t n_absfuns = gu_seq_length(papply->fun->absfuns);
-				PgfCncOverloadMap*);
+		for (size_t i = 0; i < n_absfuns; i++) {
-		if (!overl_table) {
+			PgfAbsFun* absfun =
-			overl_table = gu_new_addr_map(PgfCCat*, GuBuf*, &gu_null_struct, pool);
+				gu_seq_get(papply->fun->absfuns, PgfAbsFun*, i);
-			gu_map_put(concr->fun_indices,
+
-				papply->fun->absfun->name, PgfCncOverloadMap*, overl_table);
+			PgfCncOverloadMap* overl_table =
+				gu_map_get(concr->fun_indices, absfun->name,
+					       PgfCncOverloadMap*);
+			if (!overl_table) {
+				overl_table = gu_new_addr_map(PgfCCat*, GuBuf*, &gu_null_struct, pool);
+				gu_map_put(concr->fun_indices,
+					       absfun->name,
+					       PgfCncOverloadMap*, overl_table);
+			}
+			pgf_lzr_add_overl_entry(overl_table, ccat, papply, pool);
 		}
-		pgf_lzr_add_overl_entry(overl_table, ccat, papply, pool);
 		break;
 	}
 	case PGF_PRODUCTION_COERCE: {
@@ -148,7 +156,7 @@ pgf_cnc_resolve(PgfCnc* cnc,
 static PgfCncTree
 pgf_cnc_resolve_app(PgfCnc* cnc,
                     size_t n_vars, PgfPrintContext* context,
-                    PgfCCat* ccat, GuBuf* buf, GuBuf* args,
+                    PgfCCat* ccat, PgfCId abs_id, GuBuf* buf, GuBuf* args,
                     GuPool* pool)
 {
 	GuChoiceMark mark = gu_choice_mark(cnc->ch);
@@ -164,6 +172,7 @@ pgf_cnc_resolve_app(PgfCnc* cnc,
 	capp->ccat    = ccat;
 	capp->n_vars  = n_vars;
 	capp->context = context;
+	capp->abs_id  = abs_id;
 
 redo:;
 	int index = gu_choice_next(cnc->ch, gu_buf_length(buf));
@@ -175,7 +184,6 @@ redo:;
 		gu_buf_get(buf, PgfProductionApply*, index);
 	gu_assert(n_args == gu_seq_length(papply->args));
 
-	capp->abs_id = papply->fun->absfun->name;
 	capp->fun    = papply->fun;
 	capp->fid    = 0;
 	capp->n_args = n_args;
@@ -470,7 +478,7 @@ redo:;
 				gu_map_iter(overl_table, &clo.fn, NULL);
 				assert(clo.ccat != NULL && clo.buf != NULL);
 
-				ret = pgf_cnc_resolve_app(cnc, n_vars, context, clo.ccat, clo.buf, args, pool);
+				ret = pgf_cnc_resolve_app(cnc, n_vars, context, clo.ccat, efun->fun, clo.buf, args, pool);
 				if (gu_variant_is_null(ret)) {
 					gu_choice_reset(cnc->ch, mark);
 					if (gu_choice_advance(cnc->ch))
@@ -483,7 +491,7 @@ redo:;
 					goto done;
 				}
 
-				ret = pgf_cnc_resolve_app(cnc, n_vars, context, ccat, buf, args, pool);
+				ret = pgf_cnc_resolve_app(cnc, n_vars, context, ccat, efun->fun, buf, args, pool);
 			}
 			goto done;
 		}

src/runtime/c/pgf/lookup.c

@@ -803,7 +803,12 @@ pgf_lookup_ctree_to_expr(PgfCncTree ctree, PgfExprProb* ep,
 	switch (cti.tag) {
 	case PGF_CNC_TREE_APP: {
 		PgfCncTreeApp* fapp = cti.data;
-		*ep    = fapp->fun->absfun->ep;
+		if (gu_seq_length(fapp->fun->absfuns) > 0)
+			*ep = gu_seq_get(fapp->fun->absfuns, PgfAbsFun*, 0)->ep;
+		else {
+			ep->expr = gu_null_variant;
+			ep->prob = fapp->fun->prob;
+		}
 		n_args = fapp->n_args;
 		args   = fapp->args;
 		break;
@@ -923,8 +928,15 @@ pgf_lookup_sentence(PgfConcr* concr, PgfType* typ, GuString sentence, GuPool* po
 	size_t n_cncfuns = gu_seq_length(concr->cncfuns);
 	for (size_t i = 0; i < n_cncfuns; i++) {
 		PgfCncFun* cncfun = gu_seq_get(concr->cncfuns, PgfCncFun*, i);
-		for (size_t lin_idx = 0; lin_idx < cncfun->n_lins; lin_idx++) {
+
-			pgf_lookup_index_syms(lexicon_idx, cncfun->lins[lin_idx]->syms, cncfun->absfun, pool);
+		size_t n_absfuns = gu_seq_length(cncfun->absfuns);
+		for (size_t j = 0; j < n_absfuns; j++) {
+			PgfAbsFun* absfun =
+				gu_seq_get(cncfun->absfuns, PgfAbsFun*, j);
+
+			for (size_t lin_idx = 0; lin_idx < cncfun->n_lins; lin_idx++) {
+				pgf_lookup_index_syms(lexicon_idx, cncfun->lins[lin_idx]->syms, absfun, pool);
+			}
 		}
 	}
 

src/runtime/c/pgf/parser.c

@@ -710,8 +710,8 @@ pgf_new_item(PgfParsing* ps, PgfItemConts* conts, PgfProduction prod)
 	case PGF_PRODUCTION_APPLY: {
 		PgfProductionApply* papp = pi.data;
 		item->args = papp->args;
-		item->inside_prob = papp->fun->ep->prob;
+		item->inside_prob = papp->fun->prob;
-		
+
 		int n_args = gu_seq_length(item->args);
 		for (int i = 0; i < n_args; i++) {
 			PgfPArg *arg = gu_seq_index(item->args, PgfPArg, i);
@@ -1265,8 +1265,12 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item)
 			ps->tp = gu_new(PgfTokenProb, ps->out_pool);
 			ps->tp->tok  = tok;
 			ps->tp->cat  = item->conts->ccat->cnccat->abscat->name;
-			ps->tp->fun  = papp->fun->absfun->name;
 			ps->tp->prob = item->inside_prob + item->conts->outside_prob;
+			ps->tp->fun  = "_";
+			
+			if (gu_seq_length(papp->fun->absfuns) > 0)
+				ps->tp->fun = 
+					gu_seq_get(papp->fun->absfuns, PgfAbsFun*, 0)->name;
 		}
 	} else {
 		if (!ps->before->needs_bind && cmp_string(&current, tok, ps->case_sensitive) == 0) {
@@ -1794,19 +1798,25 @@ pgf_result_production(PgfParsing* ps,
 	case PGF_PRODUCTION_APPLY: {
 		PgfProductionApply* papp = pi.data;
 
-		PgfExprState *st = gu_new(PgfExprState, ps->pool);
+		size_t n_absfuns = gu_seq_length(papp->fun->absfuns);
-		st->answers = answers;
+		for (size_t i = 0; i < n_absfuns; i++) {
-		st->ep      = *papp->fun->ep;
+			PgfAbsFun* absfun =
-		st->args    = papp->args;
+				gu_seq_get(papp->fun->absfuns, PgfAbsFun*, i);
-		st->arg_idx = 0;
 
-		size_t n_args = gu_seq_length(st->args);
+			PgfExprState *st = gu_new(PgfExprState, ps->pool);
-		for (size_t k = 0; k < n_args; k++) {
+			st->answers = answers;
-			PgfPArg* parg = gu_seq_index(st->args, PgfPArg, k);
+			st->ep      = absfun->ep;
-			st->ep.prob += parg->ccat->viterbi_prob;
+			st->args    = papp->args;
+			st->arg_idx = 0;
+
+			size_t n_args = gu_seq_length(st->args);
+			for (size_t k = 0; k < n_args; k++) {
+				PgfPArg* parg = gu_seq_index(st->args, PgfPArg, k);
+				st->ep.prob += parg->ccat->viterbi_prob;
+			}
+
+			gu_buf_heap_push(ps->expr_queue, &pgf_expr_state_order, &st);
 		}
-
-		gu_buf_heap_push(ps->expr_queue, &pgf_expr_state_order, &st);
 		break;
 	}
 	case PGF_PRODUCTION_COERCE: {
@@ -2355,15 +2365,20 @@ pgf_morpho_iter(PgfProductionIdx* idx,
 		PgfProductionIdxEntry* entry =
 			gu_buf_index(idx, PgfProductionIdxEntry, i);
 
-		PgfCId lemma = entry->papp->fun->absfun->name;
+		size_t n_absfuns = gu_seq_length(entry->papp->fun->absfuns);
-		GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
+		for (size_t j = 0; j < n_absfuns; j++) {
-		
+			PgfAbsFun* absfun =
-		prob_t prob = entry->ccat->cnccat->abscat->prob +
+				gu_seq_get(entry->papp->fun->absfuns, PgfAbsFun*, j);
-		              entry->papp->fun->absfun->ep.prob;
+			PgfCId lemma = absfun->name;
-		callback->callback(callback,
+			GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
-						   lemma, analysis, prob, err);
+			
-		if (!gu_ok(err))
+			prob_t prob = entry->ccat->cnccat->abscat->prob +
-			return;
+						  absfun->ep.prob;
+			callback->callback(callback,
+							   lemma, analysis, prob, err);
+			if (!gu_ok(err))
+				return;
+		}
 	}
 }
 
@@ -2569,7 +2584,7 @@ pgf_ccat_set_viterbi_prob(PgfCCat* ccat) {
 			return INFINITY;
 
 		prob_t viterbi_prob = INFINITY;
-		
+
 		size_t n_prods = gu_seq_length(ccat->prods);
 		for (size_t i = 0; i < n_prods; i++) {
 			PgfProduction prod =
@@ -2581,7 +2596,7 @@ pgf_ccat_set_viterbi_prob(PgfCCat* ccat) {
 			switch (inf.tag) {
 			case PGF_PRODUCTION_APPLY: {
 				PgfProductionApply* papp = inf.data;
-				prob = papp->fun->ep->prob;
+				prob = papp->fun->prob;
 				
 				size_t n_args = gu_seq_length(papp->args);
 				for (size_t j = 0; j < n_args; j++) {

src/runtime/c/pgf/printer.c

@@ -60,7 +60,44 @@ pgf_print_absfuns(PgfAbsFuns* absfuns, GuOut *out, GuExn* err)
 		pgf_print_cid(absfun->name, out, err);
 		gu_puts(" : ", out, err);
 		pgf_print_type(absfun->type, NULL, 0, out, err);
-		gu_printf(out, err, " ;   -- %f\n", absfun->ep.prob);
+		gu_printf(out, err, " ;   -- %f ", absfun->ep.prob);
+		
+		size_t n_pragmas = gu_seq_length(absfun->pragmas);
+		for (size_t i = 0; i < n_pragmas; i++) {
+			PgfDepPragma* pragma =
+				gu_seq_index(absfun->pragmas, PgfDepPragma, i);
+			switch (pragma->tag) {
+			case PGF_DEP_PRAGMA_HEAD:
+				gu_puts("head",out,err);
+				if (pragma->index > 0)
+					gu_printf(out,err,":%d", pragma->index);
+				if (pragma->label != NULL &&  *pragma->label != 0)
+					gu_printf(out,err,":%s", pragma->label);
+				break;
+			case PGF_DEP_PRAGMA_MOD:
+				gu_puts(pragma->label, out,err);
+				if (pragma->index > 0)
+					gu_printf(out,err,":%d", pragma->index);
+				break;
+			case PGF_DEP_PRAGMA_REL:
+				gu_puts("rel",out,err);
+				if (pragma->index > 0)
+					gu_printf(out,err,":%d", pragma->index);
+				break;
+			case PGF_DEP_PRAGMA_SKIP:
+				gu_puts("_",out,err);
+				break;
+			case PGF_DEP_PRAGMA_ANCH:
+				gu_puts("anchor",out,err);
+				break;
+			default:
+				gu_impossible();
+			}
+
+			gu_putc(' ', out, err);
+		}
+
+		gu_putc('\n', out, err);
 	}
 }
 static void
@@ -206,15 +243,17 @@ pgf_print_cncfun(PgfCncFun *cncfun, PgfSequences* sequences,
 		gu_printf(out,err,"S%d", (seq - ((PgfSequence*) gu_seq_data(sequences))));
 	}
 
-	gu_puts(")", out, err);
+	gu_puts(") [", out, err);
-	
+
-	if (cncfun->absfun != NULL) {
+	size_t n_absfuns = gu_seq_length(cncfun->absfuns);
-		gu_puts(" [", out, err);
+	for (size_t i = 0; i < n_absfuns; i++) {
-		pgf_print_cid(cncfun->absfun->name, out, err);
+		PgfAbsFun* absfun =
-		gu_puts("]", out, err);
+			gu_seq_get(cncfun->absfuns, PgfAbsFun*, i);
+
+		pgf_print_cid(absfun->name, out, err);
 	}
-	
+
-	gu_puts("\n", out, err);
+	gu_puts("]\n", out, err);
 }
 
 static void

src/runtime/c/pgf/reader.c

@@ -407,6 +407,45 @@ pgf_read_patt(PgfReader* rdr)
 	return patt;
 }
 
+static PgfDepPragmas*
+pgf_read_deppragmas(PgfReader* rdr)
+{
+	size_t n_pragmas = pgf_read_len(rdr);
+	gu_return_on_exn(rdr->err, NULL);
+
+	GuSeq* pragmas = gu_new_seq(PgfDepPragma, n_pragmas, rdr->opool);
+	for (size_t i = 0; i < n_pragmas; i++) {
+		PgfDepPragma* pragma = gu_seq_index(pragmas, PgfDepPragma, i);
+		pragma->tag = pgf_read_tag(rdr);
+		gu_return_on_exn(rdr->err, NULL);
+		switch (pragma->tag) {
+		case PGF_DEP_PRAGMA_HEAD:
+			pragma->index = pgf_read_int(rdr);
+			pragma->label = pgf_read_string(rdr);
+			break;
+		case PGF_DEP_PRAGMA_MOD:
+			pragma->index = pgf_read_int(rdr);
+			pragma->label = pgf_read_string(rdr);
+			break;
+		case PGF_DEP_PRAGMA_REL:
+			pragma->index = pgf_read_int(rdr);
+			pragma->label = NULL;
+			break;
+		case PGF_DEP_PRAGMA_SKIP:
+			pragma->index = 0;
+			pragma->label = NULL;
+			break;
+		case PGF_DEP_PRAGMA_ANCH:
+			pragma->index = 0;
+			pragma->label = NULL;
+			break;
+		default:
+			pgf_read_tag_error(rdr);
+		}
+	}
+	return pragmas;
+}
+
 static PgfAbsFun*
 pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* absfun)
 {
@@ -426,6 +465,9 @@ pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* absfun)
 	absfun->type = pgf_read_type_(rdr);
 	gu_return_on_exn(rdr->err, NULL);
 
+	absfun->pragmas = pgf_read_deppragmas(rdr);
+	gu_return_on_exn(rdr->err, NULL);
+
 	absfun->arity = pgf_read_int(rdr);
 
 	uint8_t tag = pgf_read_tag(rdr);
@@ -549,17 +591,6 @@ pgf_read_abstract(PgfReader* rdr, PgfAbstr* abstract)
 	
 	abstract->cats = pgf_read_abscats(rdr, abstract);
 	gu_return_on_exn(rdr->err, );
-
-	abstract->abs_lin_fun = gu_new(PgfAbsFun, rdr->opool);
-	abstract->abs_lin_fun->name = "_";
-	abstract->abs_lin_fun->type = gu_new(PgfType, rdr->opool);
-	abstract->abs_lin_fun->type->hypos = NULL;
-	abstract->abs_lin_fun->type->cid = "_";
-	abstract->abs_lin_fun->type->n_exprs = 0;
-	abstract->abs_lin_fun->arity = 0;
-	abstract->abs_lin_fun->defns = NULL;
-	abstract->abs_lin_fun->ep.prob = INFINITY;
-	abstract->abs_lin_fun->ep.expr = gu_null_variant;
 }
 
 static PgfCIdMap*
@@ -776,22 +807,38 @@ pgf_read_sequences(PgfReader* rdr)
 static PgfCncFun*
 pgf_read_cncfun(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, int funid)
 {
-	PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool);
+	size_t n_absfuns = pgf_read_len(rdr);
+	GuSeq* absfuns =
+		gu_new_seq(PgfAbsFun*, n_absfuns, rdr->opool);
+	prob_t prob;
+	if (n_absfuns == 0)
+		prob = 0;
+	else {
+		prob = INFINITY;
+		for (size_t i = 0; i < n_absfuns; i++) {
+			PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool);
+			gu_return_on_exn(rdr->err, NULL);
+			
+			PgfAbsFun* absfun =
+				gu_seq_binsearch(abstr->funs, pgf_absfun_order, PgfAbsFun, name);
+
+			if (prob > absfun->ep.prob)
+				prob = absfun->ep.prob;
+
+			gu_seq_set(absfuns, PgfAbsFun*, i, absfun);
+		}
+	}
+
+	size_t n_lins = pgf_read_len(rdr);
 	gu_return_on_exn(rdr->err, NULL);
 
-	size_t len = pgf_read_len(rdr);
+	PgfCncFun* cncfun = gu_new_flex(rdr->opool, PgfCncFun, lins, n_lins);
-	gu_return_on_exn(rdr->err, NULL);
+	cncfun->absfuns = absfuns;
-
+	cncfun->prob = prob;
-	PgfAbsFun* absfun =
-		gu_seq_binsearch(abstr->funs, pgf_absfun_order, PgfAbsFun, name);
-
-	PgfCncFun* cncfun = gu_new_flex(rdr->opool, PgfCncFun, lins, len);
-	cncfun->absfun = absfun;
-	cncfun->ep = (absfun == NULL) ? NULL : &absfun->ep;
 	cncfun->funid = funid;
-	cncfun->n_lins = len;
+	cncfun->n_lins = n_lins;
 
-	for (size_t i = 0; i < len; i++) {
+	for (size_t i = 0; i < n_lins; i++) {
 		size_t seqid = pgf_read_int(rdr);
 		gu_return_on_exn(rdr->err, NULL);
 
@@ -878,7 +925,6 @@ pgf_read_lindefs(PgfReader* rdr, PgfConcr* concr)
 		ccat->lindefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
 		for (size_t j = 0; j < n_funs; j++) {
 			PgfCncFun* fun = pgf_read_funid(rdr, concr);
-			fun->absfun = concr->abstr->abs_lin_fun;
 			gu_seq_set(ccat->lindefs, PgfCncFun*, j, fun);
 		}
 	}
@@ -899,7 +945,6 @@ pgf_read_linrefs(PgfReader* rdr, PgfConcr* concr)
 		ccat->linrefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
 		for (size_t j = 0; j < n_funs; j++) {
 			PgfCncFun* fun = pgf_read_funid(rdr, concr);
-			fun->absfun = concr->abstr->abs_lin_fun;
 			gu_seq_set(ccat->linrefs, PgfCncFun*, j, fun);
 		}
 	}

src/runtime/c/pgf/writer.c

@@ -311,6 +311,32 @@ pgf_write_absfun(PgfAbsFun* absfun, PgfWriter* wtr)
 
 	pgf_write_type_(absfun->type, wtr);
 	gu_return_on_exn(wtr->err, );
+	
+	size_t n_pragmas = gu_seq_length(absfun->pragmas);
+	for (size_t i = 0; i < n_pragmas; i++) {
+		PgfDepPragma* pragma =
+			gu_seq_index(absfun->pragmas, PgfDepPragma, i);
+			
+		pgf_write_tag(pragma->tag, wtr);
+		switch (pragma->tag) {
+		case PGF_DEP_PRAGMA_HEAD:
+			pgf_write_int(pragma->index, wtr);
+			pgf_write_string(pragma->label, wtr);
+			break;
+		case PGF_DEP_PRAGMA_MOD:
+			pgf_write_int(pragma->index, wtr);
+			pgf_write_string(pragma->label, wtr);
+			break;
+		case PGF_DEP_PRAGMA_REL:
+			pgf_write_int(pragma->index, wtr);
+			break;
+		case PGF_DEP_PRAGMA_SKIP:
+		case PGF_DEP_PRAGMA_ANCH:
+			break;
+		default:
+			gu_impossible();
+		}
+	}
 
 	pgf_write_int(absfun->arity, wtr);
 
@@ -579,8 +605,15 @@ pgf_write_sequences(PgfSequences* seqs, PgfWriter* wtr)
 static void
 pgf_write_cncfun(PgfCncFun* cncfun, PgfConcr* concr, PgfWriter* wtr)
 {
-	pgf_write_cid(cncfun->absfun->name, wtr);
+	size_t n_absfuns = gu_seq_length(cncfun->absfuns);
-	gu_return_on_exn(wtr->err, );
+	pgf_write_len(n_absfuns, wtr);
+	for (size_t i = 0; i < n_absfuns; i++) {
+		PgfAbsFun* absfun =
+			gu_seq_get(cncfun->absfuns, PgfAbsFun*, i);
+
+		pgf_write_cid(absfun->name, wtr);
+		gu_return_on_exn(wtr->err, );
+	}
 
 	pgf_write_len(cncfun->n_lins, wtr);
 	gu_return_on_exn(wtr->err, );

src/runtime/c/sg/sg.c

@@ -1305,20 +1305,26 @@ sg_update_fts_index(SgSG* sg, PgfPGF* pgf, GuExn* err)
 		for (size_t funid = 0; funid < n_funs; funid++) {
 			PgfCncFun* cncfun = gu_seq_get(concr->cncfuns, PgfCncFun*, funid);
 
-			SgId key = 0;
+			size_t n_absfuns = gu_seq_length(cncfun->absfuns);
-			rc = find_function_rowid(sg, &ctxt, cncfun->absfun->name, &key, 1);
+			for (size_t i = 0; i < n_absfuns; i++) {
-			if (rc != SQLITE_OK) {
+				PgfAbsFun* absfun =
-				sg_raise_sqlite(rc, err);
+					gu_seq_get(cncfun->absfuns, PgfAbsFun*, i);
-				goto close;
-			}
 
-			for (size_t lin_idx = 0; lin_idx < cncfun->n_lins; lin_idx++) {
+				SgId key = 0;
-				PgfSequence* seq = cncfun->lins[lin_idx];
+				rc = find_function_rowid(sg, &ctxt, absfun->name, &key, 1);
-				rc = insert_syms(sg, crsTokens, seq->syms, key);
 				if (rc != SQLITE_OK) {
 					sg_raise_sqlite(rc, err);
 					goto close;
 				}
+
+				for (size_t lin_idx = 0; lin_idx < cncfun->n_lins; lin_idx++) {
+					PgfSequence* seq = cncfun->lins[lin_idx];
+					rc = insert_syms(sg, crsTokens, seq->syms, key);
+					if (rc != SQLITE_OK) {
+						sg_raise_sqlite(rc, err);
+						goto close;
+					}
+				}
 			}
 		}
 	}

src/runtime/haskell-bind/PGF2.hsc

@@ -73,7 +73,7 @@ module PGF2 (-- * PGF
              MorphoAnalysis, lookupMorpho, fullFormLexicon,
              -- ** Visualizations
              GraphvizOptions(..), graphvizDefaults,
-             graphvizAbstractTree, graphvizParseTree, graphvizWordAlignment,
+             graphvizAbstractTree, graphvizParseTree, graphvizDependencyGraph, graphvizWordAlignment,
 
              -- * Exceptions
              PGFError(..),
@@ -140,14 +140,13 @@ readPGF fpath =
 
 showPGF :: PGF -> String
 showPGF p =
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         pgf_print (pgf p) out exn
+    pgf_print (pgf p) out exn
-         touchPGF p
+    touchPGF p
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
 
 -- | List of all languages available in the grammar.
 languages :: PGF -> Map.Map ConcName Concr
@@ -411,41 +410,48 @@ graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
 -- | Renders an abstract syntax tree in a Graphviz format.
 graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
 graphvizAbstractTree p opts e =
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
+    c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
+    pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
-         touchExpr e
+    touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
-
 
 graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
 graphvizParseTree c opts e =
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
+    c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
+    pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
-         touchExpr e
+    touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
+
+graphvizDependencyGraph :: PGF -> GraphvizOptions -> Expr -> String
+graphvizDependencyGraph p opts e =
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    c_opts <- newGraphvizOptions tmpPl opts
+    pgf_graphviz_dependency_graph (pgf p) (expr e) c_opts out exn tmpPl
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
 graphvizWordAlignment cs opts e =
   unsafePerformIO $
-    withGuPool $ \tmpPl ->
     withArrayLen (map concr cs) $ \n_concrs ptr ->
-      do (sb,out) <- newOut tmpPl
+      do tmpPl <- gu_new_pool
+         (sb,out) <- newOut tmpPl
          exn <- gu_new_exn tmpPl
          c_opts <- newGraphvizOptions tmpPl opts
          pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn
          touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
+         peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
 
 newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions)
 newGraphvizOptions pool opts = do
@@ -750,8 +756,7 @@ linearize lang e = unsafePerformIO $
                                      msg <- peekUtf8CString c_msg
                                      throwIO (PGFError msg)
                              else throwIO (PGFError "The abstract tree cannot be linearized")
-         else do lin <- gu_string_buf_freeze sb pl
+         else do peekUtf8CStringBuf sb
-                 peekUtf8CString lin
 
 -- | Generates all possible linearizations of an expression
 linearizeAll :: Concr -> Expr -> [String]
@@ -780,8 +785,7 @@ linearizeAll lang e = unsafePerformIO $
                           if is_nonexist
                             then collect cts exn pl
                             else throwExn exn pl
-                  else do lin <- gu_string_buf_freeze sb tmpPl
+                  else do s  <- peekUtf8CStringBuf sb
-                          s <- peekUtf8CString lin
                           ss <- collect cts exn pl
                           return (s:ss)
 
@@ -841,8 +845,7 @@ tabularLinearizeAll lang e = unsafePerformIO $
                 if is_nonexist
                   then collectTable lang ctree (lin_idx+1) labels exn tmpPl
                   else throwExn exn
-        else do lin <- gu_string_buf_freeze sb tmpPl
+        else do s  <- peekUtf8CStringBuf sb
-                s  <- peekUtf8CString lin
                 ss <- collectTable lang ctree (lin_idx+1) labels exn tmpPl
                 return ((label,s):ss)
 

src/runtime/haskell-bind/PGF2/Expr.hsc

@@ -252,15 +252,14 @@ foreign import ccall "wrapper"
 -- of binding.
 showExpr :: [CId] -> Expr -> String
 showExpr scope e = 
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         pgf_print_expr (expr e) printCtxt 1 out exn
+    pgf_print_expr (expr e) printCtxt 1 out exn
-         touchExpr e
+    touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
 
 newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
 newPrintCtxt []     pool = return nullPtr

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -15,6 +15,7 @@ import Control.Exception
 import GHC.Ptr
 import Data.Int
 import Data.Word
+import System.IO.Unsafe
 
 type Touch = IO ()
 
@@ -106,6 +107,12 @@ foreign import ccall unsafe "gu/enum.h gu_enum_next"
 foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
   gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
 
+foreign import ccall unsafe "gu/string.h gu_string_buf_data"
+  gu_string_buf_data :: Ptr GuStringBuf -> IO CString
+
+foreign import ccall unsafe "gu/string.h gu_string_buf_length"
+  gu_string_buf_length :: Ptr GuStringBuf -> IO CSizeT
+
 foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
   gu_utf8_decode :: Ptr CString -> IO GuUCS
 
@@ -186,6 +193,29 @@ peekUtf8CStringLen ptr len =
                 cs <- decode pptr end
                 return (((toEnum . fromEnum) x) : cs)
 
+peekUtf8CStringBuf :: Ptr GuStringBuf -> IO String
+peekUtf8CStringBuf sbuf = do
+  ptr <- gu_string_buf_data sbuf
+  len <- gu_string_buf_length sbuf
+  peekUtf8CStringLen ptr (fromIntegral len)
+
+peekUtf8CStringBufResult :: Ptr GuStringBuf -> Ptr GuPool -> IO String
+peekUtf8CStringBufResult sbuf pool = do
+  fptr <- newForeignPtr gu_pool_finalizer pool
+  ptr <- gu_string_buf_data sbuf
+  len <- gu_string_buf_length sbuf
+  pptr <- gu_malloc pool (#size GuString*)
+  poke pptr ptr >> decode fptr pptr (ptr `plusPtr` fromIntegral len)
+  where
+    decode fptr pptr end = do
+      ptr <- peek pptr
+      if ptr >= end
+        then return []
+        else do x <- gu_utf8_decode pptr
+                cs <- unsafeInterleaveIO (decode fptr pptr end)
+                touchForeignPtr fptr
+                return (((toEnum . fromEnum) x) : cs)
+
 pokeUtf8CString :: String -> CString -> IO ()
 pokeUtf8CString s ptr =
   alloca $ \pptr ->
@@ -518,6 +548,9 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
   pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
+  
+foreign import ccall "pgf/graphviz.h pgf_graphviz_dependency_graph"
+  pgf_graphviz_dependency_graph :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO ()
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
   pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()

src/runtime/haskell-bind/PGF2/Internal.hsc

@@ -194,21 +194,24 @@ concrTotalFuns c = unsafePerformIO $ do
   touchConcr c
   return (fromIntegral (c_len :: CSizeT))
 
-concrFunction :: Concr -> FunId -> (Fun,[SeqId])
+concrFunction :: Concr -> FunId -> ([Fun],[SeqId])
 concrFunction c funid = unsafePerformIO $ do
   c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
   c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*)))
-  c_absfun <- (#peek PgfCncFun, absfun) c_cncfun
+  c_absfuns <- (#peek PgfCncFun, absfuns) c_cncfun
-  c_name <- (#peek PgfAbsFun, name) c_absfun
+  names <- peekSequence peekAbsName (#size PgfAbsFun*) c_absfuns
-  name <- peekUtf8CString c_name
   c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun
   arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins))
   seqs_seq <- (#peek PgfConcr, sequences) (concr c)
   touchConcr c
   let seqs = seqs_seq `plusPtr` (#offset GuSeq, data)
-  return (name, map (toSeqId seqs) arr)
+  return (names, map (toSeqId seqs) arr)
   where
     toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence)
+    
+    peekAbsName c_absfun = do
+      c_name <- (#peek PgfAbsFun, name) c_absfun
+      peekUtf8CString c_name
 
 concrTotalSeqs :: Concr -> SeqId
 concrTotalSeqs c = unsafePerformIO $ do
@@ -445,7 +448,7 @@ newHypos hypos pool = do
             Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
 
-data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch
+data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr GuBuf) Touch
 
 newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
                                        [(Cat,[B s Hypo],Float)] ->
@@ -455,9 +458,8 @@ newAbstr aflags cats funs = unsafePerformIO $ do
   c_aflags <- newFlags aflags pool
   (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
   (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
-  c_abs_lin_fun <- newAbsLinFun
   c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool
-  return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)
+  return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_non_lexical_buf touch)
   where
     (Builder pool touch) = ?builder
 
@@ -503,26 +505,6 @@ newAbstr aflags cats funs = unsafePerformIO $ do
       (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat)
       return (Map.insert name ptr absfuns)
 
-    newAbsLinFun = do
-      ptr <- gu_malloc_aligned pool
-                               (#size PgfAbsFun)
-                               (#const gu_alignof(PgfAbsFun))
-      c_wild <- newUtf8CString "_" pool
-      c_ty   <- gu_malloc_aligned pool
-                                  (#size PgfType)
-                                  (#const gu_alignof(PgfType))
-      (#poke PgfType, hypos)   c_ty nullPtr
-      (#poke PgfType, cid)     c_ty c_wild
-      (#poke PgfType, n_exprs) c_ty (0 :: CSizeT)
-      (#poke PgfAbsFun, name)    ptr c_wild
-      (#poke PgfAbsFun, type)    ptr c_ty
-      (#poke PgfAbsFun, arity)   ptr (0 :: CSizeT)
-      (#poke PgfAbsFun, defns)   ptr nullPtr
-      (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat)
-      (#poke PgfAbsFun, ep.expr) ptr nullPtr
-      return ptr
-
-
 data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt
 
 newConcr :: (?builder :: Builder s) => AbstrInfo ->
@@ -531,12 +513,12 @@ newConcr :: (?builder :: Builder s) => AbstrInfo ->
                                        [(FId,[FunId])] ->          -- ^ Lindefs
                                        [(FId,[FunId])] ->          -- ^ Linrefs
                                        [(FId,[Production])] ->     -- ^ Productions
-                                       [(Fun,[SeqId])] ->          -- ^ Concrete functions   (must be sorted by Fun)
+                                       [([Fun],[SeqId])] ->        -- ^ Concrete functions   (must be sorted by Fun)
                                        [[Symbol]] ->               -- ^ Sequences            (must be sorted)
                                        [(Cat,FId,FId,[String])] -> -- ^ Concrete categories
                                        FId ->                      -- ^ The total count of the categories
                                        ConcrInfo
-newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
+newConcr (AbstrInfo _ _ abscats  _ absfuns c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
   c_cflags <- newFlags cflags pool
   c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString 
                         (#size GuString) (pokeString pool)
@@ -597,7 +579,6 @@ newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun c_non_lexical_buf _) cf
 
     pokeRefDefFunId funs_ptr ptr funid = do
       let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun))
-      (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun
       poke ptr c_fun
 
     pokeCncCat c_ccats ptr (name,start,end,labels) = do
@@ -629,7 +610,7 @@ newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
                                      AbstrInfo ->
                                      [(ConcName,ConcrInfo)] ->
                                      B s PGF
-newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs =
+newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ _ _) concrs =
   unsafePerformIO $ do
     ptr <- gu_malloc_aligned pool
                              (#size PgfPGF)
@@ -645,7 +626,6 @@ newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) c
     (#poke PgfPGF, abstract.aflags) ptr c_aflags
     (#poke PgfPGF, abstract.funs)   ptr c_funs
     (#poke PgfPGF, abstract.cats)   ptr c_cats
-    (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun
     (#poke PgfPGF, concretes)       ptr c_concrs
     (#poke PgfPGF, pool)            ptr pool
     return (B (PGF ptr touch))
@@ -751,19 +731,18 @@ newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool =
     return (0,c_prod)
 
 
-newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
+newCncFun absfuns seqs_ptr (funid,(funs,seqids)) pool =
-  do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
+  do let absfun_ptrs = [ptr | fun <- funs, Just ptr <- [Map.lookup fun absfuns]]
-         c_ep     = if c_absfun == nullPtr
+         n_lins      = fromIntegral (length seqids) :: CSizeT
-                      then nullPtr
-                      else c_absfun `plusPtr` (#offset PgfAbsFun, ep)
-         n_lins   = fromIntegral (length seqids) :: CSizeT
      ptr <- gu_malloc_aligned pool
                               ((#size PgfCncFun)+n_lins*(#size PgfSequence*))
                               (#const gu_flex_alignof(PgfCncFun))
-     (#poke PgfCncFun, absfun) ptr c_absfun
+     c_absfuns <- newSequence (#size PgfAbsFun*) poke absfun_ptrs pool
-     (#poke PgfCncFun, ep)     ptr c_ep
+     c_prob    <- fmap (minimum . (0:)) $ mapM (#peek PgfAbsFun, ep.prob) absfun_ptrs
-     (#poke PgfCncFun, funid)  ptr (funid :: CInt)
+     (#poke PgfCncFun, absfuns) ptr c_absfuns
-     (#poke PgfCncFun, n_lins) ptr n_lins
+     (#poke PgfCncFun, prob)    ptr (c_prob :: CFloat)
+     (#poke PgfCncFun, funid)   ptr (funid :: CInt)
+     (#poke PgfCncFun, n_lins)  ptr n_lins
      pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids
      return ptr
   where
@@ -772,6 +751,7 @@ newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
       poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence)))
       pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids
 
+
 getCCat c_ccats fid pool =
   alloca $ \pfid -> do
     poke pfid (fromIntegral fid :: CInt)

src/runtime/haskell-bind/PGF2/Type.hsc

@@ -45,15 +45,14 @@ readType str =
 -- of binding.
 showType :: [CId] -> Type -> String
 showType scope (Type ty touch) = 
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         pgf_print_type ty printCtxt 0 out exn
+    pgf_print_type ty printCtxt 0 out exn
-         touch
+    touch
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
 
 -- | creates a type from a list of hypothesises, a category and 
 -- a list of arguments for the category. The operation 
@@ -129,13 +128,12 @@ unType (Type c_type touch) = unsafePerformIO $ do
 -- of binding.
 showContext :: [CId] -> [Hypo] -> String
 showContext scope hypos =
-  unsafePerformIO $
+  unsafePerformIO $ do
-    withGuPool $ \tmpPl ->
+    tmpPl <- gu_new_pool
-      do (sb,out) <- newOut tmpPl
+    (sb,out) <- newOut tmpPl
-         c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
+    c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
+    exn <- gu_new_exn tmpPl
-         pgf_print_context c_hypos printCtxt out exn
+    pgf_print_context c_hypos printCtxt out exn
-         mapM_ touchHypo hypos
+    mapM_ touchHypo hypos
-         s <- gu_string_buf_freeze sb tmpPl
+    peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s

src/runtime/haskell-bind/SG.hsc

@@ -196,18 +196,17 @@ readTriple str =
 showTriple :: Expr -> Expr -> Expr -> String
 showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
   unsafePerformIO $
-    withGuPool $ \tmpPl ->
+    withTriple $ \triple -> do
-      withTriple $ \triple -> do
+      tmpPl <- gu_new_pool
-         (sb,out) <- newOut tmpPl
+      (sb,out) <- newOut tmpPl
-         let printCtxt = nullPtr
+      let printCtxt = nullPtr
-         exn <- gu_new_exn tmpPl
+      exn <- gu_new_exn tmpPl
-         pokeElemOff triple 0 expr1
+      pokeElemOff triple 0 expr1
-         pokeElemOff triple 1 expr2
+      pokeElemOff triple 1 expr2
-         pokeElemOff triple 2 expr3
+      pokeElemOff triple 2 expr3
-         pgf_print_expr_tuple 3 triple printCtxt out exn
+      pgf_print_expr_tuple 3 triple printCtxt out exn
-         touch1 >> touch2 >> touch3
+      touch1 >> touch2 >> touch3
-         s <- gu_string_buf_freeze sb tmpPl
+      peekUtf8CStringBufResult sb tmpPl
-         peekUtf8CString s
 
 insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
 insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =

src/runtime/haskell/PGF.hs

@@ -335,8 +335,8 @@ functionsByCat pgf cat =
 
 functionType pgf fun =
   case Map.lookup fun (funs (abstract pgf)) of
-    Just (ty,_,_,_) -> Just ty
+    Just (ty,_,_,_,_) -> Just ty
-    Nothing         -> Nothing
+    Nothing           -> Nothing
 
 -- | Converts an expression to normal form
 compute :: PGF -> Expr -> Expr
@@ -363,20 +363,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
 browse pgf id = fmap (\def -> (def,producers,consumers)) definition
   where
     definition = case Map.lookup id (funs (abstract pgf)) of
-                   Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
+                   Just (ty,_,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
                                                                 if null eqs
                                                                   then empty
                                                                   else text "def" <+> vcat [let scope = foldl pattScope [] patts
                                                                                                 ds    = map (ppPatt 9 scope) patts
                                                                                             in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
-                   Just (ty,_,Nothing,_)      -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
+                   Just (ty,_,_,Nothing,_)      -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
                    Nothing   -> case Map.lookup id (cats (abstract pgf)) of
                                   Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
                                   Nothing         -> Nothing
 
     (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
       where
-        accum f (ty,_,_,_) (plist,clist) = 
+        accum f (ty,_,_,_,_) (plist,clist) = 
           let !plist' = if id `elem` ps then f : plist else plist
               !clist' = if id `elem` cs then f : clist else clist
           in (plist',clist')

src/runtime/haskell/PGF/Binary.hs

@@ -47,13 +47,13 @@ instance Binary CId where
 
 instance Binary Abstr where
   put abs = do put (aflags abs)
-               put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
+               put (Map.map (\(ty,ps,arity,mb_eq,prob) -> (ty,ps,arity,fmap fst mb_eq,prob)) (funs abs))
                put (cats abs)
   get = do aflags <- get
            funs <- get
            cats <- get
            return (Abstr{ aflags=aflags
-                        , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
+                        , funs=Map.map (\(ty,ps,arity,mb_eq,prob) -> (ty,ps,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
                         , cats=cats
                         })
 
@@ -199,6 +199,26 @@ instance Binary BindType where
              1 -> return Implicit
              _ -> decodingError
 
+instance Binary DepPragma where
+  put (Head index lbl) = putWord8 0 >> put index >> put lbl
+  put (Mod  index lbl) = putWord8 1 >> put index >> put lbl
+  put (Rel  index)     = putWord8 2 >> put index
+  put Skip             = putWord8 3
+  put Anch             = putWord8 4
+  get = do
+    tag <- getWord8
+    case tag of
+      0 -> do index <- get
+              lbl   <- get
+              return (Head index lbl)
+      1 -> do index <- get
+              lbl   <- get
+              return (Mod index lbl)
+      2 -> do index <- get
+              return (Rel index)
+      3 -> return Skip
+      4 -> return Anch
+
 instance Binary CncFun where
   put (CncFun fun lins) = put fun >> putArray lins
   get = liftM2 CncFun get getArray

src/runtime/haskell/PGF/Data.hs

@@ -28,7 +28,7 @@ data PGF = PGF {
 
 data Abstr = Abstr {
   aflags  :: Map.Map CId Literal,                            -- ^ value of a flag
-  funs    :: Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double),-- ^ type, arrity and definition of function + probability
+  funs    :: Map.Map CId (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double), -- ^ type, pragmas, arrity and definition of function + probability
   cats    :: Map.Map CId ([Hypo],[(Double, CId)],Double)                -- ^ 1. context of a category
                                                                         --   2. functions of a category. The functions are stored
                                                                         --      in decreasing probability order.
@@ -74,7 +74,7 @@ data Production
   deriving (Eq,Ord,Show)
 data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
 data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
-data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
+data CncFun = CncFun [CId] {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
 type Sequence = Array DotPos Symbol
 type FunId = Int
 type SeqId = Int
@@ -105,8 +105,8 @@ emptyPGF = PGF {
 haveSameFunsPGF :: PGF -> PGF -> Bool
 haveSameFunsPGF one two = 
   let 
-    fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
+    fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
-    fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
+    fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))]
   in fsone == fstwo
 
 -- | This is just a 'CId' with the language name.

src/runtime/haskell/PGF/Expr.hs

@@ -1,4 +1,4 @@
-module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..),
+module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..), DepPragma(..),
                 readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
 
                 mkAbs,    unAbs,
@@ -77,6 +77,14 @@ data Equation =
    Equ [Patt] Expr
   deriving Show
 
+data DepPragma
+  = Head Int String
+  | Mod  Int String
+  | Rel  Int
+  | Skip
+  | Anch
+
+
 -- | parses 'String' as an expression
 readExpr :: String -> Maybe Expr
 readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
@@ -319,15 +327,15 @@ data Value
   | VClosure Env Expr
   | VImplArg Value
 
-type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
+type Sig = ( Map.Map CId (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
-           , Int -> Maybe Expr                                          -- lookup for metavariables
+           , Int -> Maybe Expr                                                      -- lookup for metavariables
            )
 type Env = [Value]
 
 eval :: Sig -> Env -> Expr -> Value
 eval sig env (EVar i)     = env !! i
 eval sig env (EFun f)     = case Map.lookup f (fst sig) of
-                              Just (_,a,meqs,_) -> case meqs of
+                              Just (_,_,a,meqs,_) -> case meqs of
                                                        Just (eqs,_)
                                                                -> if a == 0
                                                                     then case eqs of
@@ -349,12 +357,12 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
 apply sig env e            []     = eval sig env e
 apply sig env (EVar i)     vs     = applyValue sig (env !! i) vs
 apply sig env (EFun f)     vs     = case Map.lookup f (fst sig) of
-                                      Just (_,a,meqs,_) -> case meqs of
+                                      Just (_,_,a,meqs,_) -> case meqs of
-                                                             Just (eqs,_) -> if a <= length vs
+                                                               Just (eqs,_) -> if a <= length vs
-                                                                               then match sig f eqs vs
+                                                                                 then match sig f eqs vs
-                                                                               else VApp f vs
+                                                                                 else VApp f vs
-                                                             Nothing      -> VApp f vs
+                                                               Nothing      -> VApp f vs
-                                      Nothing           -> error ("unknown function "++showCId f)
+                                      Nothing             -> error ("unknown function "++showCId f)
 apply sig env (EApp e1 e2) vs     = apply sig env e1 (eval sig env e2 : vs)
 apply sig env (EAbs b x e) (v:vs) = case (b,v) of
                                       (Implicit,VImplArg v) -> apply sig (v:env) e vs

src/runtime/haskell/PGF/Forest.hs

@@ -71,11 +71,11 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
                         in (ct,fid',fun,es,(map getVar hypos,lin))
         Nothing      -> error ("wrong forest id " ++ show fid)
       where
-        descend forest (PApply funid args) = let (CncFun fun _lins) = cncfuns cnc ! funid
+        descend forest (PApply funid args) = let (CncFun pfuns _lins) = cncfuns cnc ! funid
-                                                 cat = case isLindefCId fun of
+                                                 cat = case pfuns of
-                                                         Just cat -> cat
+                                                         []       -> wildCId
-                                                         Nothing  -> case Map.lookup fun (funs abs) of
+                                                         (pfun:_) -> case Map.lookup pfun (funs abs) of
-                                                                       Just (DTyp _ cat _,_,_,_) -> cat
+                                                                       Just (DTyp _ cat _,_,_,_,_) -> cat
                                                  largs  = map (render forest) args
                                                  ltable = mkLinTable cnc isTrusted [] funid largs
                                              in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
@@ -103,14 +103,6 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
         descend (PCoerce fid)       = trustedSpots parents' (PArg [] fid)
         descend (PConst c e _)      = IntSet.empty
 
-isLindefCId id 
-  | take l s == lindef = Just (mkCId (drop l s))
-  | otherwise          = Nothing
-  where
-    s      = showCId id
-    lindef = "lindef "
-    l      = length lindef
-
 -- | This function extracts the list of all completed parse trees
 -- that spans the whole input consumed so far. The trees are also
 -- limited by the category specified, which is usually
@@ -132,13 +124,13 @@ getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty dp =
       | otherwise           = do fid0 <- get
                                  put fid
                                  x <- foldForest (\funid args trees ->
-                                                  do let CncFun fn _lins = cncfuns cnc ! funid
+                                                  do let CncFun fns _lins = cncfuns cnc ! funid
-                                                     case isLindefCId fn of
+                                                     case fns of
-                                                       Just _  -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args)
+                                                       []      -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args)
                                                                      return (mkAbs arg)
-                                                       Nothing -> do ty_fn <- lookupFunType fn
+                                                       fns     -> do ty_fn <- lookupFunType (head fns)
                                                                      (e,tty0) <- foldM (\(e1,tty) arg -> goArg (Set.insert fid rec_) scope fid e1 arg tty)
-                                                                                       (EFun fn,TTyp [] ty_fn) args
+                                                                                       (EFun (head fns),TTyp [] ty_fn) args
                                                                      case mb_tty of
                                                                        Just tty -> do i <- newGuardedMeta e
                                                                                       eqType scope (scopeSize scope) i tty tty0

src/runtime/haskell/PGF/Linearize.hs

@@ -109,7 +109,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
             Nothing        -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
           where
             toApp fid (PApply funid pargs) =
-              let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
+              let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))
                   (args,res) = catSkeleton ty
               in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
             toApp _   (PCoerce fid) = 

src/runtime/haskell/PGF/Macros.hs

@@ -22,13 +22,13 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
 lookType :: Abstr -> CId -> Type
 lookType abs f = 
   case lookMap (error $ "lookType " ++ show f) f (funs abs) of
-    (ty,_,_,_) -> ty
+    (ty,_,_,_,_) -> ty
 
 isData :: Abstr -> CId -> Bool
 isData abs f =
   case Map.lookup f (funs abs) of
-    Just (_,_,Nothing,_) -> True       -- the encoding of data constrs
+    Just (_,_,_,Nothing,_) -> True       -- the encoding of data constrs
-    _                    -> False
+    _                      -> False
 
 lookValCat :: Abstr -> CId -> CId
 lookValCat abs = valCat . lookType abs
@@ -61,7 +61,7 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
 
 functionsToCat :: PGF -> CId -> [(CId,Type)]
 functionsToCat pgf cat =
-  [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
+  [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
  where 
    (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
 

src/runtime/haskell/PGF/Morphology.hs

@@ -31,7 +31,8 @@ collectWords pinfo = Map.fromListWith (++)
   [(t, [(fun,lbls ! l)]) | (CncCat s e lbls) <- Map.elems (cnccats pinfo)
                          , fid <- [s..e]
                          , PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (productions pinfo))
-                         , let CncFun fun lins = cncfuns pinfo ! funid
+                         , let CncFun funs lins = cncfuns pinfo ! funid
+                         , fun <- funs
                          , (l,seqid) <- assocs lins
                          , sym <- elems (sequences pinfo ! seqid)
                          , t <- sym2tokns sym]

src/runtime/haskell/PGF/OldBinary.hs

@@ -39,7 +39,7 @@ getAbstract =
            funs <- getMap getCId getFun
            cats <- getMap getCId getCat
            return (Abstr{ aflags=aflags
-                        , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
+                        , funs=fmap (\(w,x,y,z) -> (w,[],x,fmap (flip (,) []) y,z)) funs
                         , cats=fmap (\(x,y) -> (x,y,0)) cats
                         })
 getFun :: Get (Type,Int,Maybe [Equation],Double)
@@ -60,7 +60,7 @@ getConcr =
            cnccats     <- getMap getCId getCncCat
            totalCats   <- get
            let rseq    = listToArray [SymCat 0 0]
-               rfun    = CncFun (mkCId "linref") (listToArray [scnt])
+               rfun    = CncFun [mkCId "linref"] (listToArray [scnt])
                linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]]
            return (Concr{ cflags=cflags, printnames=printnames
                         , sequences=toArray (scnt+1,seqs++[rseq])
@@ -110,7 +110,7 @@ getBindType =
              1 -> return Implicit
              _ -> decodingError "getBindType"
 
-getCncFun = liftM2 CncFun getCId (getArray get)
+getCncFun = liftM2 CncFun (fmap (:[]) getCId) (getArray get)
 
 getCncCat = liftM3 CncCat get get (getArray get)
 

src/runtime/haskell/PGF/Optimize.hs

@@ -253,7 +253,7 @@ updateConcrete abs cnc =
                                                                         , prod <- Set.toList prods
                                                                         , fun <- getFunctions prod]
       where
-        getFunctions (PApply funid args) = let CncFun fun _ = cncfuns cnc ! funid in [fun]
+        getFunctions (PApply funid args) = let CncFun funs _ = cncfuns cnc ! funid in funs
         getFunctions (PCoerce fid)       = case IntMap.lookup fid productions of
                                              Nothing    -> []
                                              Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]

src/runtime/haskell/PGF/Paraphrase.hs

@@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
               isClosed d || (length equs == 1 && isLinear d)]
 
   equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | 
-                   (f,(_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
+                   (f,(_,_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
   ---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
   ---- cf. PGF.Tree.expr2tree
   trequ s f e = True ----trace (s ++ ": " ++ show f ++ "  " ++ show e) True

src/runtime/haskell/PGF/Parse.hs

@@ -503,14 +503,14 @@ type Continuation = TrieMap.TrieMap Token ActiveSet
 -- | Return the Continuation of a Parsestate with exportable types
 --   Used by PGFService
 getContinuationInfo :: ParseState -> Map.Map [Token] [(FunId, CId, String)]
-getContinuationInfo pstate = Map.map (map f . Set.toList) contMap
+getContinuationInfo pstate = Map.map (concatMap f . Set.toList) contMap
   where
     PState _abstr concr _chart cont = pstate
     contMap = Map.fromList (TrieMap.toList cont) -- always get [([], _::ActiveSet)]
-    f :: Active -> (FunId,CId,String)
+    f :: Active -> [(FunId,CId,String)]
-    f (Active int dotpos funid seqid pargs ak) = (funid, cid, seq)
+    f (Active int dotpos funid seqid pargs ak) = [(funid, fn, seq) | fn <- fns]
       where
-        CncFun cid _ = cncfuns concr ! funid
+        CncFun fns _ = cncfuns concr ! funid
         seq = showSeq dotpos (sequences concr ! seqid)
         
     showSeq :: DotPos -> Sequence -> String

src/runtime/haskell/PGF/Printer.hs

@@ -31,15 +31,15 @@ ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+>
 ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
 ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
 
-ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
+ppFun :: CId -> (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
-ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
+ppFun f (t,_,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
-                                  (if null eqs
+                                    (if null eqs
-                                     then empty
+                                       then empty
-                                     else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                       else text "def" <+> vcat [let scope = foldl pattScope [] patts
-                                                                   ds    = map (ppPatt 9 scope) patts
+                                                                     ds    = map (ppPatt 9 scope) patts
-                                                               in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
+                                                                 in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
-                                  ppCode 0 code
+                                    ppCode 0 code
-ppFun f (t,_,Nothing,_)         = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
+ppFun f (t,_,_,Nothing,_)         = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
 
 ppCnc :: Language -> Concr -> Doc
 ppCnc name cnc =
@@ -73,8 +73,8 @@ ppProduction (fid,PCoerce arg) =
 ppProduction (fid,PConst _ _ ss) =
   ppFId fid <+> text "->" <+> ppStrs ss
 
-ppCncFun (funid,CncFun fun arr) =
+ppCncFun (funid,CncFun funs arr) =
-  ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
+  ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (hsep (map ppCId funs))
 
 ppLinDefs (fid,funids) = 
   [ppFId fid <+> text "->" <+> ppFunId funid <> brackets (ppFId fidVar) | funid <- funids]

src/runtime/haskell/PGF/Probabilistic.hs

@@ -76,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
 
 getProbabilities :: PGF -> Probabilities
 getProbabilities pgf = Probs {
-  funProbs = Map.map (\(_,_,_,p) -> p      ) (funs (abstract pgf)),
+  funProbs = Map.map (\(_,_,_,_,p) -> p      ) (funs (abstract pgf)),
-  catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf))
+  catProbs = Map.map (\(_,fns,p)   -> (p,fns)) (cats (abstract pgf))
   }
 
 setProbabilities :: Probabilities -> PGF -> PGF
 setProbabilities probs pgf = pgf {
   abstract = (abstract pgf) {
-    funs = mapUnionWith (\(ty,a,df,_) p       -> (ty,a,df,  p)) (funs (abstract pgf)) (funProbs probs),
+    funs = mapUnionWith (\(ty,ps,a,df,_) p      -> (ty,ps,a,df,  p)) (funs (abstract pgf)) (funProbs probs),
-    cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
+    cats = mapUnionWith (\(hypos,_,_)   (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
   }}
   where
     mapUnionWith f map1 map2 = 
@@ -95,8 +95,8 @@ probTree :: PGF -> Expr -> Double
 probTree pgf t = case t of
   EApp f e -> probTree pgf f * probTree pgf e
   EFun f   -> case Map.lookup f (funs (abstract pgf)) of
-                Just (_,_,_,p) -> p
+                Just (_,_,_,_,p) -> p
-                Nothing        -> 1
+                Nothing          -> 1
   _ -> 1
 
 -- | rank from highest to lowest probability
@@ -113,7 +113,7 @@ mkProbDefs pgf =
                                               hyps0
                                               [1..]
                                fns  = [(f,ty) | (_,f) <- fs, 
-                                               let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))]
+                                               let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))]
            ]
       ((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) -> 
               let st0      = (1,Map.empty)
@@ -263,7 +263,7 @@ computeConstrs pgf st fns =
       where
         addArgs (cn,fns) = addArg (length args) cn [] fns
           where
-            Just (DTyp args _ _es,_,_,_) = Map.lookup cn (funs (abstract pgf))
+            Just (DTyp args _ _es,_,_,_,_) = Map.lookup cn (funs (abstract pgf))
 
         addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)]
         addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns]

src/runtime/haskell/PGF/SortTop.hs

@@ -38,7 +38,7 @@ showInOrder abs fset remset avset =
 isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
 isArg abs mtypes scid cid = 
    let p = Map.lookup cid $ funs abs
-       (ty,_,_,_) = fromJust p 
+       (ty,_,_,_,_) = fromJust p 
        args  = arguments ty  
        setargs = Set.fromList args
        cond = Set.null $ Set.difference setargs scid
@@ -51,8 +51,8 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
 typesInterm abs fset = 
           let fs = funs abs
               fsetTypes = Set.map (\x -> 
-                                    let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
+                                    let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
-                                     in (x,c)) fset
+                                    in (x,c)) fset
               in Map.fromList $ Set.toList fsetTypes             
 
 {-
@@ -67,7 +67,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat
 returnCat :: Abstr -> CId -> CId 
 returnCat abs cid = 
       let p = Map.lookup cid $ funs abs           
-          (DTyp _ c _,_,_,_) = fromJust p  
+          (DTyp _ c _,_,_,_,_) = fromJust p  
         in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
                    else c
 

src/runtime/haskell/PGF/TypeCheck.hs

@@ -135,8 +135,8 @@ lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
 
 lookupFunType :: CId -> TcM s Type
 lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
-                                            Just (ty,_,_,_) -> k ty ms
+                                            Just (ty,_,_,_,_) -> k ty ms
-                                            Nothing         -> h (UnknownFun fun))
+                                            Nothing           -> h (UnknownFun fun))
 
 typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
 typeGenerators scope cat = fmap normalize (liftM2 (++) x y)