module Language.Lexer.Tlex.Plugin.Debug (
    outputDfaToDot,
    Graphviz.outputAst,
) where

import           Language.Lexer.Tlex.Prelude

import qualified Data.HashMap.Strict                       as HashMap
import qualified Data.IntMap.Strict                        as IntMap
import qualified Data.IntSet                               as IntSet
import qualified Language.Lexer.Tlex.Data.EnumMap          as EnumMap
import qualified Language.Lexer.Tlex.Machine.DFA           as DFA
import qualified Language.Lexer.Tlex.Machine.State         as MState
import qualified Language.Lexer.Tlex.Plugin.Debug.Graphviz as Graphviz
import qualified Prelude


newtype EdgeBuilder = EdgeBuilder
    { EdgeBuilder -> HashMap (StateNum, StateNum) IntSet
unEdgeBuilder :: HashMap.HashMap
        (MState.StateNum, MState.StateNum)
        IntSet.IntSet
    }

instance Semigroup EdgeBuilder where
    EdgeBuilder HashMap (StateNum, StateNum) IntSet
m1 <> :: EdgeBuilder -> EdgeBuilder -> EdgeBuilder
<> EdgeBuilder HashMap (StateNum, StateNum) IntSet
m2 = HashMap (StateNum, StateNum) IntSet -> EdgeBuilder
EdgeBuilder do (IntSet -> IntSet -> IntSet)
-> HashMap (StateNum, StateNum) IntSet
-> HashMap (StateNum, StateNum) IntSet
-> HashMap (StateNum, StateNum) IntSet
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
(<>) HashMap (StateNum, StateNum) IntSet
m1 HashMap (StateNum, StateNum) IntSet
m2

instance Monoid EdgeBuilder where
    mempty :: EdgeBuilder
mempty = HashMap (StateNum, StateNum) IntSet -> EdgeBuilder
EdgeBuilder HashMap (StateNum, StateNum) IntSet
forall k v. HashMap k v
HashMap.empty

edgeBuilder :: MState.StateNum -> Int -> MState.StateNum -> EdgeBuilder
edgeBuilder :: StateNum -> Int -> StateNum -> EdgeBuilder
edgeBuilder StateNum
sf Int
lb StateNum
st = HashMap (StateNum, StateNum) IntSet -> EdgeBuilder
EdgeBuilder do (StateNum, StateNum)
-> IntSet -> HashMap (StateNum, StateNum) IntSet
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (StateNum
sf, StateNum
st) do Int -> IntSet
IntSet.singleton Int
lb

outputDfaToDot :: DFA.DFA a -> Graphviz.Ast
outputDfaToDot :: DFA a -> Ast
outputDfaToDot DFA a
dfa = Ast :: [Node] -> [Edge] -> Ast
Graphviz.Ast
    { $sel:nodes:Ast :: [Node]
Graphviz.nodes = Node
initialNode Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:
        [ StateNum -> DFAState a -> Node
forall a a. Enum a => a -> DFAState a -> Node
node StateNum
sn DFAState a
dst
        | (StateNum
sn, DFAState a
dst) <- StateArray (DFAState a) -> [(StateNum, DFAState a)]
forall a. StateArray a -> [(StateNum, a)]
MState.arrayAssocs do DFA a -> StateArray (DFAState a)
forall a. DFA a -> StateArray (DFAState a)
DFA.dfaTrans DFA a
dfa
        ]
    , $sel:edges:Ast :: [Edge]
Graphviz.edges = [Edge]
initialEdges [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++
        ((StateNum, DFAState a) -> [Edge])
-> [(StateNum, DFAState a)] -> [Edge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            do \(StateNum
sn, DFAState a
dst) -> StateNum -> DFAState a -> [Edge]
forall a. StateNum -> DFAState a -> [Edge]
edges StateNum
sn DFAState a
dst
            do StateArray (DFAState a) -> [(StateNum, DFAState a)]
forall a. StateArray a -> [(StateNum, a)]
MState.arrayAssocs do DFA a -> StateArray (DFAState a)
forall a. DFA a -> StateArray (DFAState a)
DFA.dfaTrans DFA a
dfa
    }
    where
        initialNode :: Node
initialNode = Node :: NodeId -> Maybe NodeId -> Maybe NodeShape -> Node
Graphviz.Node
            { $sel:nodeId:Node :: NodeId
Graphviz.nodeId = NodeId
"init"
            , $sel:nodeLabel:Node :: Maybe NodeId
Graphviz.nodeLabel = Maybe NodeId
forall a. Maybe a
Nothing
            , $sel:nodeShape:Node :: Maybe NodeShape
Graphviz.nodeShape = Maybe NodeShape
forall a. Maybe a
Nothing
            }

        node :: a -> DFAState a -> Node
node a
sn DFAState a
dst = Node :: NodeId -> Maybe NodeId -> Maybe NodeShape -> Node
Graphviz.Node
            { $sel:nodeId:Node :: NodeId
Graphviz.nodeId = Int -> NodeId
forall a. Show a => a -> NodeId
show do a -> Int
forall a. Enum a => a -> Int
fromEnum a
sn
            , $sel:nodeLabel:Node :: Maybe NodeId
Graphviz.nodeLabel = Maybe NodeId
forall a. Maybe a
Nothing
            , $sel:nodeShape:Node :: Maybe NodeShape
Graphviz.nodeShape = case DFAState a -> [Accept a]
forall a. DFAState a -> [Accept a]
DFA.dstAccepts DFAState a
dst of
                [] -> Maybe NodeShape
forall a. Maybe a
Nothing
                [Accept a]
_  -> NodeShape -> Maybe NodeShape
forall a. a -> Maybe a
Just NodeShape
Graphviz.DoubleCircle
            }

        initialEdges :: [Edge]
initialEdges =
            [ Edge :: NodeId -> NodeId -> Maybe NodeId -> Edge
Graphviz.Edge
                { $sel:edgeFrom:Edge :: NodeId
Graphviz.edgeFrom = NodeId
"init"
                , $sel:edgeTo:Edge :: NodeId
Graphviz.edgeTo = Int -> NodeId
forall a. Show a => a -> NodeId
show do StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
sn
                , $sel:edgeLabel:Edge :: Maybe NodeId
Graphviz.edgeLabel = Maybe NodeId
forall a. Maybe a
Nothing
                }
            | (StartState
_, StateNum
sn) <- EnumMap StartState StateNum -> [(StartState, StateNum)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.assocs do DFA a -> EnumMap StartState StateNum
forall a. DFA a -> EnumMap StartState StateNum
DFA.dfaInitials DFA a
dfa
            ]

        edges :: StateNum -> DFAState a -> [Edge]
edges StateNum
sn DFAState a
dst =
            let builder :: EdgeBuilder
builder =
                    do case DFAState a -> Maybe StateNum
forall a. DFAState a -> Maybe StateNum
DFA.dstOtherTrans DFAState a
dst of
                        Maybe StateNum
Nothing -> EdgeBuilder
forall a. Monoid a => a
mempty
                        Just StateNum
ot -> StateNum -> Int -> StateNum -> EdgeBuilder
edgeBuilder StateNum
sn Int
-1 StateNum
ot
                    EdgeBuilder -> EdgeBuilder -> EdgeBuilder
forall a. Semigroup a => a -> a -> a
<> ((Int, StateNum) -> EdgeBuilder)
-> [(Int, StateNum)] -> EdgeBuilder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                        do \(Int
lb, StateNum
to) -> StateNum -> Int -> StateNum -> EdgeBuilder
edgeBuilder StateNum
sn Int
lb StateNum
to
                        do IntMap StateNum -> [(Int, StateNum)]
forall a. IntMap a -> [(Int, a)]
IntMap.assocs do DFAState a -> IntMap StateNum
forall a. DFAState a -> IntMap StateNum
DFA.dstTrans DFAState a
dst
            in
                [ StateNum -> IntSet -> StateNum -> Edge
edge StateNum
fr IntSet
lb StateNum
to
                | ((StateNum
fr, StateNum
to), IntSet
lb) <- HashMap (StateNum, StateNum) IntSet
-> [((StateNum, StateNum), IntSet)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList do EdgeBuilder -> HashMap (StateNum, StateNum) IntSet
unEdgeBuilder EdgeBuilder
builder
                ]

        edge :: MState.StateNum -> IntSet.IntSet -> MState.StateNum -> Graphviz.Edge
        edge :: StateNum -> IntSet -> StateNum -> Edge
edge StateNum
fr IntSet
lb StateNum
to = Edge :: NodeId -> NodeId -> Maybe NodeId -> Edge
Graphviz.Edge
            { $sel:edgeFrom:Edge :: NodeId
Graphviz.edgeFrom = Int -> NodeId
forall a. Show a => a -> NodeId
show do StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
fr
            , $sel:edgeTo:Edge :: NodeId
Graphviz.edgeTo = Int -> NodeId
forall a. Show a => a -> NodeId
show do StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
to
            , $sel:edgeLabel:Edge :: Maybe NodeId
Graphviz.edgeLabel = IntSet -> Maybe NodeId
edgeLabel IntSet
lb
            }

edgeLabel :: IntSet.IntSet -> Maybe Prelude.String
edgeLabel :: IntSet -> Maybe NodeId
edgeLabel IntSet
xs0 = case IntSet -> [Int]
IntSet.toAscList IntSet
xs0 of
    []    -> Maybe NodeId
forall a. Maybe a
Nothing
    Int
x0:[Int]
xs ->
        let endPrevRange :: (NodeId -> c, a, Bool) -> NodeId -> c
endPrevRange (NodeId -> c
s, a
p, Bool
b) = case Bool
b of
                Bool
True  -> NodeId -> c
s
                Bool
False -> NodeId -> c
s (NodeId -> c) -> (NodeId -> NodeId) -> NodeId -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId
"-" NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++) (NodeId -> NodeId) -> (NodeId -> NodeId) -> NodeId -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> NodeId
forall a. Show a => a -> NodeId
show a
p NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++)
            s0 :: NodeId -> NodeId
s0 = (NodeId -> NodeId, Int, Bool) -> NodeId -> NodeId
forall a c. Show a => (NodeId -> c, a, Bool) -> NodeId -> c
endPrevRange
                do ((NodeId -> NodeId, Int, Bool)
 -> Int -> (NodeId -> NodeId, Int, Bool))
-> (NodeId -> NodeId, Int, Bool)
-> [Int]
-> (NodeId -> NodeId, Int, Bool)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                    do \ctx :: (NodeId -> NodeId, Int, Bool)
ctx@(!NodeId -> NodeId
s, !Int
p, Bool
_) Int
x -> if
                        | Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> (NodeId -> NodeId
s, Int
x, Bool
False)
                        | Bool
otherwise  ->
                            ( (NodeId -> NodeId, Int, Bool) -> NodeId -> NodeId
forall a c. Show a => (NodeId -> c, a, Bool) -> NodeId -> c
endPrevRange (NodeId -> NodeId, Int, Bool)
ctx (NodeId -> NodeId) -> (NodeId -> NodeId) -> NodeId -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId
"," NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++) (NodeId -> NodeId) -> (NodeId -> NodeId) -> NodeId -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> NodeId
forall a. Show a => a -> NodeId
show Int
x NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++)
                            , Int
x
                            , Bool
True
                            )
                    do ((Int -> NodeId
forall a. Show a => a -> NodeId
show Int
x0 NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++), Int
x0, Bool
True)
                    do [Int]
xs
        in NodeId -> Maybe NodeId
forall a. a -> Maybe a
Just do NodeId
"[" NodeId -> NodeId -> NodeId
forall a. [a] -> [a] -> [a]
++ NodeId -> NodeId
s0 NodeId
"]"