the C runtime now supports the same customizations for GraphViz as the Haskell runtime

6 files changed, 156 insertions, 34 deletions

diff --git a/src/runtime/c/pgf/graphviz.c b/src/runtime/c/pgf/graphviz.c
index 0936a2d63..1498035eb 100644
--- a/src/runtime/c/pgf/graphviz.c
+++ b/src/runtime/c/pgf/graphviz.c
@@ -2,8 +2,12 @@
 #include "graphviz.h"
 #include "linearizer.h"
 
+PgfGraphvizOptions pgf_default_graphviz_options[1] =
+  { {0, 0, 0, 1, NULL, NULL, NULL, NULL, NULL, NULL} } ;
+
 static int
-pgf_graphviz_abstract_tree_(PgfExpr expr, int *pid,
+pgf_graphviz_abstract_tree_(PgfPGF* pgf, PgfExpr expr, int *pid,
+                            PgfGraphvizOptions* opts,
                             GuOut* out, GuExn* err)
 {
 	int id = -1;
@@ -15,9 +19,16 @@ pgf_graphviz_abstract_tree_(PgfExpr expr, int *pid,
 		break;
 	case PGF_EXPR_APP: {
 		PgfExprApp* app = ei.data;
-		id = pgf_graphviz_abstract_tree_(app->fun, pid, out, err);
-		int arg_id = pgf_graphviz_abstract_tree_(app->arg, pid, out, err);
-		gu_printf(out, err, "n%d -- n%d [style = \"solid\"]\n", id, arg_id);
+		id = pgf_graphviz_abstract_tree_(pgf, app->fun, pid, opts, out, err);
+		int arg_id = pgf_graphviz_abstract_tree_(pgf, app->arg, pid, opts, out, err);
+		gu_printf(out, err, "n%d -- n%d", id, arg_id);
+		if (opts->nodeEdgeStyle != NULL && *opts->nodeEdgeStyle && opts->nodeColor != NULL && *opts->nodeColor)
+			gu_printf(out, err, " [style = \"%s\", color = \"%s\"]", opts->nodeEdgeStyle, opts->nodeColor);
+		else if (opts->nodeEdgeStyle != NULL && *opts->nodeEdgeStyle)
+				gu_printf(out, err, " [style = \"%s\"]", opts->nodeEdgeStyle);
+		else if (opts->nodeColor != NULL && *opts->nodeColor)
+				gu_printf(out, err, " [color = \"%s\"]", opts->nodeColor);
+		gu_printf(out, err, "\n", id, arg_id);
 		break;
 	}
 	case PGF_EXPR_LIT: {
@@ -58,9 +69,24 @@ pgf_graphviz_abstract_tree_(PgfExpr expr, int *pid,
 	case PGF_EXPR_FUN: {
 		PgfExprFun* fun = ei.data;
 		id = (*pid)++;
-		gu_printf(out, err, "n%d[label = \"", id);
-		gu_string_write(fun->fun, out, err);
-		gu_puts("\", style = \"solid\", shape = \"plaintext\"]\n", out, err);
+		if (opts->noFun && opts->noCat) {
+			gu_printf(out, err, "n%d[shape = \"point\"]\n", id);
+		} else {
+			gu_printf(out, err, "n%d[label = \"", id);
+			PgfType* ty = (opts->noCat) ? NULL : pgf_function_type(pgf, fun->fun);
+			if (!opts->noFun)
+				gu_string_write(fun->fun, out, err);
+			if (!opts->noFun && ty != NULL)
+				gu_puts(" : ", out,err);
+			if (ty != NULL)
+				gu_string_write(ty->cid, out, err);
+			gu_puts("\", shape = \"plaintext\", style = \"solid\"", 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);
+		}
 		break;
 	}
 	case PGF_EXPR_VAR:
@@ -68,12 +94,12 @@ pgf_graphviz_abstract_tree_(PgfExpr expr, int *pid,
 		break;
 	case PGF_EXPR_TYPED: {
 		PgfExprTyped* typed = ei.data;
-		id = pgf_graphviz_abstract_tree_(typed->expr, pid, out, err);
+		id = pgf_graphviz_abstract_tree_(pgf, typed->expr, pid, opts, out, err);
 		break;
 	}
 	case PGF_EXPR_IMPL_ARG: {
 		PgfExprImplArg* implarg = ei.data;
-		id = pgf_graphviz_abstract_tree_(implarg->expr, pid, out, err);
+		id = pgf_graphviz_abstract_tree_(pgf, implarg->expr, pid, opts, out, err);
 		break;
 	}
 	default:
@@ -84,12 +110,12 @@ pgf_graphviz_abstract_tree_(PgfExpr expr, int *pid,
 }
 
 PGF_API void
-pgf_graphviz_abstract_tree(PgfPGF* pgf, PgfExpr expr, GuOut* out, GuExn* err)
+pgf_graphviz_abstract_tree(PgfPGF* pgf, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err)
 {
 	int id = 0;
 
 	gu_puts("graph {\n", out, err);
-	pgf_graphviz_abstract_tree_(expr, &id, out, err);
+	pgf_graphviz_abstract_tree_(pgf, expr, &id, opts, out, err);
 	gu_puts("}", out, err);
 }
 
@@ -98,6 +124,7 @@ typedef struct PgfParseNode PgfParseNode;
 struct PgfParseNode {
 	int id;
 	PgfParseNode* parent;
+	GuString fun;
 	GuString label;
 };
 
@@ -107,7 +134,7 @@ typedef struct {
 	GuPool* pool;
 	GuOut* out;
 	GuExn* err;
-	
+
 	PgfParseNode* parent;
 	size_t level;
 	GuBuf* internals;
@@ -122,6 +149,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok)
 	PgfParseNode* node = gu_new(PgfParseNode, state->pool);
 	node->id     = 100000 + gu_buf_length(state->leaves);
 	node->parent = state->parent;
+	node->fun    = NULL;
 	node->label  = tok;
 	gu_buf_push(state->leaves, PgfParseNode*, node);
 }
@@ -156,6 +184,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde
 	PgfParseNode* node = gu_new(PgfParseNode, state->pool);
 	node->id     = fid;
 	node->parent = state->parent;
+	node->fun    = fun;
 	node->label  = cat;
 	gu_buf_push(level, PgfParseNode*, node);
 
@@ -182,6 +211,7 @@ pgf_bracket_lzn_symbol_meta(PgfLinFuncs** funcs, PgfMetaId meta_id)
 	PgfParseNode* node = gu_new(PgfParseNode, state->pool);
 	node->id     = 100000 + gu_buf_length(state->leaves);
 	node->parent = state->parent;
+	node->fun    = NULL;
 	node->label  = "?";
 	gu_buf_push(state->leaves, PgfParseNode*, node);
 }
@@ -197,7 +227,7 @@ static PgfLinFuncs pgf_bracket_lin_funcs = {
 };
 
 static void
-pgf_graphviz_parse_level(GuBuf* level, GuOut* out, GuExn* err)
+pgf_graphviz_parse_level(GuBuf* level, PgfGraphvizOptions* opts, GuOut* out, GuExn* err)
 {
 	gu_puts("\n  subgraph {rank=same;\n", out, err);
 
@@ -208,9 +238,32 @@ pgf_graphviz_parse_level(GuBuf* level, GuOut* out, GuExn* err)
 
 	for (size_t i = 0; i < len; i++) {
 		PgfParseNode* node = gu_buf_get(level, PgfParseNode*, i);
-		gu_printf(out, err, "    n%d[label=\"", node->id);
-		gu_string_write(node->label, out, err);
-		gu_puts("\"]\n", out, err);		
+		if (node->fun != NULL) {
+			gu_printf(out, err, "    n%d[label=\"", node->id);
+			if (!opts->noFun)
+				gu_string_write(node->fun, out, err);
+			if (!opts->noFun && !opts->noCat)
+				gu_puts(" : ", out, err);
+			if (!opts->noCat)
+				gu_string_write(node->label, out, err);
+			gu_puts("\"", 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);
+		} else {
+			if (opts->noLeaves)
+				gu_printf(out, err, "    n%d[label=\"\"]\n", node->id);
+			else {
+				gu_printf(out, err, "    n%d[label=\"%s\"", node->id, node->label);
+				if (opts->leafColor != NULL && *opts->leafColor)
+					gu_printf(out, err, ", fontcolor = \"%s\"", opts->leafColor);
+				if (opts->leafFont != NULL && *opts->leafFont)
+					gu_printf(out, err, ", fontname = \"%s\"", opts->leafFont);
+				gu_puts("]\n", out, err);
+			}
+		}
 	}
 	
 	if (len > 1) {
@@ -227,13 +280,32 @@ pgf_graphviz_parse_level(GuBuf* level, GuOut* out, GuExn* err)
 
 	for (size_t i = 0; i < len; i++) {
 		PgfParseNode* node = gu_buf_get(level, PgfParseNode*, i);		
-		if (node->parent != NULL)
-			gu_printf(out, err, "  n%d -- n%d\n", node->parent->id, node->id);
+		if (node->parent != NULL) {
+			gu_printf(out, err, "  n%d -- n%d", node->parent->id, node->id);
+
+			GuString edgeStyle, color;
+			if (node->fun == NULL) {
+				edgeStyle = opts->leafEdgeStyle;
+				color     = opts->leafColor;
+			} else {
+				edgeStyle = opts->nodeEdgeStyle;
+				color     = opts->nodeColor;
+			}
+
+			if (edgeStyle != NULL && *edgeStyle && color != NULL && *color)
+				gu_printf(out, err, " [style = \"%s\", color = \"%s\"]", edgeStyle, color);
+			else if (edgeStyle != NULL && *edgeStyle)
+				gu_printf(out, err, " [style = \"%s\"]", edgeStyle);
+			else if (color != NULL && *color)
+				gu_printf(out, err, " [color = \"%s\"]", color);
+
+			gu_putc('\n', out, err);			
+		}
 	}
 }
 
 PGF_API void
-pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, GuOut* out, GuExn* err)
+pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err)
 {
 	GuPool* tmp_pool = gu_local_pool();
 	
@@ -266,9 +338,9 @@ pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, GuOut* out, GuExn* err)
 	size_t len = gu_buf_length(state.internals);
 	for (size_t i = 0; i < len; i++) {
 		GuBuf* level = gu_buf_get(state.internals, GuBuf*, i);
-		pgf_graphviz_parse_level(level, out, err);
+		pgf_graphviz_parse_level(level, opts, out, err);
 	}
-	pgf_graphviz_parse_level(state.leaves, out, err);
+	pgf_graphviz_parse_level(state.leaves, opts, out, err);
 
 	gu_puts("}", out, err);
 
diff --git a/src/runtime/c/pgf/graphviz.h b/src/runtime/c/pgf/graphviz.h
index f2fdf11d8..d230fdcd8 100644
--- a/src/runtime/c/pgf/graphviz.h
+++ b/src/runtime/c/pgf/graphviz.h
@@ -1,10 +1,25 @@
 #ifndef PGF_GRAPHVIZ_H_
 #define PGF_GRAPHVIZ_H_
 
+typedef struct {
+	int noLeaves;
+	int noFun;
+	int noCat;
+	int noDep;
+    GuString nodeFont;
+    GuString leafFont;
+	GuString nodeColor;
+	GuString leafColor;
+    GuString nodeEdgeStyle;
+    GuString leafEdgeStyle;
+} PgfGraphvizOptions;
+
+extern PgfGraphvizOptions pgf_default_graphviz_options[1];
+
 PGF_API_DECL void
-pgf_graphviz_abstract_tree(PgfPGF* pgf, PgfExpr expr, GuOut* out, GuExn* err);
+pgf_graphviz_abstract_tree(PgfPGF* pgf, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err);
 
 PGF_API_DECL void
-pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, GuOut* out, GuExn* err);
+pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err);
 
 #endif
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 93158213f..45320c6cb 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -66,7 +66,8 @@ module PGF2 (-- * PGF
              -- ** Morphological Analysis
              MorphoAnalysis, lookupMorpho, fullFormLexicon,
              -- ** Visualizations
-             graphvizAbstractTree,graphvizParseTree,
+             GraphvizOptions(..), graphvizDefaults,
+             graphvizAbstractTree, graphvizParseTree,
 
              -- * Exceptions
              PGFError(..),
@@ -316,30 +317,61 @@ compute (PGF p _) (Expr c_expr touch1) =
 -----------------------------------------------------------------------------
 -- Graphviz
 
+data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
+                                        noFun :: Bool,
+                                        noCat :: Bool,
+                                        noDep :: Bool,
+                                        nodeFont :: String,
+                                        leafFont :: String,
+                                        nodeColor :: String,
+                                        leafColor :: String,
+                                        nodeEdgeStyle :: String,
+                                        leafEdgeStyle :: String
+                                       }
+
+graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
+
 -- | Renders an abstract syntax tree in a Graphviz format.
-graphvizAbstractTree :: PGF -> Expr -> String
-graphvizAbstractTree p e =
+graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
+graphvizAbstractTree p opts e =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
       do (sb,out) <- newOut tmpPl
          exn <- gu_new_exn tmpPl
-         pgf_graphviz_abstract_tree (pgf p) (expr e) out exn
+         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
 
 
-graphvizParseTree :: Concr -> Expr -> String
-graphvizParseTree c e =
+graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
+graphvizParseTree c opts e =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
       do (sb,out) <- newOut tmpPl
          exn <- gu_new_exn tmpPl
-         pgf_graphviz_parse_tree (concr c) (expr e) out exn
+         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
 
+newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions)
+newGraphvizOptions pool opts = do
+  c_opts <- gu_malloc pool (#size PgfGraphvizOptions)
+  (#poke PgfGraphvizOptions, noLeaves) c_opts (if noLeaves opts then 1 else 0 :: CInt)
+  (#poke PgfGraphvizOptions, noFun)    c_opts (if noFun    opts then 1 else 0 :: CInt)
+  (#poke PgfGraphvizOptions, noCat)    c_opts (if noCat    opts then 1 else 0 :: CInt)
+  (#poke PgfGraphvizOptions, noDep)    c_opts (if noDep    opts then 1 else 0 :: CInt)
+  newUtf8CString (nodeFont opts) pool >>= (#poke PgfGraphvizOptions, nodeFont) c_opts
+  newUtf8CString (leafFont opts) pool >>= (#poke PgfGraphvizOptions, leafFont) c_opts
+  newUtf8CString (nodeColor opts) pool >>= (#poke PgfGraphvizOptions, nodeColor) c_opts
+  newUtf8CString (leafColor opts) pool >>= (#poke PgfGraphvizOptions, leafColor) c_opts
+  newUtf8CString (nodeEdgeStyle opts) pool >>= (#poke PgfGraphvizOptions, nodeEdgeStyle) c_opts
+  newUtf8CString (leafEdgeStyle opts) pool >>= (#poke PgfGraphvizOptions, leafEdgeStyle) c_opts
+  return c_opts
+
 -----------------------------------------------------------------------------
 -- Functions using Concr
 -- Morpho analyses, parsing & linearization
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 7379aa723..e28e555c2 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -148,6 +148,7 @@ data PgfCallbacksMap
 data PgfOracleCallback
 data PgfCncTree
 data PgfLinFuncs
+data PgfGraphvizOptions
 
 foreign import ccall "pgf/pgf.h pgf_read"
   pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -364,7 +365,7 @@ foreign import ccall "pgf/expr.h pgf_read_type"
   pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
-  pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
+  pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
-  pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
+  pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
diff --git a/src/runtime/java/jpgf.c b/src/runtime/java/jpgf.c
index 2eb151836..db662f5c2 100644
--- a/src/runtime/java/jpgf.c
+++ b/src/runtime/java/jpgf.c
@@ -382,6 +382,7 @@ Java_org_grammaticalframework_pgf_PGF_graphvizAbstractTree(JNIEnv* env, jobject
 
 	pgf_graphviz_abstract_tree(get_ref(env,self),
 	                           gu_variant_from_ptr(l2p(get_ref(env,jexpr))),
+	                           pgf_default_graphviz_options,
 	                           out, err);
 
 	jstring jstr = gu2j_string_buf(env, sbuf);
@@ -1228,6 +1229,7 @@ Java_org_grammaticalframework_pgf_Concr_graphvizParseTree(JNIEnv* env, jobject s
 
 	pgf_graphviz_parse_tree(get_ref(env,self),
 	                        gu_variant_from_ptr(l2p(get_ref(env,jexpr))),
+	                        pgf_default_graphviz_options,
 	                        out, err);
 
 	jstring jstr = gu2j_string_buf(env, sbuf);
diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 70728f1c7..7da62e453 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -2281,7 +2281,7 @@ Concr_graphvizParseTree(ConcrObject* self, PyObject *args) {
 	GuStringBuf* sbuf = gu_new_string_buf(tmp_pool);
 	GuOut* out = gu_string_buf_out(sbuf);
 	
-	pgf_graphviz_parse_tree(self->concr, pyexpr->expr, out, err);
+	pgf_graphviz_parse_tree(self->concr, pyexpr->expr, pgf_default_graphviz_options, out, err);
 	if (!gu_ok(err)) {
 		if (gu_exn_caught(err, PgfExn)) {
 			GuString msg = (GuString) gu_exn_caught_data(err);
@@ -3075,7 +3075,7 @@ PGF_graphvizAbstractTree(PGFObject* self, PyObject *args) {
 	GuStringBuf* sbuf = gu_new_string_buf(tmp_pool);
 	GuOut* out = gu_string_buf_out(sbuf);
 	
-	pgf_graphviz_abstract_tree(self->pgf, pyexpr->expr, out, err);
+	pgf_graphviz_abstract_tree(self->pgf, pyexpr->expr, pgf_default_graphviz_options, out, err);
 	if (!gu_ok(err)) {
 		PyErr_SetString(PGFError, "The abstract tree cannot be visualized");
 		return NULL;