{-# LANGUAGE CPP                 #-}
-- #define RERE_DEBUG

{-# LANGUAGE ScopedTypeVariables #-}

#ifdef RERE_DEBUG
#if __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy         #-}
#endif
#else
#if __GLASGOW_HASKELL__ >=710
{-# LANGUAGE Safe                #-}
#elif __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy         #-}
#endif
#endif

-- | Regular expression with explicit sharing.
--
-- 'RST' is an opaque type, to maintain the invariants.
module RERE.ST (
    RST,
    matchST,
    matchDebugST,
    ) where

#ifdef RERE_DEBUG
import Debug.Trace
#endif

import Control.Monad.Fix         (mfix)
import Control.Monad.Trans.State (State, evalState, get, modify, put, runState)
import Data.Void                 (Void, vacuous)
import Data.Word                 (Word64)

import qualified Data.Map as Map
import qualified Data.Set as Set

import           RERE.CharClasses
import qualified RERE.CharSet     as CS
import qualified RERE.Type        as R
import           RERE.Var

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$), (<$>), (<*>))
#endif

#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif

import Control.Monad.ST
import Data.STRef

-- Alt (Ch "b") (Alt (App (Alt (Star (Ch "c")) (Ch "c")) Full) (Ch "de"))
-- Alt Null (App Eps Full)

-------------------------------------------------------------------------------
-- Parameters
-------------------------------------------------------------------------------

matchIter :: Int
matchIter :: Int
matchIter = Int
20

nullableIter :: Int
nullableIter :: Int
nullableIter = Int
10

-------------------------------------------------------------------------------
-- Type
-------------------------------------------------------------------------------

-- | Knot-tied recursive regular expression.
data RST s = RST
    { RST s -> Def s
_rrDef        :: Def s
    , RST s -> Word64
_rrId         :: !Word64
    ,  RST s -> Char -> ST s (RST s)
rrDerivative :: !(Char -> ST s (RST s))
    ,  RST s -> ST s (RST s)
rrCompact    :: !(ST s (RST s))
    }

data Def s
    = Eps
    | Full
    | Ch CS.CharSet
    | App (RST s) (RST s)
    | Alt (RST s) (RST s)
#ifdef RERE_INTERSECTION
    | And (RST s) (RST s)
#endif
    | Star (RST s)

    | Del (RST s)

-------------------------------------------------------------------------------
-- Make
-------------------------------------------------------------------------------

data Ctx s = Ctx
    { Ctx s -> STRef s Word64
ctxId  :: STRef s Word64
    , Ctx s -> RST s
ctxNull :: RST s
    , Ctx s -> RST s
ctxFull :: RST s
    , Ctx s -> RST s
ctxEps  :: RST s
    }

newCtx :: ST s (Ctx s)
newCtx :: ST s (Ctx s)
newCtx = do
    STRef s Word64
i <- Word64 -> ST s (STRef s Word64)
forall a s. a -> ST s (STRef s a)
newSTRef Word64
3
    let n :: RST s
n = Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
forall s.
Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
RST (CharSet -> Def s
forall s. CharSet -> Def s
Ch CharSet
CS.empty) Word64
0 (\Char
_ -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
n) (RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
n)
    let f :: RST s
f = Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
forall s.
Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
RST Def s
forall s. Def s
Full          Word64
1 (\Char
_ -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
f) (RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
f)
        e :: RST s
e = Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
forall s.
Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
RST Def s
forall s. Def s
Eps           Word64
2 (\Char
_ -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
forall s. RST s
n) (RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
e)

    Ctx s -> ST s (Ctx s)
forall (m :: * -> *) a. Monad m => a -> m a
return (STRef s Word64 -> RST s -> RST s -> RST s -> Ctx s
forall s. STRef s Word64 -> RST s -> RST s -> RST s -> Ctx s
Ctx STRef s Word64
i RST s
forall s. RST s
n RST s
forall s. RST s
f RST s
forall s. RST s
e)

makeRST :: Ctx s -> Def s -> ST s (RST s)
makeRST :: Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx Def s
def = do
    Word64
i <- STRef s Word64 -> ST s Word64
forall s a. STRef s a -> ST s a
readSTRef (Ctx s -> STRef s Word64
forall s. Ctx s -> STRef s Word64
ctxId Ctx s
ctx)
    STRef s Word64 -> Word64 -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (Ctx s -> STRef s Word64
forall s. Ctx s -> STRef s Word64
ctxId Ctx s
ctx) (Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
    STRef s (Map Char (RST s))
dref <- Map Char (RST s) -> ST s (STRef s (Map Char (RST s)))
forall a s. a -> ST s (STRef s a)
newSTRef Map Char (RST s)
forall k a. Map k a
Map.empty
    STRef s (Maybe (RST s))
cref <- Maybe (RST s) -> ST s (STRef s (Maybe (RST s)))
forall a s. a -> ST s (STRef s a)
newSTRef Maybe (RST s)
forall a. Maybe a
Nothing

    let d :: Char -> ST s (RST s)
d Char
ch = do
            Map Char (RST s)
m <- STRef s (Map Char (RST s)) -> ST s (Map Char (RST s))
forall s a. STRef s a -> ST s a
readSTRef STRef s (Map Char (RST s))
dref
            case Char -> Map Char (RST s) -> Maybe (RST s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
ch Map Char (RST s)
m of
                Just RST s
x -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
x
                Maybe (RST s)
Nothing -> (RST s -> ST s (RST s)) -> ST s (RST s)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((RST s -> ST s (RST s)) -> ST s (RST s))
-> (RST s -> ST s (RST s)) -> ST s (RST s)
forall a b. (a -> b) -> a -> b
$ \RST s
deriv -> do
                    STRef s (Map Char (RST s)) -> Map Char (RST s) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Map Char (RST s))
dref (Char -> RST s -> Map Char (RST s) -> Map Char (RST s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Char
ch RST s
deriv Map Char (RST s)
m)
                    Ctx s -> Char -> Def s -> ST s (RST s)
forall s. Ctx s -> Char -> Def s -> ST s (RST s)
derivativeDef Ctx s
ctx Char
ch Def s
def

    let c :: ST s (RST s)
c = do
          Maybe (RST s)
mcompacted <- STRef s (Maybe (RST s)) -> ST s (Maybe (RST s))
forall s a. STRef s a -> ST s a
readSTRef STRef s (Maybe (RST s))
cref
          case Maybe (RST s)
mcompacted of
              Just RST s
compacted -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
compacted
              Maybe (RST s)
Nothing        -> (RST s -> ST s (RST s)) -> ST s (RST s)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((RST s -> ST s (RST s)) -> ST s (RST s))
-> (RST s -> ST s (RST s)) -> ST s (RST s)
forall a b. (a -> b) -> a -> b
$ \RST s
compacted -> do
                  STRef s (Maybe (RST s)) -> Maybe (RST s) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Maybe (RST s))
cref (RST s -> Maybe (RST s)
forall a. a -> Maybe a
Just RST s
compacted)
                  Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
compactDef Ctx s
ctx Def s
def

    RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
forall s.
Def s -> Word64 -> (Char -> ST s (RST s)) -> ST s (RST s) -> RST s
RST Def s
def Word64
i Char -> ST s (RST s)
d ST s (RST s)
c)

-------------------------------------------------------------------------------
-- Show
-------------------------------------------------------------------------------

instance Show (RST s) where
    showsPrec :: Int -> RST s -> ShowS
showsPrec = Set Word64 -> Int -> RST s -> ShowS
go Set Word64
forall a. Set a
Set.empty where
        go :: Set.Set Word64 -> Int -> RST s -> ShowS
        go :: Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
d (RST Def s
def Word64
i Char -> ST s (RST s)
_ ST s (RST s)
_) =
            if Word64 -> Set Word64 -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word64
i Set Word64
past
            then String -> ShowS
showString String
"<<loop " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
">>"
            else Set Word64 -> Int -> Word64 -> Def s -> ShowS
go' (Word64 -> Set Word64 -> Set Word64
forall a. Ord a => a -> Set a -> Set a
Set.insert Word64
i Set Word64
past) Int
d Word64
i Def s
def

        go' :: Set.Set Word64 -> Int -> Word64 -> Def s -> ShowS
        go' :: Set Word64 -> Int -> Word64 -> Def s -> ShowS
go' Set Word64
_    Int
_ Word64
_ Def s
Eps       = String -> ShowS
showString String
"Eps"
        go' Set Word64
_    Int
_ Word64
_ Def s
Full      = String -> ShowS
showString String
"Full"
        go' Set Word64
_    Int
d Word64
_ (Ch CharSet
c)    = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Ch " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CharSet -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 CharSet
c
        go' Set Word64
past Int
d Word64
i (App RST s
r RST s
s)
            = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"App"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
showSub Word64
i
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
r
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
s
        go' Set Word64
past Int
d Word64
i (Alt RST s
r RST s
s)
            = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Alt"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
showSub Word64
i
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
r
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
s
#ifdef RERE_INTERSECTION
        go' past d i (And r s)
            = showParen (d > 10)
            $ showString "And"
            . showSub i
            . showChar ' ' . go past 11 r
            . showChar ' ' . go past 11 s
#endif
        go' Set Word64
past Int
d Word64
i (Star RST s
r)
            = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Star"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
showSub Word64
i
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
r

        go' Set Word64
past Int
d Word64
i (Del RST s
r)
            = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Del"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
showSub Word64
i
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Word64 -> Int -> RST s -> ShowS
go Set Word64
past Int
11 RST s
r

        showSub :: a -> ShowS
showSub a
i = Char -> ShowS
showChar Char
'_' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
i

_size :: RST s -> Int
_size :: RST s -> Int
_size RST s
rr = State (Set Word64) Int -> Set Word64 -> Int
forall s a. State s a -> s -> a
evalState (RST s -> State (Set Word64) Int
forall (m :: * -> *) b s.
(Monad m, Num b, Enum b) =>
RST s -> StateT (Set Word64) m b
go RST s
rr) Set Word64
forall a. Set a
Set.empty where
    go :: RST s -> StateT (Set Word64) m b
go (RST Def s
def Word64
i Char -> ST s (RST s)
_ ST s (RST s)
_) = do
        Set Word64
visited <- StateT (Set Word64) m (Set Word64)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        if Word64 -> Set Word64 -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word64
i Set Word64
visited
        then b -> StateT (Set Word64) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
1
        else do
            Set Word64 -> StateT (Set Word64) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Word64 -> Set Word64 -> Set Word64
forall a. Ord a => a -> Set a -> Set a
Set.insert Word64
i Set Word64
visited)
            b -> b
forall a. Enum a => a -> a
succ (b -> b) -> StateT (Set Word64) m b -> StateT (Set Word64) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Def s -> StateT (Set Word64) m b
go' Def s
def

    go' :: Def s -> StateT (Set Word64) m b
go' Def s
Eps       = b -> StateT (Set Word64) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
0
    go' Def s
Full      = b -> StateT (Set Word64) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
0
    go' (Ch CharSet
_)    = b -> StateT (Set Word64) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
0
    go' (App RST s
r RST s
s) = b -> b -> b
forall a. (Enum a, Num a) => a -> a -> a
plus1 (b -> b -> b)
-> StateT (Set Word64) m b -> StateT (Set Word64) m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> StateT (Set Word64) m b
go RST s
r StateT (Set Word64) m (b -> b)
-> StateT (Set Word64) m b -> StateT (Set Word64) m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RST s -> StateT (Set Word64) m b
go RST s
s
    go' (Alt RST s
r RST s
s) = b -> b -> b
forall a. (Enum a, Num a) => a -> a -> a
plus1 (b -> b -> b)
-> StateT (Set Word64) m b -> StateT (Set Word64) m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> StateT (Set Word64) m b
go RST s
r StateT (Set Word64) m (b -> b)
-> StateT (Set Word64) m b -> StateT (Set Word64) m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RST s -> StateT (Set Word64) m b
go RST s
s
#ifdef RERE_INTERSECTION
    go' (And r s) = plus1 <$> go r <*> go s
#endif
    go' (Star RST s
r)  = b -> b
forall a. Enum a => a -> a
succ (b -> b) -> StateT (Set Word64) m b -> StateT (Set Word64) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> StateT (Set Word64) m b
go RST s
r
    go' (Del RST s
r)   = b -> b
forall a. Enum a => a -> a
succ (b -> b) -> StateT (Set Word64) m b -> StateT (Set Word64) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> StateT (Set Word64) m b
go RST s
r

    plus1 :: a -> a -> a
plus1 a
x a
y = a -> a
forall a. Enum a => a -> a
succ (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y)

-------------------------------------------------------------------------------
-- Conversion
-------------------------------------------------------------------------------

-- | Convert 'R.RE' to 'RST'.
fromRE :: forall s. Ctx s -> R.RE Void -> ST s (RST s)
fromRE :: Ctx s -> RE Void -> ST s (RST s)
fromRE Ctx s
ctx RE Void
re = RE (RST s) -> ST s (RST s)
go (RE Void -> RE (RST s)
forall (f :: * -> *) a. Functor f => f Void -> f a
vacuous RE Void
re) where
    go :: R.RE (RST s) -> ST s (RST s)

    go :: RE (RST s) -> ST s (RST s)
go RE (RST s)
R.Null   = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
    go RE (RST s)
R.Full   = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxFull Ctx s
ctx)
    go RE (RST s)
R.Eps    = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    go (R.Ch CharSet
c)
        | CharSet -> Bool
CS.null CharSet
c = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
        | Bool
otherwise = Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (CharSet -> Def s
forall s. CharSet -> Def s
Ch CharSet
c)

    go (R.App RE (RST s)
r RE (RST s)
s) = do
        RST s
r' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
r
        RST s
s' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
s
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
r' RST s
s')

    go (R.Alt RE (RST s)
r RE (RST s)
s) = do
        RST s
r' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
r
        RST s
s' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
s
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
Alt RST s
r' RST s
s')

#ifdef RERE_INTERSECTION
    go (R.And r s) = do
        r' <- go r
        s' <- go s
        makeRST ctx (And r' s')
#endif

    go (R.Star RE (RST s)
r) = do
        RST s
r' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
r
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Star RST s
r')

    go (R.Var RST s
r) = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
r

    go (R.Let Name
_ RE (RST s)
r RE (Var (RST s))
s) = do
        RST s
r' <- RE (RST s) -> ST s (RST s)
go RE (RST s)
r
        RE (RST s) -> ST s (RST s)
go ((Var (RST s) -> RST s) -> RE (Var (RST s)) -> RE (RST s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RST s -> (RST s -> RST s) -> Var (RST s) -> RST s
forall r a. r -> (a -> r) -> Var a -> r
unvar RST s
r' RST s -> RST s
forall a. a -> a
id) RE (Var (RST s))
s)

    go (R.Fix Name
_ RE (Var (RST s))
r) = (RST s -> ST s (RST s)) -> ST s (RST s)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((RST s -> ST s (RST s)) -> ST s (RST s))
-> (RST s -> ST s (RST s)) -> ST s (RST s)
forall a b. (a -> b) -> a -> b
$ \RST s
res -> do
        RE (RST s) -> ST s (RST s)
go ((Var (RST s) -> RST s) -> RE (Var (RST s)) -> RE (RST s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RST s -> (RST s -> RST s) -> Var (RST s) -> RST s
forall r a. r -> (a -> r) -> Var a -> r
unvar RST s
res RST s -> RST s
forall a. a -> a
id) RE (Var (RST s))
r)

-------------------------------------------------------------------------------
-- Match
-------------------------------------------------------------------------------

-- | Convert 'R.RE' to 'RST' and then match.
--
-- Significantly faster than 'RERE.Type.match'.
matchST :: R.RE Void -> String -> Bool
matchST :: RE Void -> String -> Bool
matchST RE Void
re String
str = (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST forall s. ST s Bool
go0
  where
    go0 :: ST s Bool
    go0 :: ST s Bool
go0 = do
        Ctx s
ctx <- ST s (Ctx s)
forall s. ST s (Ctx s)
newCtx
        RST s
rr <- Ctx s -> RE Void -> ST s (RST s)
forall s. Ctx s -> RE Void -> ST s (RST s)
fromRE Ctx s
ctx RE Void
re
        let cc :: CharClasses
cc = RE Void -> CharClasses
forall a. RE a -> CharClasses
charClasses RE Void
re
        Ctx s -> CharClasses -> String -> RST s -> ST s Bool
forall s. Ctx s -> CharClasses -> String -> RST s -> ST s Bool
go Ctx s
ctx CharClasses
cc String
str RST s
rr

    go :: Ctx s -> CharClasses -> String -> RST s -> ST s Bool
    go :: Ctx s -> CharClasses -> String -> RST s -> ST s Bool
go Ctx s
ctx CharClasses
_  []     RST s
rr = Ctx s -> RST s -> ST s Bool
forall s. Ctx s -> RST s -> ST s Bool
nullableR' Ctx s
ctx RST s
rr
    go Ctx s
ctx CharClasses
cc (Char
c:String
cs) RST s
rr = do
        let c' :: Char
c' = CharClasses -> Char -> Char
classOfChar CharClasses
cc Char
c
        RST s
rr' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c' RST s
rr
        RST s
rr'' <- Int -> RST s -> ST s (RST s)
forall s. Int -> RST s -> ST s (RST s)
compactRN Int
matchIter RST s
rr'
#ifdef RERE_DEBUG
        let size1 = _size rr'
            size2 = _size rr''
        traceM ("size: " ++ show size1 ++ " ~> " ++ show size2)
        if size1 < size2
        then traceM (show rr')
        else pure ()
#endif
        Ctx s -> CharClasses -> String -> RST s -> ST s Bool
forall s. Ctx s -> CharClasses -> String -> RST s -> ST s Bool
go Ctx s
ctx CharClasses
cc String
cs RST s
rr''

-- | Match and print final 'RR' + stats.
matchDebugST :: R.RE Void -> String -> IO ()
matchDebugST :: RE Void -> String -> IO ()
matchDebugST RE Void
re String
str = (forall s. ST s (IO ())) -> IO ()
forall a. (forall s. ST s a) -> a
runST forall s. ST s (IO ())
go0 where
    go0 :: ST s (IO ())
    go0 :: ST s (IO ())
go0 = do
        Ctx s
ctx <- ST s (Ctx s)
forall s. ST s (Ctx s)
newCtx
        RST s
rr <- Ctx s -> RE Void -> ST s (RST s)
forall s. Ctx s -> RE Void -> ST s (RST s)
fromRE Ctx s
ctx RE Void
re
        Ctx s -> String -> RST s -> ST s (IO ())
forall s. Ctx s -> String -> RST s -> ST s (IO ())
go Ctx s
ctx String
str RST s
rr

    go :: Ctx s -> String -> RST s -> ST s (IO ())
    go :: Ctx s -> String -> RST s -> ST s (IO ())
go Ctx s
ctx [] RST s
rr = do
        Bool
n <- Ctx s -> RST s -> ST s Bool
forall s. Ctx s -> RST s -> ST s Bool
nullableR' Ctx s
ctx RST s
rr

        -- rn <- makeRST ctx (Del rr)
        -- (rn', trace) <- compactRTrace nullableIter rn

        IO () -> ST s (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> ST s (IO ())) -> IO () -> ST s (IO ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [ String
"size: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RST s -> Int
forall s. RST s -> Int
_size RST s
rr)
            , String
"show: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RST s -> String
forall a. Show a => a -> String
show RST s
rr
            , String
"null: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
n
            ]
            {-
            , "nul2: " ++ show (nullableR rr)
            , "dels: " ++ show rn'
            ] ++
            [ "    - " ++ show t
            | t <- trace
            ]
            -}

    go Ctx s
ctx (Char
c:String
cs) RST s
rr = do
        RST s
rr' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
rr
        RST s
rr'' <- Int -> RST s -> ST s (RST s)
forall s. Int -> RST s -> ST s (RST s)
compactRN Int
matchIter RST s
rr'
        Ctx s -> String -> RST s -> ST s (IO ())
forall s. Ctx s -> String -> RST s -> ST s (IO ())
go Ctx s
ctx String
cs RST s
rr''


-------------------------------------------------------------------------------
-- Compact
-------------------------------------------------------------------------------

compactR :: RST s -> ST s (RST s)
compactR :: RST s -> ST s (RST s)
compactR = RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
rrCompact

compactDef :: Ctx s -> Def s -> ST s (RST s)
compactDef :: Ctx s -> Def s -> ST s (RST s)
compactDef Ctx s
ctx Def s
r0 = case Def s
r0 of
    Def s
Eps  -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Def s
Full -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxFull Ctx s
ctx)
    Ch CharSet
cs | CharSet -> Bool
CS.null CharSet
cs -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
          | Bool
otherwise  -> Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx Def s
r0

    Alt (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) (RST (Ch CharSet
y) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (CharSet -> Def s
forall s. CharSet -> Def s
Ch (CharSet -> CharSet -> CharSet
CS.union CharSet
x CharSet
y))
    Alt (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) RST s
s | CharSet -> Bool
CS.null CharSet
x ->
        RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
s
    Alt RST s
r (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) | CharSet -> Bool
CS.null CharSet
x ->
        RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
    Alt (RST Def s
Full Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) RST s
_ ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxFull Ctx s
ctx)
    Alt RST s
_ (RST Def s
Full Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxFull Ctx s
ctx)
    Alt (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Alt RST s
r RST s
s -> do
        RST s
r' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
        RST s
s' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
s
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
Alt RST s
r' RST s
s')

    App (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) RST s
s ->
        RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
s
    App RST s
r (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
    App (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) RST s
_ | CharSet -> Bool
CS.null CharSet
x ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
    App RST s
_ (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) | CharSet -> Bool
CS.null CharSet
x ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
    App RST s
r RST s
s -> do
        RST s
r' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
        RST s
s' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
s
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
r' RST s
s')

#ifdef RERE_INTERSECTION
    And r s -> do
        r' <- compactR r
        s' <- compactR s
        makeRST ctx (And r' s')
#endif

    Star (RST (Ch CharSet
x) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) | CharSet -> Bool
CS.null CharSet
x ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Star (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Star r :: RST s
r@(RST Star {} Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) ->
        RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
    Star RST s
r -> do
        RST s
r' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
r
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Star RST s
r')

    Del (RST Def s
Full Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_ )      -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Del (RST (Star RST s
_) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_ )  -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Del (RST Def s
Eps Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_ )       -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    Del (RST (Ch CharSet
_) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_)     -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
    Del r :: RST s
r@(RST (Del RST s
_) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_ ) -> RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
r

    Del (RST (App RST s
r RST s
s) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) -> do
        RST s
r' <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
r)
        RST s
s' <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
s)
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
r' RST s
s')
    Del (RST (Alt RST s
r RST s
s) Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) -> do
        RST s
r' <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
r)
        RST s
s' <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
s)
        Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
Alt RST s
r' RST s
s')
#ifdef RERE_INTERSECTION
    Del (RST (And r s) _ _ _) -> do
        r' <- makeRST ctx (Del r)
        s' <- makeRST ctx (Del s)
        makeRST ctx (And r' s')
#endif

compactRN :: Int ->  RST s -> ST s (RST s)
compactRN :: Int -> RST s -> ST s (RST s)
compactRN Int
n RST s
rr | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return RST s
rr
               | Bool
otherwise = RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
rr ST s (RST s) -> (RST s -> ST s (RST s)) -> ST s (RST s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> RST s -> ST s (RST s)
forall s. Int -> RST s -> ST s (RST s)
compactRN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

_compactRTrace :: Int -> RST s -> ST s (RST s, [RST s])
_compactRTrace :: Int -> RST s -> ST s (RST s, [RST s])
_compactRTrace Int
n RST s
rr
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = (RST s, [RST s]) -> ST s (RST s, [RST s])
forall (m :: * -> *) a. Monad m => a -> m a
return (RST s
rr, [])
    | Bool
otherwise = do
        RST s
rr' <- RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
rr
        (RST s
rr'', [RST s]
tr) <- Int -> RST s -> ST s (RST s, [RST s])
forall s. Int -> RST s -> ST s (RST s, [RST s])
_compactRTrace (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) RST s
rr'
        (RST s, [RST s]) -> ST s (RST s, [RST s])
forall (m :: * -> *) a. Monad m => a -> m a
return (RST s
rr'', RST s
rr RST s -> [RST s] -> [RST s]
forall a. a -> [a] -> [a]
: [RST s]
tr)

-------------------------------------------------------------------------------
-- Derivative
-------------------------------------------------------------------------------

derivativeR :: Char -> RST s -> ST s (RST s)
derivativeR :: Char -> RST s -> ST s (RST s)
derivativeR = (RST s -> Char -> ST s (RST s)) -> Char -> RST s -> ST s (RST s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip RST s -> Char -> ST s (RST s)
forall s. RST s -> Char -> ST s (RST s)
rrDerivative

derivativeDef :: Ctx s -> Char -> Def s -> ST s (RST s)
derivativeDef :: Ctx s -> Char -> Def s -> ST s (RST s)
derivativeDef Ctx s
ctx Char
_ Def s
Eps =
    RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
derivativeDef Ctx s
ctx Char
_ Def s
Full =
    RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxFull Ctx s
ctx)
derivativeDef Ctx s
ctx Char
_ (Del RST s
_) = do
    RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
derivativeDef Ctx s
ctx Char
c (Ch CharSet
x)
    | Char -> CharSet -> Bool
CS.member Char
c CharSet
x = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxEps Ctx s
ctx)
    | Bool
otherwise     = RST s -> ST s (RST s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx s -> RST s
forall s. Ctx s -> RST s
ctxNull Ctx s
ctx)
derivativeDef Ctx s
ctx Char
c (Alt RST s
r RST s
s) = do
    RST s
r' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
r
    RST s
s' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
s
    Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
Alt RST s
r' RST s
s')
#ifdef RERE_INTERSECTION
derivativeDef ctx c (And r s) = do
    r' <- derivativeR c r
    s' <- derivativeR c s
    makeRST ctx (And r' s')
#endif
derivativeDef Ctx s
ctx Char
c (Star RST s
r) = do
    RST s
r' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
r
    RST s
starR <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Star RST s
r)
    Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
r' RST s
starR)
derivativeDef Ctx s
ctx Char
c (App RST s
r RST s
s) = do
    RST s
r' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
r
    RST s
s' <- Char -> RST s -> ST s (RST s)
forall s. Char -> RST s -> ST s (RST s)
derivativeR Char
c RST s
s

    RST s
dr <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
r)

    RST s
lft <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
dr RST s
s')
    RST s
rgt <- Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
App RST s
r' RST s
s)

    Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> RST s -> Def s
forall s. RST s -> RST s -> Def s
Alt RST s
lft RST s
rgt)

-------------------------------------------------------------------------------
-- Nullable equations
-------------------------------------------------------------------------------

-- | Whether 'RST' is nullable.
--
-- @
-- 'R.nullable' re = 'nullableR' ('fromRE' re)
-- @
nullableR :: RST s -> Bool
nullableR :: RST s -> Bool
nullableR RST s
r =
    let (BoolExpr
bexpr, Map Word64 BoolExpr
eqs) = RST s -> (BoolExpr, Map Word64 BoolExpr)
forall s. RST s -> (BoolExpr, Map Word64 BoolExpr)
equations RST s
r
    in BoolExpr -> Map Word64 BoolExpr -> Bool
lfp BoolExpr
bexpr Map Word64 BoolExpr
eqs

nullableR' :: Ctx s -> RST s -> ST s Bool
nullableR' :: Ctx s -> RST s -> ST s Bool
nullableR' Ctx s
ctx RST s
rr = Ctx s -> Def s -> ST s (RST s)
forall s. Ctx s -> Def s -> ST s (RST s)
makeRST Ctx s
ctx (RST s -> Def s
forall s. RST s -> Def s
Del RST s
rr) ST s (RST s) -> (RST s -> ST s Bool) -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> RST s -> ST s Bool
forall t s. (Ord t, Num t) => t -> RST s -> ST s Bool
go Int
nullableIter where
    go :: t -> RST s -> ST s Bool
go t
_ (RST Def s
Eps     Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) = Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go t
_ (RST (Ch CharSet
_)  Word64
_ Char -> ST s (RST s)
_ ST s (RST s)
_) = Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    go t
n RST s
rr' | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (RST s -> Bool
forall s. RST s -> Bool
nullableR RST s
rr')
             | Bool
otherwise = RST s -> ST s (RST s)
forall s. RST s -> ST s (RST s)
compactR RST s
rr' ST s (RST s) -> (RST s -> ST s Bool) -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> RST s -> ST s Bool
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

equations :: RST s -> (BoolExpr, Map.Map Word64 BoolExpr)
equations :: RST s -> (BoolExpr, Map Word64 BoolExpr)
equations RST s
r =
    let (BoolExpr
bexpr, Map Word64 (Def s)
next) = State (Map Word64 (Def s)) BoolExpr
-> Map Word64 (Def s) -> (BoolExpr, Map Word64 (Def s))
forall s a. State s a -> s -> (a, s)
runState (RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
r) Map Word64 (Def s)
forall k a. Map k a
Map.empty
    in (BoolExpr
bexpr, Map Word64 (Def s) -> Map Word64 BoolExpr
forall s. Map Word64 (Def s) -> Map Word64 BoolExpr
collectEquations Map Word64 (Def s)
next)

collectEquations :: Map.Map Word64 (Def s)-> Map.Map Word64 BoolExpr
collectEquations :: Map Word64 (Def s) -> Map Word64 BoolExpr
collectEquations = Map Word64 BoolExpr -> Map Word64 (Def s) -> Map Word64 BoolExpr
forall s.
Map Word64 BoolExpr -> Map Word64 (Def s) -> Map Word64 BoolExpr
go Map Word64 BoolExpr
forall k a. Map k a
Map.empty where
    go :: Map Word64 BoolExpr -> Map Word64 (Def s) -> Map Word64 BoolExpr
go Map Word64 BoolExpr
acc Map Word64 (Def s)
queue = case Map Word64 (Def s) -> Maybe ((Word64, Def s), Map Word64 (Def s))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey Map Word64 (Def s)
queue of
        Maybe ((Word64, Def s), Map Word64 (Def s))
Nothing               -> Map Word64 BoolExpr
acc
        Just ((Word64
i, Def s
r), Map Word64 (Def s)
queue')
            | Word64 -> Map Word64 BoolExpr -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Word64
i Map Word64 BoolExpr
acc -> Map Word64 BoolExpr -> Map Word64 (Def s) -> Map Word64 BoolExpr
go Map Word64 BoolExpr
acc Map Word64 (Def s)
queue'
            | Bool
otherwise        ->
                let (BoolExpr
bexpr, Map Word64 (Def s)
next) = State (Map Word64 (Def s)) BoolExpr
-> Map Word64 (Def s) -> (BoolExpr, Map Word64 (Def s))
forall s a. State s a -> s -> (a, s)
runState (Def s -> State (Map Word64 (Def s)) BoolExpr
forall s. Def s -> State (Map Word64 (Def s)) BoolExpr
collectEquation' Def s
r) Map Word64 (Def s)
forall k a. Map k a
Map.empty
                in Map Word64 BoolExpr -> Map Word64 (Def s) -> Map Word64 BoolExpr
go (Word64 -> BoolExpr -> Map Word64 BoolExpr -> Map Word64 BoolExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word64
i BoolExpr
bexpr Map Word64 BoolExpr
acc) (Map Word64 (Def s)
queue' Map Word64 (Def s) -> Map Word64 (Def s) -> Map Word64 (Def s)
forall a. Semigroup a => a -> a -> a
<> Map Word64 (Def s)
next)

collectEquation :: RST s -> State (Map.Map Word64 (Def s)) BoolExpr
collectEquation :: RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation (RST Def s
def Word64
i Char -> ST s (RST s)
_ ST s (RST s)
_) = do
    (Map Word64 (Def s) -> Map Word64 (Def s))
-> StateT (Map Word64 (Def s)) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Word64 -> Def s -> Map Word64 (Def s) -> Map Word64 (Def s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word64
i Def s
def)
    BoolExpr -> State (Map Word64 (Def s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> BoolExpr
BVar Word64
i)

collectEquation' :: Def s -> State (Map.Map Word64 (Def s)) BoolExpr
collectEquation' :: Def s -> State (Map Word64 (Def s)) BoolExpr
collectEquation' Def s
Eps       = BoolExpr -> State (Map Word64 (Def s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
collectEquation' Def s
Full      = BoolExpr -> State (Map Word64 (Def s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
collectEquation' (Ch CharSet
_)    = BoolExpr -> State (Map Word64 (Def s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BFalse
collectEquation' (Del RST s
r)   = RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
r
collectEquation' (App RST s
r RST s
s) = BoolExpr -> BoolExpr -> BoolExpr
band (BoolExpr -> BoolExpr -> BoolExpr)
-> State (Map Word64 (Def s)) BoolExpr
-> StateT (Map Word64 (Def s)) Identity (BoolExpr -> BoolExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
r StateT (Map Word64 (Def s)) Identity (BoolExpr -> BoolExpr)
-> State (Map Word64 (Def s)) BoolExpr
-> State (Map Word64 (Def s)) BoolExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
s
collectEquation' (Alt RST s
r RST s
s) = BoolExpr -> BoolExpr -> BoolExpr
bor (BoolExpr -> BoolExpr -> BoolExpr)
-> State (Map Word64 (Def s)) BoolExpr
-> StateT (Map Word64 (Def s)) Identity (BoolExpr -> BoolExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
r StateT (Map Word64 (Def s)) Identity (BoolExpr -> BoolExpr)
-> State (Map Word64 (Def s)) BoolExpr
-> State (Map Word64 (Def s)) BoolExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RST s -> State (Map Word64 (Def s)) BoolExpr
forall s. RST s -> State (Map Word64 (Def s)) BoolExpr
collectEquation RST s
s
collectEquation' (Star RST s
_)  = BoolExpr -> State (Map Word64 (Def s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
#ifdef RERE_INTERSECTION
collectEquation' (And r s) = band <$> collectEquation r <*> collectEquation s
#endif

lfp :: BoolExpr -> Map.Map Word64 BoolExpr -> Bool
lfp :: BoolExpr -> Map Word64 BoolExpr -> Bool
lfp BoolExpr
b Map Word64 BoolExpr
exprs = Map Word64 Bool -> Bool
go (Bool
False Bool -> Map Word64 BoolExpr -> Map Word64 Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map Word64 BoolExpr
exprs) where
    go :: Map Word64 Bool -> Bool
go Map Word64 Bool
curr
        | Map Word64 Bool
curr Map Word64 Bool -> Map Word64 Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Map Word64 Bool
next = BoolExpr -> Bool
evaluate BoolExpr
b
        | Bool
otherwise    = Map Word64 Bool -> Bool
go Map Word64 Bool
next
      where
        next :: Map Word64 Bool
next = (BoolExpr -> Bool) -> Map Word64 BoolExpr -> Map Word64 Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoolExpr -> Bool
evaluate Map Word64 BoolExpr
exprs

        evaluate :: BoolExpr -> Bool
        evaluate :: BoolExpr -> Bool
evaluate BoolExpr
BTrue      = Bool
True
        evaluate BoolExpr
BFalse     = Bool
False
        evaluate (BOr BoolExpr
x BoolExpr
y)  = BoolExpr -> Bool
evaluate BoolExpr
x Bool -> Bool -> Bool
|| BoolExpr -> Bool
evaluate BoolExpr
y
        evaluate (BAnd BoolExpr
x BoolExpr
y) = BoolExpr -> Bool
evaluate BoolExpr
x Bool -> Bool -> Bool
&& BoolExpr -> Bool
evaluate BoolExpr
y
        evaluate (BVar Word64
i)   = Bool -> Word64 -> Map Word64 Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False Word64
i Map Word64 Bool
curr

-------------------------------------------------------------------------------
-- BoolExpr
-------------------------------------------------------------------------------

data BoolExpr
    = BVar Word64
    | BTrue
    | BFalse
    | BOr BoolExpr BoolExpr
    | BAnd BoolExpr BoolExpr
  deriving (Int -> BoolExpr -> ShowS
[BoolExpr] -> ShowS
BoolExpr -> String
(Int -> BoolExpr -> ShowS)
-> (BoolExpr -> String) -> ([BoolExpr] -> ShowS) -> Show BoolExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoolExpr] -> ShowS
$cshowList :: [BoolExpr] -> ShowS
show :: BoolExpr -> String
$cshow :: BoolExpr -> String
showsPrec :: Int -> BoolExpr -> ShowS
$cshowsPrec :: Int -> BoolExpr -> ShowS
Show)

band :: BoolExpr -> BoolExpr -> BoolExpr
band :: BoolExpr -> BoolExpr -> BoolExpr
band BoolExpr
BFalse BoolExpr
_      = BoolExpr
BFalse
band BoolExpr
_      BoolExpr
BFalse = BoolExpr
BFalse
band BoolExpr
BTrue  BoolExpr
r      = BoolExpr
r
band BoolExpr
r      BoolExpr
BTrue  = BoolExpr
r
band BoolExpr
r      BoolExpr
s      = BoolExpr -> BoolExpr -> BoolExpr
BAnd BoolExpr
r BoolExpr
s

bor :: BoolExpr -> BoolExpr -> BoolExpr
bor :: BoolExpr -> BoolExpr -> BoolExpr
bor BoolExpr
BFalse BoolExpr
r      = BoolExpr
r
bor BoolExpr
r      BoolExpr
BFalse = BoolExpr
r
bor BoolExpr
BTrue  BoolExpr
_      = BoolExpr
BTrue
bor BoolExpr
_      BoolExpr
BTrue  = BoolExpr
BTrue
bor BoolExpr
r      BoolExpr
s      = BoolExpr -> BoolExpr -> BoolExpr
BOr BoolExpr
r BoolExpr
s