module Text.GrammarCombinators.Utils.ToGraph (
ruleToGraph,
graphToGraphviz,
fullGrammarToGraph,
reachableGrammarToGraph,
showGraph
) where
import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.IsReachable
import Data.String (fromString)
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Control.Monad.Writer
import Data.Graph.Inductive.PatriciaTree
import Data.GraphViz
newNode :: (MonadState (Int, Int) m) => m Int
newNode = do (d, n) <- get
put (d, n + 1)
return n
tell1 :: (MonadWriter [w] m) => w -> m ()
tell1 w = tell [w]
newtype GraphConstructor (phi :: * -> *) (r :: * -> *) t v =
MkGC {
constructContexts ::
Adj String -> Bool ->
WriterT [Context String String] (State (Int, Int)) (Adj String)
}
leafNode :: String -> Bool -> GraphConstructor phi r t v
leafNode label eps = MkGC $ \parentEdge printeps ->
if not eps || printeps
then do ln <- newNode
tell1 (parentEdge, ln, label, [])
return [("",ln)]
else return parentEdge
constructContextsSub :: GraphConstructor phi r t v -> Adj String ->
Bool ->
WriterT [Context String String] (State (Int, Int)) (Adj String)
constructContextsSub r pe printeps =
do (d, n) <- get
if d > 0
then put (d1,n) >>
constructContexts r pe printeps
else do n' <- newNode
tell1 (pe, n', "(...)", [])
return []
instance ProductionRule (GraphConstructor phi r t) where
ra >>> rb = MkGC $ \parentEdge printeps ->
do (d,_) <- get
pe <- constructContextsSub ra parentEdge False
if null pe
then return []
else do modify $ \(_,n) -> (d,n)
constructContextsSub rb pe printeps
ra ||| rb = MkGC $ \parentEdge _ ->
do (d,_) <- get
pea <- constructContextsSub ra parentEdge True
modify $ \(_,n) -> (d,n)
peb <- constructContextsSub rb parentEdge True
return $ pea ++ peb
endOfInput = leafNode "endOfInput" False
die = leafNode "die" False
instance EpsProductionRule (GraphConstructor phi r t) where
epsilon _ = leafNode "epsilon" True
instance LiftableProductionRule (GraphConstructor phi r t) where
epsilonL _ _ = leafNode "epsilon" True
instance (Token t) =>
TokenProductionRule (GraphConstructor phi r t) t where
token tt = leafNode (show tt) False
anyToken = leafNode "anyToken" False
instance (Domain phi) => RecProductionRule (GraphConstructor phi r t) phi r where
ref idx = leafNode ("<" ++ showIdx idx ++ ">") False
instance (Domain phi) => LoopProductionRule (GraphConstructor phi r t) phi r where
manyRef idx = leafNode ("<" ++ showIdx idx ++ ">*") False
ruleToGraph :: forall phi t r rr gr ix. (Token t, Domain phi, DynGraph gr) =>
Int -> GExtendedContextFreeGrammar phi t r rr ->
phi ix -> gr String String
ruleToGraph depth gram idx = buildGr $ snd $ ruleToContexts depth gram idx 0
ruleToContexts :: forall phi t r rr ix. (Token t, Domain phi) =>
Int -> GExtendedContextFreeGrammar phi t r rr ->
phi ix -> Int -> (Int, [Context String String])
ruleToContexts depth gram idx sn =
let
processNTDef :: phi ix ->
WriterT [Context String String] (State (Int, Int)) (Adj String)
processNTDef idx' =
do ntNode <- newNode
tell1 ([], ntNode, showIdx idx', [])
let stAdj = [("", ntNode)]
constructContexts (gram idx') stAdj True
(contexts, (_,nsn)) = flip runState (depth, sn) $ execWriterT $ processNTDef idx
in (nsn, reverse contexts)
graphvizParams :: GraphvizParams Node String String () String
graphvizParams = Params {
isDirected = True,
globalAttributes = [],
clusterBy = N,
clusterID = \_ -> undefined,
isDotCluster = \_ -> undefined,
fmtCluster = const [],
fmtNode = \(_,n) -> [toLabel n],
fmtEdge = \(_,_,_) -> []
}
graphToGraphviz :: Gr String String -> DotGraph Node
graphToGraphviz gr = setID (Str $ fromString "Grammar") $ graphToDot graphvizParams (gr :: Gr String String)
grammarToContexts :: forall phi t r rr . (Token t, Domain phi) =>
(forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->
Int -> GExtendedContextFreeGrammar phi t r rr ->
[Context String String]
grammarToContexts fold' depth gram =
let
processRule idx (nsn, cs) = (nsn', cs ++ cs')
where (nsn', cs') = ruleToContexts depth gram idx nsn
in snd $ fold' processRule (0,[])
grammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) =>
(forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->
Int -> GExtendedContextFreeGrammar phi t r rr ->
gr String String
grammarToGraph fold' depth gram = buildGr $ grammarToContexts fold' depth gram
fullGrammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) =>
Int -> GExtendedContextFreeGrammar phi t r rr ->
gr String String
fullGrammarToGraph = grammarToGraph foldFam
reachableGrammarToGraph :: forall phi t r rr gr ix . (Token t, Domain phi, DynGraph gr) =>
Int -> GExtendedContextFreeGrammar phi t r rr -> phi ix ->
gr String String
reachableGrammarToGraph depth gram idx = grammarToGraph (foldReachable gram idx) depth gram
showGraph :: (PrintDotRepr dg n) => dg n -> IO ()
showGraph gr = runGraphvizCanvas' gr Xlib >> return ()