{-# LANGUAGE OverloadedStrings #-}
module Data.ECTA.Internal.ECTA.Visualization (
toDot
) where
import qualified Data.Text as Text
import qualified Data.Graph.Inductive as Fgl
import Data.List.Index ( imap )
import qualified Language.Dot.Syntax as Dot
import Data.ECTA.Internal.ECTA.Operations ( maxIndegree, crush )
import Data.ECTA.Internal.ECTA.Type
import Data.ECTA.Internal.Paths ( EqConstraints )
import Data.ECTA.Internal.Term
import Data.Interned.Extended.HashTableBased ( Id )
import Data.Text.Extended.Pretty
type EdgeId = (Id, Int)
data PartialGraph = PartialGraph {
PartialGraph -> [Id]
partialNormal :: [Id]
, PartialGraph -> [(Id, Id)]
partialMu :: [(Id, Id)]
, PartialGraph -> [((Id, Id), Symbol, EqConstraints)]
partialEdges :: [(EdgeId, Symbol, EqConstraints)]
, PartialGraph -> [(Id, (Id, Id))]
partialFromNode :: [(Id, EdgeId)]
, PartialGraph -> [((Id, Id), Id)]
partialFromEdge :: [(EdgeId, Id)]
}
deriving (Id -> PartialGraph -> ShowS
[PartialGraph] -> ShowS
PartialGraph -> String
(Id -> PartialGraph -> ShowS)
-> (PartialGraph -> String)
-> ([PartialGraph] -> ShowS)
-> Show PartialGraph
forall a.
(Id -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PartialGraph] -> ShowS
$cshowList :: [PartialGraph] -> ShowS
show :: PartialGraph -> String
$cshow :: PartialGraph -> String
showsPrec :: Id -> PartialGraph -> ShowS
$cshowsPrec :: Id -> PartialGraph -> ShowS
Show)
instance Semigroup PartialGraph where
PartialGraph
a <> :: PartialGraph -> PartialGraph -> PartialGraph
<> PartialGraph
b = PartialGraph :: [Id]
-> [(Id, Id)]
-> [((Id, Id), Symbol, EqConstraints)]
-> [(Id, (Id, Id))]
-> [((Id, Id), Id)]
-> PartialGraph
PartialGraph {
partialNormal :: [Id]
partialNormal = (PartialGraph -> [Id]) -> [Id]
forall a. Semigroup a => (PartialGraph -> a) -> a
combine PartialGraph -> [Id]
partialNormal
, partialMu :: [(Id, Id)]
partialMu = (PartialGraph -> [(Id, Id)]) -> [(Id, Id)]
forall a. Semigroup a => (PartialGraph -> a) -> a
combine PartialGraph -> [(Id, Id)]
partialMu
, partialEdges :: [((Id, Id), Symbol, EqConstraints)]
partialEdges = (PartialGraph -> [((Id, Id), Symbol, EqConstraints)])
-> [((Id, Id), Symbol, EqConstraints)]
forall a. Semigroup a => (PartialGraph -> a) -> a
combine PartialGraph -> [((Id, Id), Symbol, EqConstraints)]
partialEdges
, partialFromNode :: [(Id, (Id, Id))]
partialFromNode = (PartialGraph -> [(Id, (Id, Id))]) -> [(Id, (Id, Id))]
forall a. Semigroup a => (PartialGraph -> a) -> a
combine PartialGraph -> [(Id, (Id, Id))]
partialFromNode
, partialFromEdge :: [((Id, Id), Id)]
partialFromEdge = (PartialGraph -> [((Id, Id), Id)]) -> [((Id, Id), Id)]
forall a. Semigroup a => (PartialGraph -> a) -> a
combine PartialGraph -> [((Id, Id), Id)]
partialFromEdge
}
where
combine :: Semigroup a => (PartialGraph -> a) -> a
combine :: (PartialGraph -> a) -> a
combine PartialGraph -> a
f = PartialGraph -> a
f PartialGraph
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> PartialGraph -> a
f PartialGraph
b
instance Monoid PartialGraph where
mempty :: PartialGraph
mempty = PartialGraph :: [Id]
-> [(Id, Id)]
-> [((Id, Id), Symbol, EqConstraints)]
-> [(Id, (Id, Id))]
-> [((Id, Id), Id)]
-> PartialGraph
PartialGraph {
partialNormal :: [Id]
partialNormal = []
, partialMu :: [(Id, Id)]
partialMu = []
, partialEdges :: [((Id, Id), Symbol, EqConstraints)]
partialEdges = []
, partialFromNode :: [(Id, (Id, Id))]
partialFromNode = []
, partialFromEdge :: [((Id, Id), Id)]
partialFromEdge = []
}
mkPartialGraph :: Node -> PartialGraph
mkPartialGraph :: Node -> PartialGraph
mkPartialGraph = (Node -> PartialGraph) -> Node -> PartialGraph
forall m. Monoid m => (Node -> m) -> Node -> m
crush Node -> PartialGraph
onNode
where
onNode :: Node -> PartialGraph
onNode :: Node -> PartialGraph
onNode Node
EmptyNode = String -> PartialGraph
forall a. HasCallStack => String -> a
error String
"mkPartialGraph: impossible (crush does not invoke function on EmptyNode)"
onNode (InternedNode InternedNode
node) = let ([((Id, Id), Symbol, EqConstraints)]
edgeNodes, [(Id, (Id, Id))]
fr, [[((Id, Id), Id)]]
to) = [(((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])]
-> ([((Id, Id), Symbol, EqConstraints)], [(Id, (Id, Id))],
[[((Id, Id), Id)]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])]
-> ([((Id, Id), Symbol, EqConstraints)], [(Id, (Id, Id))],
[[((Id, Id), Id)]]))
-> [(((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])]
-> ([((Id, Id), Symbol, EqConstraints)], [(Id, (Id, Id))],
[[((Id, Id), Id)]])
forall a b. (a -> b) -> a -> b
$ (Id
-> Edge
-> (((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)]))
-> [Edge]
-> [(((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])]
forall a b. (Id -> a -> b) -> [a] -> [b]
imap (Id
-> Id
-> Edge
-> (((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])
onEdge Id
nid) [Edge]
es in
PartialGraph
forall a. Monoid a => a
mempty {
partialNormal :: [Id]
partialNormal = [Id
nid]
, partialEdges :: [((Id, Id), Symbol, EqConstraints)]
partialEdges = [((Id, Id), Symbol, EqConstraints)]
edgeNodes
, partialFromNode :: [(Id, (Id, Id))]
partialFromNode = [(Id, (Id, Id))]
fr
, partialFromEdge :: [((Id, Id), Id)]
partialFromEdge = [[((Id, Id), Id)]] -> [((Id, Id), Id)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[((Id, Id), Id)]]
to
}
where
nid :: Id
nid = InternedNode -> Id
internedNodeId InternedNode
node
es :: [Edge]
es = InternedNode -> [Edge]
internedNodeEdges InternedNode
node
onNode (InternedMu InternedMu
mu) = case InternedMu -> Node
internedMuBody InternedMu
mu of
InternedNode InternedNode
node -> PartialGraph
forall a. Monoid a => a
mempty {
partialMu :: [(Id, Id)]
partialMu = [(InternedMu -> Id
internedMuId InternedMu
mu, InternedNode -> Id
internedNodeId InternedNode
node)]
}
Node
_otherwise -> String -> PartialGraph
forall a. HasCallStack => String -> a
error String
"mkPartialGraph: expected Node as a child of a Mu"
onNode (Rec RecNodeId
_) = PartialGraph
forall a. Monoid a => a
mempty
onEdge :: Id
-> Int
-> Edge
-> ( (EdgeId, Symbol, EqConstraints)
, (Id, EdgeId)
, [(EdgeId, Id)]
)
onEdge :: Id
-> Id
-> Edge
-> (((Id, Id), Symbol, EqConstraints), (Id, (Id, Id)),
[((Id, Id), Id)])
onEdge Id
nid Id
i Edge
e = (
((Id, Id)
eid, Edge -> Symbol
edgeSymbol Edge
e, Edge -> EqConstraints
edgeEcs Edge
e)
, (Id
nid, (Id, Id)
eid)
, (Node -> ((Id, Id), Id)) -> [Node] -> [((Id, Id), Id)]
forall a b. (a -> b) -> [a] -> [b]
map (\Node
n -> ((Id, Id)
eid, Node -> Id
nodeIdentity Node
n)) ([Node] -> [((Id, Id), Id)]) -> [Node] -> [((Id, Id), Id)]
forall a b. (a -> b) -> a -> b
$ Edge -> [Node]
edgeChildren Edge
e
)
where
eid :: (Id, Id)
eid = (Id
nid, Id
i)
data FglNodeLabel = IdLabel Id | TransitionLabel Symbol EqConstraints
deriving ( FglNodeLabel -> FglNodeLabel -> Bool
(FglNodeLabel -> FglNodeLabel -> Bool)
-> (FglNodeLabel -> FglNodeLabel -> Bool) -> Eq FglNodeLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FglNodeLabel -> FglNodeLabel -> Bool
$c/= :: FglNodeLabel -> FglNodeLabel -> Bool
== :: FglNodeLabel -> FglNodeLabel -> Bool
$c== :: FglNodeLabel -> FglNodeLabel -> Bool
Eq, Eq FglNodeLabel
Eq FglNodeLabel
-> (FglNodeLabel -> FglNodeLabel -> Ordering)
-> (FglNodeLabel -> FglNodeLabel -> Bool)
-> (FglNodeLabel -> FglNodeLabel -> Bool)
-> (FglNodeLabel -> FglNodeLabel -> Bool)
-> (FglNodeLabel -> FglNodeLabel -> Bool)
-> (FglNodeLabel -> FglNodeLabel -> FglNodeLabel)
-> (FglNodeLabel -> FglNodeLabel -> FglNodeLabel)
-> Ord FglNodeLabel
FglNodeLabel -> FglNodeLabel -> Bool
FglNodeLabel -> FglNodeLabel -> Ordering
FglNodeLabel -> FglNodeLabel -> FglNodeLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FglNodeLabel -> FglNodeLabel -> FglNodeLabel
$cmin :: FglNodeLabel -> FglNodeLabel -> FglNodeLabel
max :: FglNodeLabel -> FglNodeLabel -> FglNodeLabel
$cmax :: FglNodeLabel -> FglNodeLabel -> FglNodeLabel
>= :: FglNodeLabel -> FglNodeLabel -> Bool
$c>= :: FglNodeLabel -> FglNodeLabel -> Bool
> :: FglNodeLabel -> FglNodeLabel -> Bool
$c> :: FglNodeLabel -> FglNodeLabel -> Bool
<= :: FglNodeLabel -> FglNodeLabel -> Bool
$c<= :: FglNodeLabel -> FglNodeLabel -> Bool
< :: FglNodeLabel -> FglNodeLabel -> Bool
$c< :: FglNodeLabel -> FglNodeLabel -> Bool
compare :: FglNodeLabel -> FglNodeLabel -> Ordering
$ccompare :: FglNodeLabel -> FglNodeLabel -> Ordering
$cp1Ord :: Eq FglNodeLabel
Ord, Id -> FglNodeLabel -> ShowS
[FglNodeLabel] -> ShowS
FglNodeLabel -> String
(Id -> FglNodeLabel -> ShowS)
-> (FglNodeLabel -> String)
-> ([FglNodeLabel] -> ShowS)
-> Show FglNodeLabel
forall a.
(Id -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FglNodeLabel] -> ShowS
$cshowList :: [FglNodeLabel] -> ShowS
show :: FglNodeLabel -> String
$cshow :: FglNodeLabel -> String
showsPrec :: Id -> FglNodeLabel -> ShowS
$cshowsPrec :: Id -> FglNodeLabel -> ShowS
Show )
partialToFgl :: Int -> PartialGraph -> Fgl.Gr FglNodeLabel ()
partialToFgl :: Id -> PartialGraph -> Gr FglNodeLabel ()
partialToFgl Id
maxNodeIndegree PartialGraph
p =
[LNode FglNodeLabel] -> [LEdge ()] -> Gr FglNodeLabel ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Fgl.mkGraph ([LNode FglNodeLabel]
nodeNodes [LNode FglNodeLabel]
-> [LNode FglNodeLabel] -> [LNode FglNodeLabel]
forall a. [a] -> [a] -> [a]
++ [LNode FglNodeLabel]
transitionNodes) ([LEdge ()]
nodeToTransitionEdges [LEdge ()] -> [LEdge ()] -> [LEdge ()]
forall a. [a] -> [a] -> [a]
++ [LEdge ()]
transitionToNodeEdges)
where
nodeNodes, transitionNodes :: [Fgl.LNode FglNodeLabel]
nodeNodes :: [LNode FglNodeLabel]
nodeNodes = (Id -> LNode FglNodeLabel) -> [Id] -> [LNode FglNodeLabel]
forall a b. (a -> b) -> [a] -> [b]
map (\ Id
i -> (Id -> Id
fglNodeId Id
i, Id -> FglNodeLabel
IdLabel (Id -> FglNodeLabel) -> Id -> FglNodeLabel
forall a b. (a -> b) -> a -> b
$ Id
i)) ([Id] -> [LNode FglNodeLabel]) -> [Id] -> [LNode FglNodeLabel]
forall a b. (a -> b) -> a -> b
$ PartialGraph -> [Id]
partialNormal PartialGraph
p
transitionNodes :: [LNode FglNodeLabel]
transitionNodes = (((Id, Id), Symbol, EqConstraints) -> LNode FglNodeLabel)
-> [((Id, Id), Symbol, EqConstraints)] -> [LNode FglNodeLabel]
forall a b. (a -> b) -> [a] -> [b]
map (\((Id, Id)
i, Symbol
s, EqConstraints
cs) -> ((Id, Id) -> Id
fglEdgeId (Id, Id)
i, Symbol -> EqConstraints -> FglNodeLabel
TransitionLabel Symbol
s EqConstraints
cs)) ([((Id, Id), Symbol, EqConstraints)] -> [LNode FglNodeLabel])
-> [((Id, Id), Symbol, EqConstraints)] -> [LNode FglNodeLabel]
forall a b. (a -> b) -> a -> b
$ PartialGraph -> [((Id, Id), Symbol, EqConstraints)]
partialEdges PartialGraph
p
nodeToTransitionEdges, transitionToNodeEdges :: [Fgl.LEdge ()]
nodeToTransitionEdges :: [LEdge ()]
nodeToTransitionEdges = ((Id, (Id, Id)) -> LEdge ()) -> [(Id, (Id, Id))] -> [LEdge ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
nid, (Id, Id)
eid) -> (Id -> Id
fglNodeId Id
nid, (Id, Id) -> Id
fglEdgeId (Id, Id)
eid, ())) ([(Id, (Id, Id))] -> [LEdge ()]) -> [(Id, (Id, Id))] -> [LEdge ()]
forall a b. (a -> b) -> a -> b
$ PartialGraph -> [(Id, (Id, Id))]
partialFromNode PartialGraph
p
transitionToNodeEdges :: [LEdge ()]
transitionToNodeEdges = (((Id, Id), Id) -> LEdge ()) -> [((Id, Id), Id)] -> [LEdge ()]
forall a b. (a -> b) -> [a] -> [b]
map (\((Id, Id)
eid, Id
nid) -> ((Id, Id) -> Id
fglEdgeId (Id, Id)
eid, Id -> Id
fglNodeId' Id
nid, ())) ([((Id, Id), Id)] -> [LEdge ()]) -> [((Id, Id), Id)] -> [LEdge ()]
forall a b. (a -> b) -> a -> b
$ PartialGraph -> [((Id, Id), Id)]
partialFromEdge PartialGraph
p
fglNodeId :: Id -> Fgl.Node
fglNodeId :: Id -> Id
fglNodeId Id
nid = Id
nid Id -> Id -> Id
forall a. Num a => a -> a -> a
* (Id
maxNodeIndegree Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
1)
fglNodeId' :: Id -> Fgl.Node
fglNodeId' :: Id -> Id
fglNodeId' Id
nid = Id -> (Id -> Id) -> Maybe Id -> Id
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Id -> Id
fglNodeId Id
nid) Id -> Id
fglNodeId (Id -> [(Id, Id)] -> Maybe Id
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Id
nid ([(Id, Id)] -> Maybe Id) -> [(Id, Id)] -> Maybe Id
forall a b. (a -> b) -> a -> b
$ PartialGraph -> [(Id, Id)]
partialMu PartialGraph
p)
fglEdgeId :: EdgeId -> Fgl.Node
fglEdgeId :: (Id, Id) -> Id
fglEdgeId (Id
nid, Id
i) = Id
nid Id -> Id -> Id
forall a. Num a => a -> a -> a
* (Id
maxNodeIndegree Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
1) Id -> Id -> Id
forall a. Num a => a -> a -> a
+ (Id
i Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
1)
toFgl :: Node -> Fgl.Gr FglNodeLabel ()
toFgl :: Node -> Gr FglNodeLabel ()
toFgl Node
root = Id -> PartialGraph -> Gr FglNodeLabel ()
partialToFgl (Node -> Id
maxIndegree Node
root) (Node -> PartialGraph
mkPartialGraph Node
root)
fglToDot :: Fgl.Gr FglNodeLabel () -> Dot.Graph
fglToDot :: Gr FglNodeLabel () -> Graph
fglToDot Gr FglNodeLabel ()
g = GraphStrictness
-> GraphDirectedness -> Maybe Id -> [Statement] -> Graph
Dot.Graph GraphStrictness
Dot.StrictGraph GraphDirectedness
Dot.DirectedGraph Maybe Id
forall a. Maybe a
Nothing ([Statement]
nodeStmts [Statement] -> [Statement] -> [Statement]
forall a. [a] -> [a] -> [a]
++ [Statement]
edgeStmts)
where
nodeStmts :: [Dot.Statement]
nodeStmts :: [Statement]
nodeStmts = (LNode FglNodeLabel -> Statement)
-> [LNode FglNodeLabel] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map LNode FglNodeLabel -> Statement
renderNode ([LNode FglNodeLabel] -> [Statement])
-> [LNode FglNodeLabel] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Gr FglNodeLabel () -> [LNode FglNodeLabel]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
Fgl.labNodes Gr FglNodeLabel ()
g
edgeStmts :: [Dot.Statement]
edgeStmts :: [Statement]
edgeStmts = (LEdge () -> Statement) -> [LEdge ()] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map LEdge () -> Statement
renderEdge ([LEdge ()] -> [Statement]) -> [LEdge ()] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Gr FglNodeLabel () -> [LEdge ()]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
Fgl.labEdges Gr FglNodeLabel ()
g
renderNode :: Fgl.LNode FglNodeLabel -> Dot.Statement
renderNode :: LNode FglNodeLabel -> Statement
renderNode (Id
fglId, FglNodeLabel
l) = NodeId -> [Attribute] -> Statement
Dot.NodeStatement (Id -> Maybe Port -> NodeId
Dot.NodeId (Integer -> Id
Dot.IntegerId (Integer -> Id) -> Integer -> Id
forall a b. (a -> b) -> a -> b
$ Id -> Integer
forall a. Integral a => a -> Integer
toInteger Id
fglId) Maybe Port
forall a. Maybe a
Nothing)
[ Id -> Id -> Attribute
Dot.AttributeSetValue (String -> Id
Dot.NameId String
"label") (FglNodeLabel -> Id
renderNodeLabel FglNodeLabel
l)
, Id -> Id -> Attribute
Dot.AttributeSetValue (String -> Id
Dot.NameId String
"shape")
(case FglNodeLabel
l of
IdLabel Id
_ -> String -> Id
Dot.StringId String
"ellipse"
TransitionLabel Symbol
_ EqConstraints
_ -> String -> Id
Dot.StringId String
"box")
]
renderEdge :: Fgl.LEdge () -> Dot.Statement
renderEdge :: LEdge () -> Statement
renderEdge (Id
a, Id
b, ()
_) = [Entity] -> [Attribute] -> Statement
Dot.EdgeStatement [Entity
ea, Entity
eb] []
where
ea :: Entity
ea = EdgeType -> NodeId -> Entity
Dot.ENodeId EdgeType
Dot.NoEdge (Id -> Maybe Port -> NodeId
Dot.NodeId (Integer -> Id
Dot.IntegerId (Integer -> Id) -> Integer -> Id
forall a b. (a -> b) -> a -> b
$ Id -> Integer
forall a. Integral a => a -> Integer
toInteger Id
a) Maybe Port
forall a. Maybe a
Nothing)
eb :: Entity
eb = EdgeType -> NodeId -> Entity
Dot.ENodeId EdgeType
Dot.DirectedEdge (Id -> Maybe Port -> NodeId
Dot.NodeId (Integer -> Id
Dot.IntegerId (Integer -> Id) -> Integer -> Id
forall a b. (a -> b) -> a -> b
$ Id -> Integer
forall a. Integral a => a -> Integer
toInteger Id
b) Maybe Port
forall a. Maybe a
Nothing)
renderNodeLabel :: FglNodeLabel -> Dot.Id
renderNodeLabel :: FglNodeLabel -> Id
renderNodeLabel (IdLabel Id
l) = String -> Id
Dot.StringId (String
"q" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
l)
renderNodeLabel (TransitionLabel Symbol
s EqConstraints
ecs) =
String -> Id
Dot.StringId (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Symbol -> Text
forall a. Pretty a => a -> Text
pretty Symbol
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EqConstraints -> Text
forall a. Pretty a => a -> Text
pretty EqConstraints
ecs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
toDot :: Node -> Dot.Graph
toDot :: Node -> Graph
toDot = Gr FglNodeLabel () -> Graph
fglToDot (Gr FglNodeLabel () -> Graph)
-> (Node -> Gr FglNodeLabel ()) -> Node -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Gr FglNodeLabel ()
toFgl