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
-      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
+  let (fid_cnt1,lindefs,linrefs,fun_st1) = mkCncCats cdefs fid_cnt IntMap.empty IntMap.empty Map.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,Map.size fun_st2-1) (Map.elems fun_st2))
   where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
-      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
-    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
-      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
-                       in funs_cnt+(e_funid-s_funid+1)
-          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
-          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
-          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
-      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
+    mkCncCats []                                                          fid_cnt lindefs linrefs fun_st =
+      (fid_cnt,lindefs,linrefs,fun_st)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt lindefs linrefs fun_st =
+      let mseqs   = case lookupModule gr m of
+                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
+                      _                              -> ex_seqs
+          (lindefs',fun_st1) = foldl' (toLinDef (m,id) funs0 mseqs) (lindefs,fun_st ) prods0
+          (linrefs',fun_st2) = foldl' (toLinRef (m,id) funs0 mseqs) (linrefs,fun_st1) prods0
+      in mkCncCats cdefs fid_cnt lindefs' linrefs' fun_st2
+    mkCncCats (_                                                  :cdefs) fid_cnt lindefs linrefs fun_st =
+      mkCncCats cdefs fid_cnt lindefs linrefs fun_st
 
-    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
-      (fid_cnt,funs_cnt,funs,prods)
-    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
-      let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
-          ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
-          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
-                           in funs_cnt+(e_funid-s_funid+1)
-          !(fid_cnt',crc',prods') 
-                         = foldl' (toProd lindefs ty_C funs_cnt)
-                                  (fid_cnt,crc,prods) prods0
-          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
-      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
+    mkCncFuns []                                                        lindefs st = st
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) lindefs st =
+      let ty_C    = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+          mseqs   = case lookupModule gr m of
+                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
+                      _                              -> ex_seqs
+          bundles = [([(args0,res0) | Production res0 funid0 args0 <- prods0, funid0==funid],lins) | (funid,lins) <- assocs funs0]
+          !st'    = foldl' (toProd id lindefs mseqs ty_C) st bundles
+      in mkCncFuns cdefs lindefs st'
+    mkCncFuns (_                                                :cdefs) lindefs st =
+      mkCncFuns cdefs lindefs st
 
-    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
-      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
-          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
-          fid     = mkFId res_C fid0
-          !prods' = case IntMap.lookup fid prods of
-                     Just set -> IntMap.insert fid (Set.union set0 set) prods
-                     Nothing  -> IntMap.insert fid set0 prods
-      in (fid_cnt,crc,prods')
+    toLinDef mid funs0 mseqs st@(lindefs,fun_st) (Production res0 funid0 [arg0])
+      | arg0 == [fidVar] =
+          let res  = mkFId mid res0
+
+              lins = amap (newSeqId mseqs) (funs0 ! funid0)
+
+              !funid    = Map.size fun_st
+              !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) =
-      if args == [[fidVar]]
-        then IntMap.insertWith (++) fid [offs+funid0] lindefs
-        else lindefs
+    newSeqId mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
       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 (f,(typ,_,_,_)) =
+absdef2js :: (CId,(Type,[DepPragma],Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
+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 (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
+pyAbsdef :: (Type, [DepPragma], Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
+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,7 +351,8 @@ 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 [] ["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, ",
@@ -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 ps = CFObj f (zipWith profileToTerm argTypes ps)
+        profilesToTerm :: CId -> [Profile] -> CFTerm
+        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;
-	PgfExprProb *ep;
+	GuSeq* absfuns;
+	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,
-				PgfCncOverloadMap*);
-		if (!overl_table) {
-			overl_table = gu_new_addr_map(PgfCCat*, GuBuf*, &gu_null_struct, pool);
-			gu_map_put(concr->fun_indices,
-				papply->fun->absfun->name, PgfCncOverloadMap*, overl_table);
+
+		size_t n_absfuns = gu_seq_length(papply->fun->absfuns);
+		for (size_t i = 0; i < n_absfuns; i++) {
+			PgfAbsFun* absfun =
+				gu_seq_get(papply->fun->absfuns, PgfAbsFun*, i);
+
+			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,7 +710,7 @@ 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++) {
@@ -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);
-		st->answers = answers;
-		st->ep      = *papp->fun->ep;
-		st->args    = papp->args;
-		st->arg_idx = 0;
+		size_t n_absfuns = gu_seq_length(papp->fun->absfuns);
+		for (size_t i = 0; i < n_absfuns; i++) {
+			PgfAbsFun* absfun =
+				gu_seq_get(papp->fun->absfuns, PgfAbsFun*, i);
 
-		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;
+			PgfExprState *st = gu_new(PgfExprState, ps->pool);
+			st->answers = answers;
+			st->ep      = absfun->ep;
+			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;
-		GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
+		size_t n_absfuns = gu_seq_length(entry->papp->fun->absfuns);
+		for (size_t j = 0; j < n_absfuns; j++) {
+			PgfAbsFun* absfun =
+				gu_seq_get(entry->papp->fun->absfuns, PgfAbsFun*, j);
+			PgfCId lemma = absfun->name;
+			GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
 			
-		prob_t prob = entry->ccat->cnccat->abscat->prob +
-		              entry->papp->fun->absfun->ep.prob;
-		callback->callback(callback,
-						   lemma, analysis, prob, err);
-		if (!gu_ok(err))
-			return;
+			prob_t prob = entry->ccat->cnccat->abscat->prob +
+						  absfun->ep.prob;
+			callback->callback(callback,
+							   lemma, analysis, prob, err);
+			if (!gu_ok(err))
+				return;
+		}
 	}
 }
 
@@ -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) {
-		gu_puts(" [", out, err);
-		pgf_print_cid(cncfun->absfun->name, out, err);
-		gu_puts("]", out, err);
+	size_t n_absfuns = gu_seq_length(cncfun->absfuns);
+	for (size_t i = 0; i < n_absfuns; i++) {
+		PgfAbsFun* absfun =
+			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);
-	gu_return_on_exn(rdr->err, NULL);
-
-	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;
+	PgfCncFun* cncfun = gu_new_flex(rdr->opool, PgfCncFun, lins, n_lins);
+	cncfun->absfuns = absfuns;
+	cncfun->prob = prob;
 	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

@@ -312,6 +312,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);
 
 	pgf_write_tag((absfun->defns == NULL) ? 0 : 1, 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);
-	gu_return_on_exn(wtr->err, );
+	size_t n_absfuns = gu_seq_length(cncfun->absfuns);
+	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;
-			rc = find_function_rowid(sg, &ctxt, cncfun->absfun->name, &key, 1);
-			if (rc != SQLITE_OK) {
-				sg_raise_sqlite(rc, err);
-				goto close;
-			}
+			size_t n_absfuns = gu_seq_length(cncfun->absfuns);
+			for (size_t i = 0; i < n_absfuns; i++) {
+				PgfAbsFun* absfun =
+					gu_seq_get(cncfun->absfuns, PgfAbsFun*, i);
 
-			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);
+				SgId key = 0;
+				rc = find_function_rowid(sg, &ctxt, absfun->name, &key, 1);
 				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 $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print (pgf p) out exn
-         touchPGF p
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print (pgf p) out exn
+    touchPGF p
+    peekUtf8CStringBufResult sb tmpPl
 
 -- | 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 $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
-         touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
-
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    c_opts <- newGraphvizOptions tmpPl opts
+    pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
 graphvizParseTree c opts e =
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
-         touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    c_opts <- newGraphvizOptions tmpPl opts
+    pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
+
+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
-         peekUtf8CString s
+         peekUtf8CStringBufResult sb tmpPl
 
 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
-                 peekUtf8CString lin
+         else do peekUtf8CStringBuf sb
 
 -- | 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
-                          s <- peekUtf8CString lin
+                  else do s  <- peekUtf8CStringBuf sb
                           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
-                s  <- peekUtf8CString lin
+        else do s  <- peekUtf8CStringBuf sb
                 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 $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_expr (expr e) printCtxt 1 out exn
-         touchExpr e
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_expr (expr e) printCtxt 1 out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 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 ->
@@ -519,6 +549,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,22 +194,25 @@ 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_name <- (#peek PgfAbsFun, name) c_absfun
-  name <- peekUtf8CString c_name
+  c_absfuns <- (#peek PgfCncFun, absfuns) c_cncfun
+  names <- peekSequence peekAbsName (#size PgfAbsFun*) c_absfuns
   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
   seq <- (#peek PgfConcr, sequences) (concr c)
@@ -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 =
-  do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
-         c_ep     = if c_absfun == nullPtr
-                      then nullPtr
-                      else c_absfun `plusPtr` (#offset PgfAbsFun, ep)
-         n_lins   = fromIntegral (length seqids) :: CSizeT
+newCncFun absfuns seqs_ptr (funid,(funs,seqids)) pool =
+  do let absfun_ptrs = [ptr | fun <- funs, Just ptr <- [Map.lookup fun absfuns]]
+         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
-     (#poke PgfCncFun, ep)     ptr c_ep
-     (#poke PgfCncFun, funid)  ptr (funid :: CInt)
-     (#poke PgfCncFun, n_lins) ptr n_lins
+     c_absfuns <- newSequence (#size PgfAbsFun*) poke absfun_ptrs pool
+     c_prob    <- fmap (minimum . (0:)) $ mapM (#peek PgfAbsFun, ep.prob) absfun_ptrs
+     (#poke PgfCncFun, absfuns) ptr c_absfuns
+     (#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 $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_type ty printCtxt 0 out exn
-         touch
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_type ty printCtxt 0 out exn
+    touch
+    peekUtf8CStringBufResult sb tmpPl
 
 -- | 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 $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_context c_hypos printCtxt out exn
-         mapM_ touchHypo hypos
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_context c_hypos printCtxt out exn
+    mapM_ touchHypo hypos
+    peekUtf8CStringBufResult sb tmpPl

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
-         (sb,out) <- newOut tmpPl
-         let printCtxt = nullPtr
-         exn <- gu_new_exn tmpPl
-         pokeElemOff triple 0 expr1
-         pokeElemOff triple 1 expr2
-         pokeElemOff triple 2 expr3
-         pgf_print_expr_tuple 3 triple printCtxt out exn
-         touch1 >> touch2 >> touch3
-         s <- gu_string_buf_freeze sb tmpPl
-         peekUtf8CString s
+    withTriple $ \triple -> do
+      tmpPl <- gu_new_pool
+      (sb,out) <- newOut tmpPl
+      let printCtxt = nullPtr
+      exn <- gu_new_exn tmpPl
+      pokeElemOff triple 0 expr1
+      pokeElemOff triple 1 expr2
+      pokeElemOff triple 2 expr3
+      pgf_print_expr_tuple 3 triple printCtxt out exn
+      touch1 >> touch2 >> touch3
+      peekUtf8CStringBufResult sb tmpPl
 
 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
-    Nothing         -> Nothing
+    Just (ty,_,_,_,_) -> Just ty
+    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))]
-    fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
+    fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
+    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
-           , Int -> Maybe Expr                                          -- lookup for metavariables
+type Sig = ( Map.Map CId (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
+           , 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 (eqs,_) -> if a <= length vs
-                                                                               then match sig f eqs vs
-                                                                               else VApp f vs
-                                                             Nothing      -> VApp f vs
-                                      Nothing           -> error ("unknown function "++showCId f)
+                                      Just (_,_,a,meqs,_) -> case meqs of
+                                                               Just (eqs,_) -> if a <= length vs
+                                                                                 then match sig f eqs vs
+                                                                                 else VApp f vs
+                                                               Nothing      -> VApp f vs
+                                      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
-                                                 cat = case isLindefCId fun of
-                                                         Just cat -> cat
-                                                         Nothing  -> case Map.lookup fun (funs abs) of
-                                                                       Just (DTyp _ cat _,_,_,_) -> cat
+        descend forest (PApply funid args) = let (CncFun pfuns _lins) = cncfuns cnc ! funid
+                                                 cat = case pfuns of
+                                                         []       -> wildCId
+                                                         (pfun:_) -> case Map.lookup pfun (funs abs) of
+                                                                       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
-                                                     case isLindefCId fn of
-                                                       Just _  -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args)
+                                                  do let CncFun fns _lins = cncfuns cnc ! funid
+                                                     case fns of
+                                                       []      -> 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
-    _                    -> False
+    Just (_,_,_,Nothing,_) -> True       -- the encoding of data constrs
+    _                      -> 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 int dotpos funid seqid pargs ak) = (funid, cid, seq)
+    f :: Active -> [(FunId,CId,String)]
+    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 f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
-                                  (if null eqs
-                                     then empty
-                                     else text "def" <+> vcat [let scope = foldl pattScope [] patts
-                                                                   ds    = map (ppPatt 9 scope) patts
-                                                               in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
-                                  ppCode 0 code
-ppFun f (t,_,Nothing,_)         = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
+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 ';' $$
+                                    (if null eqs
+                                       then empty
+                                       else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                                                     ds    = map (ppPatt 9 scope) patts
+                                                                 in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
+                                    ppCode 0 code
+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) =
-  ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
+ppCncFun (funid,CncFun funs arr) =
+  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)),
-  catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf))
+  funProbs = Map.map (\(_,_,_,_,p) -> p      ) (funs (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),
-    cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs 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)
   }}
   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
-                Nothing        -> 1
+                Just (_,_,_,_,p) -> p
+                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
-                                     in (x,c)) fset
+                                    let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
+                                    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
-                                            Nothing         -> h (UnknownFun fun))
+                                            Just (ty,_,_,_,_) -> k ty ms
+                                            Nothing           -> h (UnknownFun fun))
 
 typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
 typeGenerators scope cat = fmap normalize (liftM2 (++) x y)