{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Regex.Internal.Debug
( reToDot
, parserToDot
, dispCharRanges
) where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Identity
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.CPS
import qualified Data.Foldable as F
import Data.Maybe (isJust)
import Data.String
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))
import Regex.Internal.Parser (Node(..), Parser(..))
import Regex.Internal.Unique (Unique(..))
import qualified Regex.Internal.CharSet as CS
reToDot :: forall c a. Maybe ([c], [c] -> String) -> RE c a -> String
reToDot :: forall c a. Maybe ([c], [c] -> String) -> RE c a -> String
reToDot Maybe ([c], [c] -> String)
ma RE c a
re0 = M () -> String
forall a. M a -> String
execM (M () -> String) -> M () -> String
forall a b. (a -> b) -> a -> b
$ do
Str -> M ()
writeLn Str
"digraph RE {"
_ <- RE c a -> M Id
forall b. RE c b -> M Id
go RE c a
re0
writeLn "}"
where
go :: forall b. RE c b -> M Id
go :: forall b. RE c b -> M Id
go RE c b
re = case RE c b
re of
RToken c -> Maybe b
t -> Str -> M Id
new (Str -> M Id) -> Str -> M Id
forall a b. (a -> b) -> a -> b
$ String -> (c -> Maybe b) -> Maybe ([c], [c] -> String) -> Str
forall c a.
String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken String
"RToken" c -> Maybe b
t Maybe ([c], [c] -> String)
ma
RFmap Strictness
st a1 -> b
_ RE c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"RFmap" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
RE c a1 -> M Id
forall b. RE c b -> M Id
go RE c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RFmap_ b
_ RE c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"RFmap_" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
RE c a1 -> M Id
forall b. RE c b -> M Id
go RE c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RPure b
_ -> Str -> M Id
new Str
"RPure"
RLiftA2 Strictness
st a1 -> a2 -> b
_ RE c a1
re1 RE c a2
re2 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"RLiftA2" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
RE c a1 -> M Id
forall b. RE c b -> M Id
go RE c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RE c a2 -> M Id
forall b. RE c b -> M Id
go RE c a2
re2 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RE c b
REmpty -> Str -> M Id
new Str
"REmpty"
RAlt RE c b
re1 RE c b
re2 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"RAlt" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
RE c b -> M Id
forall b. RE c b -> M Id
go RE c b
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RE c b -> M Id
forall b. RE c b -> M Id
go RE c b
re2 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RFold Strictness
st Greediness
gr b -> a1 -> b
_ b
_ RE c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"RFold" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st Str -> Str -> Str
<+> Greediness -> Str
dispsGr Greediness
gr) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
RE c a1 -> M Id
forall b. RE c b -> M Id
go RE c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
RMany a1 -> b
_ a2 -> b
_ a2 -> a1 -> a2
_ a2
_ RE c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"RMany" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
RE c a1 -> M Id
forall b. RE c b -> M Id
go RE c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
parserToDot :: forall c a. Maybe ([c], [c] -> String) -> Parser c a -> String
parserToDot :: forall c a. Maybe ([c], [c] -> String) -> Parser c a -> String
parserToDot Maybe ([c], [c] -> String)
ma Parser c a
p0 = M () -> String
forall a. M a -> String
execM (M () -> String) -> M () -> String
forall a b. (a -> b) -> a -> b
$ do
Str -> M ()
writeLn Str
"digraph Parser {"
_ <- Parser c a -> M Id
forall b. Parser c b -> M Id
go Parser c a
p0
writeLn "}"
where
go :: forall b. Parser c b -> M Id
go :: forall b. Parser c b -> M Id
go Parser c b
p = case Parser c b
p of
PToken c -> Maybe b
t -> Str -> M Id
new (Str -> M Id) -> Str -> M Id
forall a b. (a -> b) -> a -> b
$ String -> (c -> Maybe b) -> Maybe ([c], [c] -> String) -> Str
forall c a.
String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken String
"PToken" c -> Maybe b
t Maybe ([c], [c] -> String)
ma
PFmap Strictness
st a1 -> b
_ Parser c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"PFmap" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
Parser c a1 -> M Id
forall b. Parser c b -> M Id
go Parser c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
PFmap_ Node c b
node ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"PFmap_" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
Str -> M ()
writeLn (Str -> M ()) -> Str -> M ()
forall a b. (a -> b) -> a -> b
$ Str
"subgraph cluster" Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Id -> Str
idStr Id
i Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Str
" {"
j <- StateT (IntMap Id) (StateT Int (Writer Str)) Id
-> IntMap Id -> M Id
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
node) IntMap Id
forall a. IntMap a
IM.empty
writeLn "}"
writeEdge i j
PPure b
_ -> Str -> M Id
new Str
"PPure"
PLiftA2 Strictness
st a1 -> a2 -> b
_ Parser c a1
re1 Parser c a2
re2 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"PLiftA2" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
Parser c a1 -> M Id
forall b. Parser c b -> M Id
go Parser c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
Parser c a2 -> M Id
forall b. Parser c b -> M Id
go Parser c a2
re2 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
Parser c b
PEmpty -> Str -> M Id
new Str
"PEmpty"
PAlt Unique
_ Parser c b
re1 Parser c b
re2 SmallArray (Parser c b)
res ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"PAlt" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
Parser c b -> M Id
forall b. Parser c b -> M Id
go Parser c b
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
Parser c b -> M Id
forall b. Parser c b -> M Id
go Parser c b
re2 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
(Parser c b -> M ()) -> SmallArray (Parser c b) -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (Parser c b -> M Id
forall b. Parser c b -> M Id
go (Parser c b -> M Id) -> (Id -> M ()) -> Parser c b -> M ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Id -> Id -> M ()
writeEdge Id
i) SmallArray (Parser c b)
res
PMany Unique
_ a1 -> b
_ a2 -> b
_ a2 -> a1 -> a2
_ a2
_ Parser c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew Str
"PMany" ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
Parser c a1 -> M Id
forall b. Parser c b -> M Id
go Parser c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
PFoldGr Unique
_ Strictness
st b -> a1 -> b
_ b
_ Parser c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"PFoldGr" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
Parser c a1 -> M Id
forall b. Parser c b -> M Id
go Parser c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
PFoldMn Unique
_ Strictness
st b -> a1 -> b
_ b
_ Parser c a1
re1 ->
Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (Str
"PFoldMn" Str -> Str -> Str
<+> Strictness -> Str
dispsSt Strictness
st) ((Id -> M ()) -> M Id) -> (Id -> M ()) -> M Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
Parser c a1 -> M Id
forall b. Parser c b -> M Id
go Parser c a1
re1 M Id -> (Id -> M ()) -> M ()
forall a b.
StateT Int (Writer Str) a
-> (a -> StateT Int (Writer Str) b) -> StateT Int (Writer Str) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Id -> Id -> M ()
writeEdge Id
i
goNode :: forall b. Node c b -> StateT (IntMap Id) M Id
goNode :: forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
n = case Node c b
n of
NAccept b
_ -> M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ Str -> M Id
new Str
"NAccept"
NGuard Unique
u Node c b
n1 -> do
v <- (IntMap Id -> Maybe Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) (Maybe Id)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((IntMap Id -> Maybe Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) (Maybe Id))
-> (IntMap Id -> Maybe Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Int -> IntMap Id -> Maybe Id
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Unique -> Int
unUnique Unique
u)
case v of
Just Id
i -> Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a. a -> StateT (IntMap Id) (StateT Int (Writer Str)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
Maybe Id
Nothing -> Str
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (StateT Int (Writer Str)))) =>
Str
-> (Id -> t (StateT Int (Writer Str)) a)
-> t (StateT Int (Writer Str)) Id
withNewT Str
"NGuard" ((Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
(IntMap Id -> IntMap Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((IntMap Id -> IntMap Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (IntMap Id -> IntMap Id)
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall a b. (a -> b) -> a -> b
$ Int -> Id -> IntMap Id -> IntMap Id
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Unique -> Int
unUnique Unique
u) Id
i
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
n1 StateT (IntMap Id) (StateT Int (Writer Str)) Id
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall a b.
StateT (IntMap Id) (StateT Int (Writer Str)) a
-> (a -> StateT (IntMap Id) (StateT Int (Writer Str)) b)
-> StateT (IntMap Id) (StateT Int (Writer Str)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (Id -> M ())
-> Id
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id -> M ()
writeEdge Id
i
NToken c -> Maybe a1
t Node c b
n1 ->
Str
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (StateT Int (Writer Str)))) =>
Str
-> (Id -> t (StateT Int (Writer Str)) a)
-> t (StateT Int (Writer Str)) Id
withNewT (String -> (c -> Maybe a1) -> Maybe ([c], [c] -> String) -> Str
forall c a.
String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken String
"NToken" c -> Maybe a1
t Maybe ([c], [c] -> String)
ma) ((Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ \Id
i ->
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
n1 StateT (IntMap Id) (StateT Int (Writer Str)) Id
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall a b.
StateT (IntMap Id) (StateT Int (Writer Str)) a
-> (a -> StateT (IntMap Id) (StateT Int (Writer Str)) b)
-> StateT (IntMap Id) (StateT Int (Writer Str)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (Id -> M ())
-> Id
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id -> M ()
writeEdge Id
i
Node c b
NEmpty -> M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> M Id -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ Str -> M Id
new Str
"NEmpty"
NAlt Node c b
n1 Node c b
n2 SmallArray (Node c b)
ns -> Str
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (StateT Int (Writer Str)))) =>
Str
-> (Id -> t (StateT Int (Writer Str)) a)
-> t (StateT Int (Writer Str)) Id
withNewT Str
"NAlt" ((Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> do
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
n1 StateT (IntMap Id) (StateT Int (Writer Str)) Id
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall a b.
StateT (IntMap Id) (StateT Int (Writer Str)) a
-> (a -> StateT (IntMap Id) (StateT Int (Writer Str)) b)
-> StateT (IntMap Id) (StateT Int (Writer Str)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (Id -> M ())
-> Id
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id -> M ()
writeEdge Id
i
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode Node c b
n2 StateT (IntMap Id) (StateT Int (Writer Str)) Id
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall a b.
StateT (IntMap Id) (StateT Int (Writer Str)) a
-> (a -> StateT (IntMap Id) (StateT Int (Writer Str)) b)
-> StateT (IntMap Id) (StateT Int (Writer Str)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (Id -> M ())
-> Id
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id -> M ()
writeEdge Id
i
(Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> SmallArray (Node c b)
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
forall b.
Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id
goNode (Node c b -> StateT (IntMap Id) (StateT Int (Writer Str)) Id)
-> (Id -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> Node c b
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (IntMap Id) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (IntMap Id) (StateT Int (Writer Str)) ())
-> (Id -> M ())
-> Id
-> StateT (IntMap Id) (StateT Int (Writer Str)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id -> M ()
writeEdge Id
i) SmallArray (Node c b)
ns
dispCharRanges :: [Char] -> String
dispCharRanges :: String -> String
dispCharRanges = [(Char, Char)] -> String
forall a. Show a => a -> String
show ([(Char, Char)] -> String)
-> (String -> [(Char, Char)]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet -> [(Char, Char)]
CS.ranges (CharSet -> [(Char, Char)])
-> (String -> CharSet) -> String -> [(Char, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CharSet
CS.fromList
newtype Str = Str { Str -> String -> String
runStr :: String -> String }
instance IsString Str where
fromString :: String -> Str
fromString = (String -> String) -> Str
Str ((String -> String) -> Str)
-> (String -> String -> String) -> String -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++)
instance Semigroup Str where
Str
s1 <> :: Str -> Str -> Str
<> Str
s2 = (String -> String) -> Str
Str (Str -> String -> String
runStr Str
s1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> String -> String
runStr Str
s2)
instance Monoid Str where
mempty :: Str
mempty = (String -> String) -> Str
Str String -> String
forall a. a -> a
id
dispsSt :: Strictness -> Str
dispsSt :: Strictness -> Str
dispsSt Strictness
st = case Strictness
st of
Strictness
Strict -> Str
"S"
Strictness
NonStrict -> Str
"NS"
dispsGr :: Greediness -> Str
dispsGr :: Greediness -> Str
dispsGr Greediness
gr = case Greediness
gr of
Greediness
Greedy -> Str
"G"
Greediness
Minimal -> Str
"M"
labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken :: forall c a.
String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken String
node c -> Maybe a
t = Str
-> (([c], [c] -> String) -> Str)
-> Maybe ([c], [c] -> String)
-> Str
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> Str
forall a. IsString a => String -> a
fromString String
node)
(\([c]
cs, [c] -> String
disp) ->
String -> Str
forall a. IsString a => String -> a
fromString String
node Str -> Str -> Str
<+>
(String -> Str
forall a. IsString a => String -> a
fromString (String -> Str) -> ([c] -> String) -> [c] -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escape (String -> String) -> ([c] -> String) -> [c] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c] -> String
disp) ((c -> Bool) -> [c] -> [c]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> (c -> Maybe a) -> c -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Maybe a
t) [c]
cs))
escape :: String -> String
escape :: String -> String
escape = String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall {a}. [a] -> [a]
tail' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show
where
tail' :: [a] -> [a]
tail' (a
_:[a]
xs) = [a]
xs
tail' [] = String -> [a]
forall a. HasCallStack => String -> a
error String
"tail'"
(<+>) :: Str -> Str -> Str
Str
s1 <+> :: Str -> Str -> Str
<+> Str
s2 = Str
s1 Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Str
" " Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Str
s2
infixr 6 <+>
declNode :: Id -> Str -> Str
declNode :: Id -> Str -> Str
declNode Id
i Str
label =
Id -> Str
idStr Id
i Str -> Str -> Str
<+>
Str
"[label=\"" Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<>
Str
label Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<>
Str
"\", ordering=\"out\"]"
type M = StateT Int (Writer Str)
execM :: M a -> String
execM :: forall a. M a -> String
execM = ((String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"") ((String -> String) -> String)
-> (M a -> String -> String) -> M a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> String -> String
runStr (Str -> String -> String)
-> (M a -> Str) -> M a -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer Str (a, Int) -> Str
forall w a. Monoid w => Writer w a -> w
execWriter (Writer Str (a, Int) -> Str)
-> (M a -> Writer Str (a, Int)) -> M a -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M a -> Int -> Writer Str (a, Int))
-> Int -> M a -> Writer Str (a, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip M a -> Int -> Writer Str (a, Int)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Int
1
newtype Id = Id { Id -> String
unId :: String }
idStr :: Id -> Str
idStr :: Id -> Str
idStr = String -> Str
forall a. IsString a => String -> a
fromString (String -> Str) -> (Id -> String) -> Id -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> String
unId
nxt :: M Id
nxt :: M Id
nxt = (Int -> (Id, Int)) -> M Id
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int -> (Id, Int)) -> M Id) -> (Int -> (Id, Int)) -> M Id
forall a b. (a -> b) -> a -> b
$ \Int
i -> let !i' :: Int
i' = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in (String -> Id
Id (Int -> String
forall a. Show a => a -> String
show Int
i), Int
i')
writeLn :: Str -> M ()
writeLn :: Str -> M ()
writeLn = Writer Str () -> M ()
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Writer Str () -> M ()) -> (Str -> Writer Str ()) -> Str -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Writer Str ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Str -> Writer Str ()) -> (Str -> Str) -> Str -> Writer Str ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Str
"\n")
writeEdge :: Id -> Id -> M ()
writeEdge :: Id -> Id -> M ()
writeEdge Id
fr Id
to = Str -> M ()
writeLn (Str -> M ()) -> Str -> M ()
forall a b. (a -> b) -> a -> b
$ Id -> Str
idStr Id
fr Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Str
" -> " Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<> Id -> Str
idStr Id
to
new :: Str -> M Id
new :: Str -> M Id
new Str
node = do
i <- M Id
nxt
writeLn $ declNode i node
pure i
withNew :: Str -> (Id -> M a) -> M Id
withNew :: forall a. Str -> (Id -> M a) -> M Id
withNew Str
node Id -> M a
f = IdentityT (StateT Int (Writer Str)) Id -> M Id
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (IdentityT (StateT Int (Writer Str)) Id -> M Id)
-> IdentityT (StateT Int (Writer Str)) Id -> M Id
forall a b. (a -> b) -> a -> b
$ Str
-> (Id -> IdentityT (StateT Int (Writer Str)) a)
-> IdentityT (StateT Int (Writer Str)) Id
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (StateT Int (Writer Str)))) =>
Str
-> (Id -> t (StateT Int (Writer Str)) a)
-> t (StateT Int (Writer Str)) Id
withNewT Str
node ((Id -> IdentityT (StateT Int (Writer Str)) a)
-> IdentityT (StateT Int (Writer Str)) Id)
-> (Id -> IdentityT (StateT Int (Writer Str)) a)
-> IdentityT (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ M a -> IdentityT (StateT Int (Writer Str)) a
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M a -> IdentityT (StateT Int (Writer Str)) a)
-> (Id -> M a) -> Id -> IdentityT (StateT Int (Writer Str)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> M a
f
withNewT :: (MonadTrans t, Monad (t M)) => Str -> (Id -> t M a) -> t M Id
withNewT :: forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (StateT Int (Writer Str)))) =>
Str
-> (Id -> t (StateT Int (Writer Str)) a)
-> t (StateT Int (Writer Str)) Id
withNewT Str
node Id -> t (StateT Int (Writer Str)) a
f = do
i <- M Id -> t (StateT Int (Writer Str)) Id
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M Id -> t (StateT Int (Writer Str)) Id)
-> M Id -> t (StateT Int (Writer Str)) Id
forall a b. (a -> b) -> a -> b
$ Str -> M Id
new Str
node
_ <- f i
pure i