restore graphvizParseTree

src/compiler/GF/Command/Commands.hs

@@ -561,12 +561,8 @@ pgfCommands = Map.fromList [
                                           nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
                                           leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
                                          }
-         let depfile = valStrOpts "file" "" opts
          concr  <- optLang pgf opts
-         mlab <- case depfile of
+         let grphs = map (graphvizParseTree concr gvOptions) es
-           "" -> return Nothing
-           _  -> (Just . getDepLabels) `fmap` restricted (readFile depfile)
-         let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts

src/runtime/c/Makefile.am

@@ -23,6 +23,8 @@ libpgf_la_SOURCES = \
 	pgf/typechecker.h \
 	pgf/linearizer.cxx \
 	pgf/linearizer.h \
+	pgf/graphviz.cxx \
+	pgf/graphviz.h \
 	pgf/data.cxx \
 	pgf/data.h \
 	pgf/expr.cxx \

src/runtime/c/pgf/pgf.cxx

@@ -11,6 +11,7 @@
 #include "printer.h"
 #include "typechecker.h"
 #include "linearizer.h"
+#include "graphviz.h"
 
 static void
 pgf_exn_clear(PgfExn* err)
@@ -2065,3 +2066,27 @@ void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision,
         concr->cflags = cflags;
     } PGF_API_END
 }
+
+PGF_API PgfText *
+pgf_graphviz_parse_tree(PgfDB *db, PgfConcrRevision revision,
+                        PgfExpr expr, PgfMarshaller *m,
+                        PgfGraphvizOptions* opts,
+                        PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        PgfLinearizationGraphvizOutput out;
+        PgfLinearizer linearizer(concr, m);
+        m->match_expr(&linearizer, expr);
+        linearizer.reverse_and_label();
+        if (linearizer.resolve()) {
+            linearizer.linearize(&out);
+            return out.generate_graphviz(opts);
+        }
+    } PGF_API_END
+
+    return NULL;
+}

src/runtime/c/pgf/pgf.h

@@ -672,4 +672,23 @@ void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision,
                            PgfMarshaller *m,
                            PgfExn *err);
 
+typedef struct {
+    int noLeaves;
+    int noFun;
+    int noCat;
+    int noDep;
+    const char *nodeFont;
+    const char *leafFont;
+    const char *nodeColor;
+    const char *leafColor;
+    const char *nodeEdgeStyle;
+    const char *leafEdgeStyle;
+} PgfGraphvizOptions;
+
+PGF_API PgfText *
+pgf_graphviz_parse_tree(PgfDB *db, PgfConcrRevision revision,
+                        PgfExpr expr, PgfMarshaller *m,
+                        PgfGraphvizOptions* opts,
+                        PgfExn *err);
+
 #endif // PGF_H_

src/runtime/haskell/PGF2.hsc

@@ -858,12 +858,40 @@ data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
 
 graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
 
+withGraphvizOptions :: GraphvizOptions -> (Ptr PgfGraphvizOptions -> IO a) -> IO a
+withGraphvizOptions opts f =
+  allocaBytes (#size PgfGraphvizOptions) $ \c_opts ->
+  withCString (nodeFont opts) $ \c_nodeFont ->
+  withCString (leafFont opts) $ \c_leafFont ->
+  withCString (nodeColor opts) $ \c_nodeColor ->
+  withCString (leafColor opts) $ \c_leafColor ->
+  withCString (nodeEdgeStyle opts) $ \c_nodeEdgeStyle ->
+  withCString (leafEdgeStyle opts) $ \c_leafEdgeStyle -> do
+    (#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)
+    (#poke PgfGraphvizOptions, nodeFont) c_opts c_nodeFont
+    (#poke PgfGraphvizOptions, leafFont) c_opts c_leafFont
+    (#poke PgfGraphvizOptions, nodeColor) c_opts c_nodeColor
+    (#poke PgfGraphvizOptions, leafColor) c_opts c_leafColor
+    (#poke PgfGraphvizOptions, nodeEdgeStyle) c_opts c_nodeEdgeStyle
+    (#poke PgfGraphvizOptions, leafEdgeStyle) c_opts c_leafEdgeStyle
+    f c_opts
+
 -- | Renders an abstract syntax tree in a Graphviz format.
 graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
 graphvizAbstractTree p opts e = error "TODO: graphvizAbstractTree"
 
 graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
-graphvizParseTree c opts e = error "TODO: graphvizParseTree"
+graphvizParseTree c opts e =
+  unsafePerformIO $
+  withForeignPtr (c_revision c) $ \c_revision ->
+  bracket (newStablePtr e) freeStablePtr $ \c_e ->
+  withForeignPtr marshaller $ \m ->
+  withGraphvizOptions opts $ \c_opts ->
+  bracket (withPgfExn "graphvizParseTree" (pgf_graphviz_parse_tree  (c_db c) c_revision c_e m c_opts)) free $ \c_text ->
+    peekText c_text
 
 graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
 graphvizWordAlignment cs opts e = error "TODO: graphvizWordAlignment"

src/runtime/haskell/PGF2/FFI.hsc

@@ -44,6 +44,7 @@ data PgfUnmarshaller
 data PgfBuildLinIface
 data PgfLinBuilderIface
 data PgfLinearizationOutputIface
+data PgfGraphvizOptions
 
 type Wrapper a = a -> IO (FunPtr a)
 type Dynamic a = FunPtr a -> a
@@ -226,6 +227,9 @@ foreign import ccall pgf_get_concrete_flag :: Ptr PgfDB -> Ptr Concr -> Ptr PgfT
 
 foreign import ccall pgf_set_concrete_flag :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
+foreign import ccall pgf_graphviz_parse_tree :: Ptr PgfDB -> Ptr Concr -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfGraphvizOptions -> Ptr PgfExn -> IO (Ptr PgfText)
+
+
 -----------------------------------------------------------------------
 -- Texts