{-# LANGUAGE CPP         #-}
#if __GLASGOW_HASKELL__ >=710
{-# LANGUAGE Safe        #-}
#elif __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy #-}
#endif
-- | Regular expression with explicit sharing.
--
-- 'RR' is an opaque type, to maintain the invariants.
module RERE.Ref (
    RR,
    matchR, matchDebugR,
    ) where

import Control.Monad.Fix         (mfix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
       (State, StateT, evalState, evalStateT, get, modify, put, runState)
import Data.Void                 (Void, vacuous)

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

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

-- | Knot-tied recursive regular expression.
data RR s
    = Eps
    | Ch CS.CharSet
    | App (RR s) (RR s)
    | Alt (RR s) (RR s)
#ifdef RERE_INTERSECTION
    | And (RR s) (RR s)
#endif
    | Star (RR s)
    | Ref !Int !(STRef s (Map.Map Char (RR s))) (RR s)

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

        go Set Int
past Int
d (Ref Int
i STRef s (Map Char (RR s))
_ RR s
r)
            | forall a. Ord a => a -> Set a -> Bool
Set.member Int
i Set Int
past = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10)
            forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Ref " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" <<loop>>"
            | Bool
otherwise         = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10)
            forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Ref " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Set Int -> Int -> RR s -> ShowS
go (forall a. Ord a => a -> Set a -> Set a
Set.insert Int
i Set Int
past) Int
11 RR s
r

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

-- | Convert 'R.RE' to 'RR'.
fromRE :: R.RE Void -> M s (RR s)
fromRE :: forall s. RE Void -> M s (RR s)
fromRE RE Void
re = forall {s}. RE (RR s) -> StateT Int (ST s) (RR s)
go (forall (f :: * -> *) a. Functor f => f Void -> f a
vacuous RE Void
re) where
    go :: RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
R.Null   = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
nullRR
    go RE (RR s)
R.Full   = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
fullRR
    go RE (RR s)
R.Eps    = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
Eps
    go (R.Ch CharSet
c) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. CharSet -> RR s
Ch CharSet
c)

    go (R.App RE (RR s)
r RE (RR s)
s) = do
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
r
        RR s
s' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. RR s -> RR s -> RR s
app_ RR s
r' RR s
s')

    go (R.Alt RE (RR s)
r RE (RR s)
s) = do
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
r
        RR s
s' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. RR s -> RR s -> RR s
alt_ RR s
r' RR s
s')

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

    go (R.Star RE (RR s)
r) = do
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
r
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. RR s -> RR s
star_ RR s
r')

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

    go (R.Let Name
_ RE (RR s)
r RE (Var (RR s))
s) = do
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go RE (RR s)
r
        -- it looks like we shouldn't memoize here
        -- both simple and json benchmark are noticeably faster.
        RE (RR s) -> StateT Int (ST s) (RR s)
go (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall r a. r -> (a -> r) -> Var a -> r
unvar RR s
r' forall a. a -> a
id) RE (Var (RR s))
s)

    go (R.Fix Name
_ RE (Var (RR s))
r) = forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \RR s
res -> do
        Int
i <- forall s. M s Int
newId
        STRef s (Map Char (RR s))
ref <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a s. a -> ST s (STRef s a)
newSTRef forall k a. Map k a
Map.empty)
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall r a. r -> (a -> r) -> Var a -> r
unvar RR s
res forall a. a -> a
id) RE (Var (RR s))
r)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. Int -> STRef s (Map Char (RR s)) -> RR s -> RR s
Ref Int
i STRef s (Map Char (RR s))
ref RR s
r')

_size :: RR s -> Int
_size :: forall s. RR s -> Int
_size RR s
rr = forall s a. State s a -> s -> a
evalState (forall {m :: * -> *} {a} {s}.
(Monad m, Num a, Enum a) =>
RR s -> StateT (Set Int) m a
go RR s
rr) forall a. Set a
Set.empty where
    go :: RR s -> StateT (Set Int) m a
go RR s
Eps       = forall (m :: * -> *) a. Monad m => a -> m a
return a
1
    go (Ch CharSet
_)    = forall (m :: * -> *) a. Monad m => a -> m a
return a
1
    go (App RR s
r RR s
s) = forall {a}. (Enum a, Num a) => a -> a -> a
plus1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m a
go RR s
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> StateT (Set Int) m a
go RR s
s
    go (Alt RR s
r RR s
s) = forall {a}. (Enum a, Num a) => a -> a -> a
plus1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m a
go RR s
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> StateT (Set Int) m a
go RR s
s
#ifdef RERE_INTERSECTION
    go (And r s) = plus1 <$> go r <*> go s
#endif
    go (Star RR s
r)  = forall a. Enum a => a -> a
succ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m a
go RR s
r
    go (Ref Int
i STRef s (Map Char (RR s))
_ RR s
r) = do
        Set Int
visited <- forall (m :: * -> *) s. Monad m => StateT s m s
get
        if forall a. Ord a => a -> Set a -> Bool
Set.member Int
i Set Int
visited
        then forall (m :: * -> *) a. Monad m => a -> m a
return a
1
        else do
            forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (forall a. Ord a => a -> Set a -> Set a
Set.insert Int
i Set Int
visited)
            forall a. Enum a => a -> a
succ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m a
go RR s
r

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

-------------------------------------------------------------------------------
-- Variable supply monad
-------------------------------------------------------------------------------

type M s = StateT Int (ST s)

newId :: M s Int
newId :: forall s. M s Int
newId = do
    Int
i <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$! Int
i forall a. Num a => a -> a -> a
+ Int
1
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

_returnI :: RR s -> M s (RR s)
_returnI :: forall s. RR s -> M s (RR s)
_returnI r :: RR s
r@RR s
Eps    = forall (m :: * -> *) a. Monad m => a -> m a
return RR s
r
_returnI r :: RR s
r@Ch {}  = forall (m :: * -> *) a. Monad m => a -> m a
return RR s
r
_returnI r :: RR s
r@Ref {} = forall (m :: * -> *) a. Monad m => a -> m a
return RR s
r
_returnI RR s
r = do
    Int
i <- forall s. M s Int
newId
    STRef s (Map Char (RR s))
ref <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a s. a -> ST s (STRef s a)
newSTRef forall k a. Map k a
Map.empty)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. Int -> STRef s (Map Char (RR s)) -> RR s -> RR s
Ref Int
i STRef s (Map Char (RR s))
ref RR s
r)

-------------------------------------------------------------------------------
-- Smart constructors
-------------------------------------------------------------------------------

nullRR :: RR s
nullRR :: forall s. RR s
nullRR = forall s. CharSet -> RR s
Ch CharSet
CS.empty

fullRR :: RR s
fullRR :: forall s. RR s
fullRR = forall s. RR s -> RR s
Star (forall s. CharSet -> RR s
Ch CharSet
CS.universe)

isNull :: RR s -> Bool
isNull :: forall s. RR s -> Bool
isNull (Ch CharSet
c) = CharSet -> Bool
CS.null CharSet
c
isNull RR s
_      = Bool
False

isFull :: RR s -> Bool
isFull :: forall s. RR s -> Bool
isFull (Star (Ch CharSet
x)) = CharSet
x forall a. Eq a => a -> a -> Bool
== CharSet
CS.universe
isFull RR s
_             = Bool
False

app_ :: RR s -> RR s -> RR s
app_ :: forall s. RR s -> RR s -> RR s
app_ RR s
r    RR s
_    | forall s. RR s -> Bool
isNull RR s
r = RR s
r
app_ RR s
_    RR s
r    | forall s. RR s -> Bool
isNull RR s
r = RR s
r
app_ RR s
Eps  RR s
r    = RR s
r
app_ RR s
r    RR s
Eps  = RR s
r
app_ RR s
r    RR s
s    = forall s. RR s -> RR s -> RR s
App RR s
r RR s
s

alt_ :: RR s -> RR s -> RR s
alt_ :: forall s. RR s -> RR s -> RR s
alt_ RR s
r      RR s
s      | forall s. RR s -> Bool
isNull RR s
r = RR s
s
alt_ RR s
r      RR s
s      | forall s. RR s -> Bool
isNull RR s
s = RR s
r
alt_ RR s
r      RR s
s      | forall s. RR s -> Bool
isFull RR s
r Bool -> Bool -> Bool
|| forall s. RR s -> Bool
isFull RR s
s = forall s. RR s
fullRR
alt_ (Ch CharSet
a) (Ch CharSet
b) = forall s. CharSet -> RR s
Ch (CharSet -> CharSet -> CharSet
CS.union CharSet
a CharSet
b)
alt_ RR s
r      RR s
s      = forall s. RR s -> RR s -> RR s
Alt RR s
r RR s
s

#ifdef RERE_INTERSECTION
and_ :: RR s -> RR s -> RR s
and_ r      s      | isFull r = s
and_ r      s      | isFull s = r
and_ r      s      | isNull r || isNull s = nullRR
and_ (Ch a) (Ch b) = Ch (CS.intersection a b)
and_ r      s      = And r s
#endif

star_ :: RR s -> RR s
star_ :: forall s. RR s -> RR s
star_ RR s
r          | forall s. RR s -> Bool
isNull RR s
r
                 = forall s. RR s
Eps
star_ RR s
Eps        = forall s. RR s
Eps
star_ r :: RR s
r@(Star RR s
_) = RR s
r
star_ RR s
r          = forall s. RR s -> RR s
Star RR s
r

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

-- | Convert 'R.RE' to 'RR' and then match.
--
-- Significantly faster than 'RERE.Type.match'.
--
matchR :: R.RE Void -> String -> Bool
matchR :: RE Void -> String -> Bool
matchR RE Void
re String
str = forall a. (forall s. ST s a) -> a
runST (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall s. RE Void -> M s (RR s)
fromRE RE Void
re forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s. RR s -> M s Bool
go0) Int
0)
  where
    go0 :: RR s -> M s Bool
    go0 :: forall s. RR s -> M s Bool
go0 RR s
rr = do
        let cc :: CharClasses
cc = forall a. RE a -> CharClasses
charClasses RE Void
re
        forall s. CharClasses -> String -> RR s -> M s Bool
go CharClasses
cc String
str RR s
rr

    go :: CharClasses -> String -> RR s -> M s Bool
    go :: forall s. CharClasses -> String -> RR s -> M s Bool
go CharClasses
_  []     RR s
rr = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. RR s -> Bool
nullableR RR s
rr
    go CharClasses
cc (Char
c:String
cs) RR s
rr = do
        let c' :: Char
c' = CharClasses -> Char -> Char
classOfChar CharClasses
cc Char
c
        RR s
rr' <- forall s. Char -> RR s -> M s (RR s)
derivative Char
c' RR s
rr
        forall s. CharClasses -> String -> RR s -> M s Bool
go CharClasses
cc String
cs RR s
rr'

-- | Match and print final 'RR' + stats.
matchDebugR :: R.RE Void -> String -> IO ()
matchDebugR :: RE Void -> String -> IO ()
matchDebugR RE Void
re String
str = forall a. (forall s. ST s a) -> a
runST (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall s. RE Void -> M s (RR s)
fromRE RE Void
re forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s. RR s -> M s (IO ())
go0) Int
0)
  where
    go0 :: RR s -> M s (IO ())
    go0 :: forall s. RR s -> M s (IO ())
go0 RR s
rr = do
        let cc :: CharClasses
cc = forall a. RE a -> CharClasses
charClasses RE Void
re
        forall s. CharClasses -> String -> RR s -> M s (IO ())
go CharClasses
cc String
str RR s
rr

    go :: CharClasses -> String -> RR s -> M s (IO ())
    go :: forall s. CharClasses -> String -> RR s -> M s (IO ())
go CharClasses
_  []     RR s
rr = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"size: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall s. RR s -> Int
_size RR s
rr)
            , String
"show: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RR s
rr
            , String
"null: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall s. RR s -> Bool
nullableR RR s
rr)
            ]

    go CharClasses
cc (Char
c:String
cs) RR s
rr = do
        let c' :: Char
c' = CharClasses -> Char -> Char
classOfChar CharClasses
cc Char
c
        RR s
rr' <- forall s. Char -> RR s -> M s (RR s)
derivative Char
c' RR s
rr
        forall s. CharClasses -> String -> RR s -> M s (IO ())
go CharClasses
cc String
cs RR s
rr'

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

derivative :: Char -> RR s -> M s (RR s)
derivative :: forall s. Char -> RR s -> M s (RR s)
derivative Char
c = forall s. RR s -> M s (RR s)
go where
    go :: RR s -> M s (RR s)
    go :: forall s. RR s -> M s (RR s)
go RR s
Eps                    = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
nullRR
    go (Ch CharSet
x) | Char -> CharSet -> Bool
CS.member Char
c CharSet
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
Eps
              | Bool
otherwise     = forall (m :: * -> *) a. Monad m => a -> m a
return forall s. RR s
nullRR

    go (Alt RR s
r RR s
s) = do
        RR s
r' <- forall s. RR s -> M s (RR s)
go RR s
r
        RR s
s' <- forall s. RR s -> M s (RR s)
go RR s
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. RR s -> RR s -> RR s
alt_ RR s
r' RR s
s')

#ifdef RERE_INTERSECTION
    go (And r s) = do
        r' <- go r
        s' <- go s
        return (and_ r' s')
#endif

    go (App RR s
r RR s
s)
        | forall s. RR s -> Bool
nullableR RR s
r = do
            RR s
r' <- forall s. RR s -> M s (RR s)
go RR s
r
            RR s
s' <- forall s. RR s -> M s (RR s)
go RR s
s
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. RR s -> RR s -> RR s
alt_ RR s
s' (forall s. RR s -> RR s -> RR s
app_ RR s
r' RR s
s)
        | Bool
otherwise = do
            RR s
r' <- forall s. RR s -> M s (RR s)
go RR s
r
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. RR s -> RR s -> RR s
app_ RR s
r' RR s
s

    go r0 :: RR s
r0@(Star RR s
r) = do
        RR s
r' <- forall s. RR s -> M s (RR s)
go RR s
r
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. RR s -> RR s -> RR s
app_ RR s
r' RR s
r0)

    go (Ref Int
_ STRef s (Map Char (RR s))
ref RR s
r) = do
        Map Char (RR s)
m <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s a. STRef s a -> ST s a
readSTRef STRef s (Map Char (RR s))
ref)
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char (RR s)
m of
            Just RR s
r' -> forall (m :: * -> *) a. Monad m => a -> m a
return RR s
r'
            Maybe (RR s)
Nothing -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \RR s
res -> do
                Int
j <- forall s. M s Int
newId
                STRef s (Map Char (RR s))
ref' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a s. a -> ST s (STRef s a)
newSTRef forall k a. Map k a
Map.empty)
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Map Char (RR s))
ref (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Char
c RR s
res Map Char (RR s)
m))
                RR s
r' <- forall s. RR s -> M s (RR s)
go RR s
r
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. Int -> STRef s (Map Char (RR s)) -> RR s -> RR s
Ref Int
j STRef s (Map Char (RR s))
ref' RR s
r')

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

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

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

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

collectEquation :: RR s -> State (Map.Map Int (RR s)) BoolExpr
collectEquation :: forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
Eps       = forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
collectEquation (Ch CharSet
_)    = forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BFalse
collectEquation (App RR s
r RR s
s) = BoolExpr -> BoolExpr -> BoolExpr
band forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
s
collectEquation (Alt RR s
r RR s
s) = BoolExpr -> BoolExpr -> BoolExpr
bor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
s
collectEquation (Star RR s
_)  = forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
collectEquation (Ref Int
i STRef s (Map Char (RR s))
_ RR s
r) = do
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i RR s
r)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> BoolExpr
BVar Int
i)
#ifdef RERE_INTERSECTION
collectEquation (And r s) = band <$> collectEquation r <*> collectEquation s
#endif

lfp :: BoolExpr -> Map.Map Int BoolExpr -> Bool
lfp :: BoolExpr -> Map Int BoolExpr -> Bool
lfp BoolExpr
b Map Int BoolExpr
exprs = Map Int Bool -> Bool
go (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map Int BoolExpr
exprs) where
    go :: Map Int Bool -> Bool
go Map Int Bool
curr
        | Map Int Bool
curr forall a. Eq a => a -> a -> Bool
== Map Int Bool
next = BoolExpr -> Bool
evaluate BoolExpr
b
        | Bool
otherwise    = Map Int Bool -> Bool
go Map Int Bool
next
      where
        next :: Map Int Bool
next = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoolExpr -> Bool
evaluate Map Int 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 Int
i)   = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False Int
i Map Int Bool
curr

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

data BoolExpr
    = BVar Int
    | BTrue
    | BFalse
    | BOr BoolExpr BoolExpr
    | BAnd BoolExpr BoolExpr
  deriving (Int -> BoolExpr -> ShowS
[BoolExpr] -> ShowS
BoolExpr -> String
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