GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-06 01:32:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Krasimir Angelov
2017-08-31 10:58:49 +02:00
parent 675ef4573c
commit eaf9f0c3ac
8 changed files with 189 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -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