From 3d1123eed4ad95f801df7fd5873081a6ba01e6d7 Mon Sep 17 00:00:00 2001 From: krangelov Date: Sat, 4 Dec 2021 14:12:23 +0100 Subject: [PATCH] restore graphvizParseTree --- src/compiler/GF/Command/Commands.hs | 6 +----- src/runtime/c/Makefile.am | 2 ++ src/runtime/c/pgf/pgf.cxx | 25 ++++++++++++++++++++++++ src/runtime/c/pgf/pgf.h | 19 ++++++++++++++++++ src/runtime/haskell/PGF2.hsc | 30 ++++++++++++++++++++++++++++- src/runtime/haskell/PGF2/FFI.hsc | 4 ++++ 6 files changed, 80 insertions(+), 6 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index a2bbcfdeb..ddb7763bf 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/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 - "" -> return Nothing - _ -> (Just . getDepLabels) `fmap` restricted (readFile depfile) - let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es + let grphs = map (graphvizParseTree concr gvOptions) es if isFlag "view" opts || isFlag "format" opts then do let view = optViewGraph opts diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 2f4721282..09d2b147b 100644 --- a/src/runtime/c/Makefile.am +++ b/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 \ diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 1a1f1f4c7..00c0ea815 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/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 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; +} diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 249687f26..8959fd25e 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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_ diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index a20fed383..ef98989bf 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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" diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 60046a44a..47cee9485 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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