{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module provides functions for visualizing @RE@s and @Parser@s.
-- [See here](https://github.com/meooow25/parser-regex/wiki/Visualizations)
-- for some examples.
--
module Regex.Internal.Debug
  ( reToDot
  , parserToDot
  , dispCharRanges
  ) where

import Control.Monad ((>=>))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Identity (IdentityT(..))
import Control.Monad.Trans.State.Strict
  (StateT(..), evalStateT, gets, modify', state)
import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell)
import qualified Data.Foldable as F
import Data.Maybe (isJust)
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

-------
-- RE
-------

-- | Generate a [Graphviz DOT](https://graphviz.org/doc/info/lang.html)
-- visualization of a 'RE'. Optionally takes an alphabet @[c]@, which will be
-- tested against the @token@ functions in the 'RE' and accepted characters
-- displayed.
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 (String -> Str
str String
"digraph RE {")
  Id
_ <- RE c a -> M Id
forall b. RE c b -> M Id
go RE c a
re0
  Str -> M ()
writeLn (String -> Str
str String
"}")
  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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"REmpty")
      RAlt RE c b
re1 RE c b
re2 ->
        Str -> (Id -> M ()) -> M Id
forall a. Str -> (Id -> M a) -> M Id
withNew (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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

-----------
-- Parser
-----------

-- | Generate a [Graphviz DOT](https://graphviz.org/doc/info/lang.html)
-- visualization of a 'Parser'. Optionally takes an alphabet @[c]@, which will
-- be tested against the @token@ functions in the 'Parser' and the accepted
-- characters displayed.
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 (String -> Str
str String
"digraph Parser {")
  Id
_ <- Parser c a -> M Id
forall b. Parser c b -> M Id
go Parser c a
p0
  Str -> M ()
writeLn (String -> Str
str String
"}")
  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 (String -> Str
str String
"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 (String -> Str
str String
"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
$ String -> Str
str String
"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
<> String -> Str
str String
" {"
          Id
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
          Str -> M ()
writeLn (String -> Str
str String
"}")
          Id -> Id -> M ()
writeEdge Id
i Id
j
      PPure b
_ -> Str -> M Id
new (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"NAccept")
      NGuard Unique
u Node c b
n1 -> do
        Maybe Id
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 Maybe Id
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 (String -> Str
str String
"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 (String -> Str
str String
"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 (String -> Str
str String
"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

------------------
-- Display Chars
------------------

-- |
-- >>> dispCharRanges "abc012def"
-- "[('0','2'),('a','f')]"
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

-----------------
-- Common stuff
-----------------

newtype Str = Str { Str -> String -> String
runStr :: String -> String }

str :: String -> Str
str :: String -> Str
str = (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 -> String -> Str
str String
"S"
  Strictness
NonStrict -> String -> Str
str String
"NS"

dispsGr :: Greediness -> Str
dispsGr :: Greediness -> Str
dispsGr Greediness
gr = case Greediness
gr of
  Greediness
Greedy -> String -> Str
str String
"G"
  Greediness
Minimal -> String -> Str
str String
"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
str String
node)
  (\([c]
cs, [c] -> String
disp) -> String -> Str
str String
node Str -> Str -> Str
<+> (String -> Str
str (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
<> String -> Str
str String
" " 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
<+>
  String -> Str
str String
"[label=\"" Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<>
  Str
label Str -> Str -> Str
forall a. Semigroup a => a -> a -> a
<>
  String -> Str
str String
"\", 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
str (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
<> String -> Str
str String
"\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
<> String -> Str
str String
" -> " 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
  Id
i <- M Id
nxt
  Str -> M ()
writeLn (Str -> M ()) -> Str -> M ()
forall a b. (a -> b) -> a -> b
$ Id -> Str -> Str
declNode Id
i Str
node
  Id -> M Id
forall a. a -> StateT Int (Writer Str) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
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
  Id
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
  a
_ <- Id -> t (StateT Int (Writer Str)) a
f Id
i
  Id -> t (StateT Int (Writer Str)) Id
forall a. a -> t (StateT Int (Writer Str)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i