diff options
| author | Krasimir Angelov <kr.angelov@gmail.com> | 2017-08-31 10:58:49 +0200 |
|---|---|---|
| committer | Krasimir Angelov <kr.angelov@gmail.com> | 2017-08-31 10:58:49 +0200 |
| commit | eaf9f0c3ac2ce1c34a0e08de9073d8fca66a3680 (patch) | |
| tree | ce43fb9e4d2e4ed63ce093ca6a5553923c6063ad /src/runtime/haskell-bind/PGF2.hsc | |
| parent | 675ef4573ccf14fd380f7d1e6bc9ba97e5408ee3 (diff) | |
the C runtime now supports the same customizations for GraphViz as the Haskell runtime
Diffstat (limited to 'src/runtime/haskell-bind/PGF2.hsc')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 46 |
1 files changed, 39 insertions, 7 deletions
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 |