{-# 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 = Set Int -> Int -> RR s -> ShowS
forall s. Set Int -> Int -> RR s -> ShowS
go Set Int
forall a. Set a
Set.empty where
        go :: Set.Set Int -> Int -> RR s -> ShowS
        go :: 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 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 Int
past Int
d (App RR s
r RR 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
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Int -> RR s -> ShowS
forall s. Set Int -> Int -> RR s -> ShowS
go Set Int
past Int
11 RR 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 Int -> Int -> RR s -> ShowS
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 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
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Int -> RR s -> ShowS
forall s. Set Int -> Int -> RR s -> ShowS
go Set Int
past Int
11 RR 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 Int -> Int -> RR s -> ShowS
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 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
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Int -> RR s -> ShowS
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)
            | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Int
i Set Int
past = 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
"Ref " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" <<loop>>"
            | Bool
otherwise         = 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
"Ref " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
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 Int -> Int -> RR s -> ShowS
forall s. Set Int -> Int -> RR s -> ShowS
go (Int -> Set Int -> Set Int
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 :: RE Void -> M s (RR s)
fromRE RE Void
re = RE (RR s) -> M s (RR s)
forall s. RE (RR s) -> StateT Int (ST s) (RR s)
go (RE Void -> RE (RR s)
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   = RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
nullRR
    go RE (RR s)
R.Full   = RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
fullRR
    go RE (RR s)
R.Eps    = RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
Eps
    go (R.Ch CharSet
c) = RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (CharSet -> RR s
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
        RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> RR s -> RR s
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
        RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> RR s -> RR s
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
        RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> RR s
forall s. RR s -> RR s
star_ RR s
r')

    go (R.Var RR s
r) = RR s -> StateT Int (ST s) (RR s)
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 ((Var (RR s) -> RR s) -> RE (Var (RR s)) -> RE (RR s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RR s -> (RR s -> RR s) -> Var (RR s) -> RR s
forall r a. r -> (a -> r) -> Var a -> r
unvar RR s
r' RR s -> RR s
forall a. a -> a
id) RE (Var (RR s))
s)

    go (R.Fix Name
_ RE (Var (RR s))
r) = (RR s -> StateT Int (ST s) (RR s)) -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((RR s -> StateT Int (ST s) (RR s)) -> StateT Int (ST s) (RR s))
-> (RR s -> StateT Int (ST s) (RR s)) -> StateT Int (ST s) (RR s)
forall a b. (a -> b) -> a -> b
$ \RR s
res -> do
        Int
i <- M s Int
forall s. M s Int
newId
        STRef s (Map Char (RR s))
ref <- ST s (STRef s (Map Char (RR s)))
-> StateT Int (ST s) (STRef s (Map Char (RR s)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Map Char (RR s) -> ST s (STRef s (Map Char (RR s)))
forall a s. a -> ST s (STRef s a)
newSTRef Map Char (RR s)
forall k a. Map k a
Map.empty)
        RR s
r' <- RE (RR s) -> StateT Int (ST s) (RR s)
go ((Var (RR s) -> RR s) -> RE (Var (RR s)) -> RE (RR s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RR s -> (RR s -> RR s) -> Var (RR s) -> RR s
forall r a. r -> (a -> r) -> Var a -> r
unvar RR s
res RR s -> RR s
forall a. a -> a
id) RE (Var (RR s))
r)
        RR s -> StateT Int (ST s) (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> STRef s (Map Char (RR s)) -> RR s -> RR s
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 :: RR s -> Int
_size RR s
rr = State (Set Int) Int -> Set Int -> Int
forall s a. State s a -> s -> a
evalState (RR s -> State (Set Int) Int
forall (m :: * -> *) b s.
(Monad m, Num b, Enum b) =>
RR s -> StateT (Set Int) m b
go RR s
rr) Set Int
forall a. Set a
Set.empty where
    go :: RR s -> StateT (Set Int) m b
go RR s
Eps       = b -> StateT (Set Int) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
1
    go (Ch CharSet
_)    = b -> StateT (Set Int) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
1
    go (App RR s
r RR s
s) = b -> b -> b
forall a. (Enum a, Num a) => a -> a -> a
plus1 (b -> b -> b)
-> StateT (Set Int) m b -> StateT (Set Int) m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m b
go RR s
r StateT (Set Int) m (b -> b)
-> StateT (Set Int) m b -> StateT (Set Int) m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> StateT (Set Int) m b
go RR s
s
    go (Alt RR s
r RR s
s) = b -> b -> b
forall a. (Enum a, Num a) => a -> a -> a
plus1 (b -> b -> b)
-> StateT (Set Int) m b -> StateT (Set Int) m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m b
go RR s
r StateT (Set Int) m (b -> b)
-> StateT (Set Int) m b -> StateT (Set Int) m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> StateT (Set Int) m b
go RR s
s
#ifdef RERE_INTERSECTION
    go (And r s) = plus1 <$> go r <*> go s
#endif
    go (Star RR s
r)  = b -> b
forall a. Enum a => a -> a
succ (b -> b) -> StateT (Set Int) m b -> StateT (Set Int) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m b
go RR s
r
    go (Ref Int
i STRef s (Map Char (RR s))
_ RR s
r) = do
        Set Int
visited <- StateT (Set Int) m (Set Int)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        if Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Int
i Set Int
visited
        then b -> StateT (Set Int) m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
1
        else do
            Set Int -> StateT (Set Int) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
i Set Int
visited)
            b -> b
forall a. Enum a => a -> a
succ (b -> b) -> StateT (Set Int) m b -> StateT (Set Int) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> StateT (Set Int) m b
go RR 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)

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

type M s = StateT Int (ST s)

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

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

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

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

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

app_ :: RR s -> RR s -> RR s
app_ :: RR s -> RR s -> RR s
app_ RR s
r    RR s
_    | RR s -> Bool
forall s. RR s -> Bool
isNull RR s
r = RR s
r
app_ RR s
_    RR s
r    | RR s -> Bool
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    = RR s -> RR s -> RR s
forall s. RR s -> RR s -> RR s
App RR s
r RR s
s

alt_ :: RR s -> RR s -> RR s
alt_ :: RR s -> RR s -> RR s
alt_ RR s
r      RR s
s      | RR s -> Bool
forall s. RR s -> Bool
isNull RR s
r = RR s
s
alt_ RR s
r      RR s
s      | RR s -> Bool
forall s. RR s -> Bool
isNull RR s
s = RR s
r
alt_ RR s
r      RR s
s      | RR s -> Bool
forall s. RR s -> Bool
isFull RR s
r Bool -> Bool -> Bool
|| RR s -> Bool
forall s. RR s -> Bool
isFull RR s
s = RR s
forall s. RR s
fullRR
alt_ (Ch CharSet
a) (Ch CharSet
b) = CharSet -> RR s
forall s. CharSet -> RR s
Ch (CharSet -> CharSet -> CharSet
CS.union CharSet
a CharSet
b)
alt_ RR s
r      RR s
s      = RR s -> RR s -> RR 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_ :: RR s -> RR s
star_ RR s
r          | RR s -> Bool
forall s. RR s -> Bool
isNull RR s
r
                 = RR s
forall s. RR s
Eps
star_ RR s
Eps        = RR s
forall s. RR s
Eps
star_ r :: RR s
r@(Star RR s
_) = RR s
r
star_ RR s
r          = RR s -> RR s
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 s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (StateT Int (ST s) Bool -> Int -> ST s Bool
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RE Void -> M s (RR s)
forall s. RE Void -> M s (RR s)
fromRE RE Void
re M s (RR s)
-> (RR s -> StateT Int (ST s) Bool) -> StateT Int (ST s) Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RR s -> StateT Int (ST s) Bool
forall s. RR s -> M s Bool
go0) Int
0)
  where
    go0 :: RR s -> M s Bool
    go0 :: RR s -> M s Bool
go0 RR s
rr = do
        let cc :: CharClasses
cc = RE Void -> CharClasses
forall a. RE a -> CharClasses
charClasses RE Void
re
        CharClasses -> String -> RR s -> M s Bool
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 :: CharClasses -> String -> RR s -> M s Bool
go CharClasses
_  []     RR s
rr = Bool -> M s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> M s Bool) -> Bool -> M s Bool
forall a b. (a -> b) -> a -> b
$ RR s -> Bool
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' <- Char -> RR s -> M s (RR s)
forall s. Char -> RR s -> M s (RR s)
derivative Char
c' RR s
rr
        CharClasses -> String -> RR s -> M s Bool
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 s. ST s (IO ())) -> IO ()
forall a. (forall s. ST s a) -> a
runST (StateT Int (ST s) (IO ()) -> Int -> ST s (IO ())
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RE Void -> M s (RR s)
forall s. RE Void -> M s (RR s)
fromRE RE Void
re M s (RR s)
-> (RR s -> StateT Int (ST s) (IO ())) -> StateT Int (ST s) (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RR s -> StateT Int (ST s) (IO ())
forall s. RR s -> M s (IO ())
go0) Int
0)
  where
    go0 :: RR s -> M s (IO ())
    go0 :: RR s -> M s (IO ())
go0 RR s
rr = do
        let cc :: CharClasses
cc = RE Void -> CharClasses
forall a. RE a -> CharClasses
charClasses RE Void
re
        CharClasses -> String -> RR s -> M s (IO ())
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 :: CharClasses -> String -> RR s -> M s (IO ())
go CharClasses
_  []     RR s
rr = IO () -> M s (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> M s (IO ())) -> IO () -> M 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
"size: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RR s -> Int
forall s. RR s -> Int
_size RR s
rr)
            , String
"show: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RR s -> String
forall a. Show a => a -> String
show RR s
rr
            , String
"null: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (RR s -> Bool
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' <- Char -> RR s -> M s (RR s)
forall s. Char -> RR s -> M s (RR s)
derivative Char
c' RR s
rr
        CharClasses -> String -> RR s -> M s (IO ())
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 :: Char -> RR s -> M s (RR s)
derivative Char
c = RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go where
    go :: RR s -> M s (RR s)
    go :: RR s -> M s (RR s)
go RR s
Eps                    = RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
nullRR
    go (Ch CharSet
x) | Char -> CharSet -> Bool
CS.member Char
c CharSet
x = RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
Eps
              | Bool
otherwise     = RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
forall s. RR s
nullRR

    go (Alt RR s
r RR s
s) = do
        RR s
r' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
r
        RR s
s' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
s
        RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> RR s -> RR s
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)
        | RR s -> Bool
forall s. RR s -> Bool
nullableR RR s
r = do
            RR s
r' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
r
            RR s
s' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
s
            RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> M s (RR s)) -> RR s -> M s (RR s)
forall a b. (a -> b) -> a -> b
$ RR s -> RR s -> RR s
forall s. RR s -> RR s -> RR s
alt_ RR s
s' (RR s -> RR s -> RR s
forall s. RR s -> RR s -> RR s
app_ RR s
r' RR s
s)
        | Bool
otherwise = do
            RR s
r' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
r
            RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> M s (RR s)) -> RR s -> M s (RR s)
forall a b. (a -> b) -> a -> b
$ RR s -> RR s -> RR s
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' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
r
        RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (RR s -> RR s -> RR s
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 <- ST s (Map Char (RR s)) -> StateT Int (ST s) (Map Char (RR s))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STRef s (Map Char (RR s)) -> ST s (Map Char (RR s))
forall s a. STRef s a -> ST s a
readSTRef STRef s (Map Char (RR s))
ref)
        case Char -> Map Char (RR s) -> Maybe (RR s)
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' -> RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return RR s
r'
            Maybe (RR s)
Nothing -> (RR s -> M s (RR s)) -> M s (RR s)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((RR s -> M s (RR s)) -> M s (RR s))
-> (RR s -> M s (RR s)) -> M s (RR s)
forall a b. (a -> b) -> a -> b
$ \RR s
res -> do
                Int
j <- M s Int
forall s. M s Int
newId
                STRef s (Map Char (RR s))
ref' <- ST s (STRef s (Map Char (RR s)))
-> StateT Int (ST s) (STRef s (Map Char (RR s)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Map Char (RR s) -> ST s (STRef s (Map Char (RR s)))
forall a s. a -> ST s (STRef s a)
newSTRef Map Char (RR s)
forall k a. Map k a
Map.empty)
                ST s () -> StateT Int (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STRef s (Map Char (RR s)) -> Map Char (RR s) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Map Char (RR s))
ref (Char -> RR s -> Map Char (RR s) -> Map Char (RR s)
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' <- RR s -> M s (RR s)
forall s. RR s -> M s (RR s)
go RR s
r
                RR s -> M s (RR s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> STRef s (Map Char (RR s)) -> RR s -> RR s
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 :: RR s -> Bool
nullableR RR s
r =
    let (BoolExpr
bexpr, Map Int BoolExpr
eqs) = RR s -> (BoolExpr, Map Int BoolExpr)
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 :: RR s -> (BoolExpr, Map Int BoolExpr)
equations RR s
r =
    let (BoolExpr
bexpr, Map Int (RR s)
next) = State (Map Int (RR s)) BoolExpr
-> Map Int (RR s) -> (BoolExpr, Map Int (RR s))
forall s a. State s a -> s -> (a, s)
runState (RR s -> State (Map Int (RR s)) BoolExpr
forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r) Map Int (RR s)
forall k a. Map k a
Map.empty
    in (BoolExpr
bexpr, Map Int (RR s) -> Map Int BoolExpr
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 :: Map Int (RR s) -> Map Int BoolExpr
collectEquations = Map Int BoolExpr -> Map Int (RR s) -> Map Int BoolExpr
forall s. Map Int BoolExpr -> Map Int (RR s) -> Map Int BoolExpr
go Map Int BoolExpr
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 Map Int (RR s) -> Maybe ((Int, RR s), Map Int (RR s))
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')
            | Int -> Map Int BoolExpr -> Bool
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) = State (Map Int (RR s)) BoolExpr
-> Map Int (RR s) -> (BoolExpr, Map Int (RR s))
forall s a. State s a -> s -> (a, s)
runState (RR s -> State (Map Int (RR s)) BoolExpr
forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r) Map Int (RR s)
forall k a. Map k a
Map.empty
                in Map Int BoolExpr -> Map Int (RR s) -> Map Int BoolExpr
go (Int -> BoolExpr -> Map Int BoolExpr -> Map Int BoolExpr
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' Map Int (RR s) -> Map Int (RR s) -> Map Int (RR s)
forall a. Semigroup a => a -> a -> a
<> Map Int (RR s)
next)

collectEquation :: RR s -> State (Map.Map Int (RR s)) BoolExpr
collectEquation :: RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
Eps       = BoolExpr -> State (Map Int (RR s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BTrue
collectEquation (Ch CharSet
_)    = BoolExpr -> State (Map Int (RR s)) BoolExpr
forall (m :: * -> *) a. Monad m => a -> m a
return BoolExpr
BFalse
collectEquation (App RR s
r RR s
s) = BoolExpr -> BoolExpr -> BoolExpr
band (BoolExpr -> BoolExpr -> BoolExpr)
-> State (Map Int (RR s)) BoolExpr
-> StateT (Map Int (RR s)) Identity (BoolExpr -> BoolExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> State (Map Int (RR s)) BoolExpr
forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r StateT (Map Int (RR s)) Identity (BoolExpr -> BoolExpr)
-> State (Map Int (RR s)) BoolExpr
-> State (Map Int (RR s)) BoolExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> State (Map Int (RR s)) BoolExpr
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 (BoolExpr -> BoolExpr -> BoolExpr)
-> State (Map Int (RR s)) BoolExpr
-> StateT (Map Int (RR s)) Identity (BoolExpr -> BoolExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RR s -> State (Map Int (RR s)) BoolExpr
forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
r StateT (Map Int (RR s)) Identity (BoolExpr -> BoolExpr)
-> State (Map Int (RR s)) BoolExpr
-> State (Map Int (RR s)) BoolExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RR s -> State (Map Int (RR s)) BoolExpr
forall s. RR s -> State (Map Int (RR s)) BoolExpr
collectEquation RR s
s
collectEquation (Star RR s
_)  = BoolExpr -> State (Map Int (RR s)) BoolExpr
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
    (Map Int (RR s) -> Map Int (RR s))
-> StateT (Map Int (RR s)) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Int -> RR s -> Map Int (RR s) -> Map Int (RR s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i RR s
r)
    BoolExpr -> State (Map Int (RR s)) BoolExpr
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 Bool -> Map Int BoolExpr -> Map Int Bool
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 Map Int Bool -> Map Int Bool -> Bool
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 = (BoolExpr -> Bool) -> Map Int BoolExpr -> Map Int Bool
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)   = Bool -> Int -> Map Int Bool -> Bool
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
(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