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

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -6,7 +6,7 @@ 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.Internal as C
 import GF.Grammar.Predef
@@ -22,6 +22,7 @@ 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
@@ -29,13 +30,16 @@ import Data.Array.IArray
 
 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 (C.PGF Map.empty an abs (Map.fromList cncs))
   where
     cenv = resourceValues opts gr
 
-    mkAbstr am = return (mi2i am, C.Abstr flags funs cats)
+    mkAbstr am depconf = return (mi2i am, C.Abstr flags funs cats)
       where
         aflags = err (const noOptions) mflags (lookupModule gr am)
 
@@ -45,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]
 
@@ -320,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)])
 

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

src/compiler/GF/Infra/Option.hs

@@ -157,6 +157,7 @@ data Flags = Flags {
       optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
+      optLabelsFile      :: Maybe FilePath,
       optRetainResource  :: Bool,
       optName            :: Maybe String,
       optPreprocessors   :: [String],
@@ -268,6 +269,7 @@ defaultFlags = Flags {
       optDocumentRoot    = Nothing,
       optRecomp          = RecompIfNewer,
       optProbsFile       = Nothing,
+      optLabelsFile      = Nothing,
       optRetainResource  = False,
 
       optName            = Nothing,
@@ -349,8 +351,9 @@ optDescr =
      Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
                  "Never recompile from source, if there is already .gfo file.",
      Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
-     Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     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, ",
                      "internally in the output."]),
@@ -428,6 +431,7 @@ optDescr =
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
+       labelsFile  x = set $ \o -> o { optLabelsFile = Just x }
 
        name        x = set $ \o -> o { optName = Just x }
        addLibDir   x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }

src/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,8 +710,8 @@ pgf_new_item(PgfParsing* ps, PgfItemConts* conts, PgfProduction prod)
 	case PGF_PRODUCTION_APPLY: {
 		PgfProductionApply* papp = pi.data;
 		item->args = papp->args;
-		item->inside_prob = papp->fun->ep->prob;
-		
+		item->inside_prob = papp->fun->prob;
+
 		int n_args = gu_seq_length(item->args);
 		for (int i = 0; i < n_args; i++) {
 			PgfPArg *arg = gu_seq_index(item->args, PgfPArg, i);
@@ -1265,8 +1265,12 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item)
 			ps->tp = gu_new(PgfTokenProb, ps->out_pool);
 			ps->tp->tok  = tok;
 			ps->tp->cat  = item->conts->ccat->cnccat->abscat->name;
-			ps->tp->fun  = papp->fun->absfun->name;
 			ps->tp->prob = item->inside_prob + item->conts->outside_prob;
+			ps->tp->fun  = "_";
+			
+			if (gu_seq_length(papp->fun->absfuns) > 0)
+				ps->tp->fun = 
+					gu_seq_get(papp->fun->absfuns, PgfAbsFun*, 0)->name;
 		}
 	} else {
 		if (!ps->before->needs_bind && cmp_string(&current, tok, ps->case_sensitive) == 0) {
@@ -1794,19 +1798,25 @@ pgf_result_production(PgfParsing* ps,
 	case PGF_PRODUCTION_APPLY: {
 		PgfProductionApply* papp = pi.data;
 
-		PgfExprState *st = gu_new(PgfExprState, ps->pool);
-		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];
-		
-		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;
+		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 +
+						  absfun->ep.prob;
+			callback->callback(callback,
+							   lemma, analysis, prob, err);
+			if (!gu_ok(err))
+				return;
+		}
 	}
 }
 
@@ -2569,7 +2584,7 @@ pgf_ccat_set_viterbi_prob(PgfCCat* ccat) {
 			return INFINITY;
 
 		prob_t viterbi_prob = INFINITY;
-		
+
 		size_t n_prods = gu_seq_length(ccat->prods);
 		for (size_t i = 0; i < n_prods; i++) {
 			PgfProduction prod =
@@ -2581,7 +2596,7 @@ pgf_ccat_set_viterbi_prob(PgfCCat* ccat) {
 			switch (inf.tag) {
 			case PGF_PRODUCTION_APPLY: {
 				PgfProductionApply* papp = inf.data;
-				prob = papp->fun->ep->prob;
+				prob = papp->fun->prob;
 				
 				size_t n_args = gu_seq_length(papp->args);
 				for (size_t j = 0; j < n_args; j++) {

src/runtime/c/pgf/printer.c

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

@@ -311,6 +311,32 @@ pgf_write_absfun(PgfAbsFun* absfun, PgfWriter* wtr)
 
 	pgf_write_type_(absfun->type, wtr);
 	gu_return_on_exn(wtr->err, );
+	
+	size_t n_pragmas = gu_seq_length(absfun->pragmas);
+	for (size_t i = 0; i < n_pragmas; i++) {
+		PgfDepPragma* pragma =
+			gu_seq_index(absfun->pragmas, PgfDepPragma, i);
+			
+		pgf_write_tag(pragma->tag, wtr);
+		switch (pragma->tag) {
+		case PGF_DEP_PRAGMA_HEAD:
+			pgf_write_int(pragma->index, wtr);
+			pgf_write_string(pragma->label, wtr);
+			break;
+		case PGF_DEP_PRAGMA_MOD:
+			pgf_write_int(pragma->index, wtr);
+			pgf_write_string(pragma->label, wtr);
+			break;
+		case PGF_DEP_PRAGMA_REL:
+			pgf_write_int(pragma->index, wtr);
+			break;
+		case PGF_DEP_PRAGMA_SKIP:
+		case PGF_DEP_PRAGMA_ANCH:
+			break;
+		default:
+			gu_impossible();
+		}
+	}
 
 	pgf_write_int(absfun->arity, wtr);
 
@@ -579,8 +605,15 @@ pgf_write_sequences(PgfSequences* seqs, PgfWriter* wtr)
 static void
 pgf_write_cncfun(PgfCncFun* cncfun, PgfConcr* concr, PgfWriter* wtr)
 {
-	pgf_write_cid(cncfun->absfun->name, wtr);
-	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 ->
@@ -518,6 +548,9 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
   pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
+  
+foreign import ccall "pgf/graphviz.h pgf_graphviz_dependency_graph"
+  pgf_graphviz_dependency_graph :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO ()
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
   pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()

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

@@ -194,21 +194,24 @@ concrTotalFuns c = unsafePerformIO $ do
   touchConcr c
   return (fromIntegral (c_len :: CSizeT))
 
-concrFunction :: Concr -> FunId -> (Fun,[SeqId])
+concrFunction :: Concr -> FunId -> ([Fun],[SeqId])
 concrFunction c funid = unsafePerformIO $ do
   c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
   c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*)))
-  c_absfun <- (#peek PgfCncFun, absfun) c_cncfun
-  c_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
@@ -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.
@@ -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

@@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
                                                  cat = case pfuns of
                                                          []       -> wildCId
                                                          (pfun:_) -> case Map.lookup pfun (funs abs) of
-                                                                       Just (DTyp _ cat _,_,_,_) -> cat
+                                                                       Just (DTyp _ cat _,_,_,_,_) -> cat
                                                  largs  = map (render forest) args
                                                  ltable = mkLinTable cnc isTrusted [] funid largs
                                              in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

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/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)

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/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 =

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)