module Language.Lexer.Tlex.Pipeline.Nfa2Dfa (
    nfa2Dfa,
) where

import           Language.Lexer.Tlex.Prelude

import qualified Data.EnumMap.Strict                 as EnumMap
import qualified Data.HashMap.Strict                 as HashMap
import qualified Data.IntMap.Strict                  as IntMap
import qualified Data.IntSet                         as IntSet
import qualified Language.Lexer.Tlex.Machine.DFA     as DFA
import qualified Language.Lexer.Tlex.Machine.NFA     as NFA
import qualified Language.Lexer.Tlex.Machine.Pattern as Pattern
import qualified Language.Lexer.Tlex.Machine.State   as MState


nfa2Dfa :: NFA.NFA a -> DFA.DFA a
nfa2Dfa :: forall a. NFA a -> DFA a
nfa2Dfa NFA a
nfa = forall m. DFABuilder m () -> DFA m
DFA.buildDFA
    do forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \DFABuilderContext a
dfaBuilderCtx0 -> forall m. Nfa2DfaContext m -> DFABuilderContext m
nfa2DfaCtxDFABuilderCtx
        do forall s a. State s a -> s -> s
execState
            do forall m. NFA m -> Nfa2DfaM m ()
nfa2DfaM NFA a
nfa
            do Nfa2DfaContext
                { $sel:nfa2DfaCtxStateMap:Nfa2DfaContext :: HashMap StateSet StateNum
nfa2DfaCtxStateMap = forall k v. HashMap k v
HashMap.empty
                , $sel:nfa2DfaCtxDFABuilderCtx:Nfa2DfaContext :: DFABuilderContext a
nfa2DfaCtxDFABuilderCtx = DFABuilderContext a
dfaBuilderCtx0
                }


data Nfa2DfaContext m = Nfa2DfaContext
    { forall m. Nfa2DfaContext m -> HashMap StateSet StateNum
nfa2DfaCtxStateMap      :: HashMap.HashMap MState.StateSet MState.StateNum
    , forall m. Nfa2DfaContext m -> DFABuilderContext m
nfa2DfaCtxDFABuilderCtx :: DFA.DFABuilderContext m
    }

type Nfa2DfaM m = State (Nfa2DfaContext m)

liftBuilderOp :: DFA.DFABuilder m a -> Nfa2DfaM m a
liftBuilderOp :: forall m a. DFABuilder m a -> Nfa2DfaM m a
liftBuilderOp DFABuilder m a
builder = do
    Nfa2DfaContext m
ctx0 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (a
x, DFABuilderContext m
builderCtx1) = forall s a. State s a -> s -> (a, s)
runState DFABuilder m a
builder do forall m. Nfa2DfaContext m -> DFABuilderContext m
nfa2DfaCtxDFABuilderCtx Nfa2DfaContext m
ctx0
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put do Nfa2DfaContext m
ctx0
            { $sel:nfa2DfaCtxDFABuilderCtx:Nfa2DfaContext :: DFABuilderContext m
nfa2DfaCtxDFABuilderCtx = DFABuilderContext m
builderCtx1
            }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

registerNewState :: MState.StateSet -> Nfa2DfaM m MState.StateNum
registerNewState :: forall m. StateSet -> Nfa2DfaM m StateNum
registerNewState StateSet
nfaSs = do
    StateNum
dfaSn <- forall m a. DFABuilder m a -> Nfa2DfaM m a
liftBuilderOp forall m. DFABuilder m StateNum
DFA.newStateNum
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \ctx0 :: Nfa2DfaContext m
ctx0@Nfa2DfaContext{ HashMap StateSet StateNum
nfa2DfaCtxStateMap :: HashMap StateSet StateNum
$sel:nfa2DfaCtxStateMap:Nfa2DfaContext :: forall m. Nfa2DfaContext m -> HashMap StateSet StateNum
nfa2DfaCtxStateMap } -> Nfa2DfaContext m
ctx0
        { $sel:nfa2DfaCtxStateMap:Nfa2DfaContext :: HashMap StateSet StateNum
nfa2DfaCtxStateMap = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert StateSet
nfaSs StateNum
dfaSn HashMap StateSet StateNum
nfa2DfaCtxStateMap
        }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure StateNum
dfaSn

nfa2DfaM :: NFA.NFA m -> Nfa2DfaM m ()
nfa2DfaM :: forall m. NFA m -> Nfa2DfaM m ()
nfa2DfaM NFA.NFA{ [(StateNum, StartState)]
$sel:nfaInitials:NFA :: forall a. NFA a -> [(StateNum, StartState)]
nfaInitials :: [(StateNum, StartState)]
nfaInitials, StateArray (NFAState m)
$sel:nfaTrans:NFA :: forall a. NFA a -> StateArray (NFAState a)
nfaTrans :: StateArray (NFAState m)
nfaTrans } = do
    [(StateNum, StateSet)]
initials <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(StateNum, StartState)]
nfaInitials \(StateNum
nfaSn, StartState
s) -> do
        let nfaSs :: StateSet
nfaSs = StateNum -> StateSet
buildNfaSs StateNum
nfaSn
        StateNum
dfaSn <- forall m. StateSet -> Nfa2DfaM m StateNum
registerNewState StateSet
nfaSs
        forall m a. DFABuilder m a -> Nfa2DfaM m a
liftBuilderOp do forall m. StateNum -> StartState -> DFABuilder m ()
DFA.initial StateNum
dfaSn StartState
s
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateNum
dfaSn, StateSet
nfaSs)

    [(StateNum, StateSet)] -> Nfa2DfaM m ()
buildStateMap [(StateNum, StateSet)]
initials
    where
        buildNfaSs :: StateNum -> StateSet
buildNfaSs StateNum
nfaSn =
            let nfaState :: NFAState m
nfaState = StateArray (NFAState m)
nfaTrans forall a. StateArray a -> StateNum -> a
`MState.indexArray` StateNum
nfaSn
            in [StateNum] -> StateSet
MState.listToSet do forall a. NFAState a -> [StateNum]
NFA.nstEpsilonTrans NFAState m
nfaState

        insertNfaSn :: StateNum -> StateSet -> StateSet
insertNfaSn StateNum
nfaSn0 StateSet
nfaSs0 =
            let nfaState0 :: NFAState m
nfaState0 = StateArray (NFAState m)
nfaTrans forall a. StateArray a -> StateNum -> a
`MState.indexArray` StateNum
nfaSn0
            in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                do \StateSet
nfaSs StateNum
nfaSn -> StateNum -> StateSet -> StateSet
MState.insertSet StateNum
nfaSn StateSet
nfaSs
                do StateSet
nfaSs0
                do forall a. NFAState a -> [StateNum]
NFA.nstEpsilonTrans NFAState m
nfaState0

        buildStateMap :: [(StateNum, StateSet)] -> Nfa2DfaM m ()
buildStateMap = \case
            []                   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            (StateNum
dfaSn, StateSet
nfaSs):[(StateNum, StateSet)]
rest0 -> do
                ([(StateNum, StateSet)]
rest1, DFAState m
dst) <- StateSet
-> [(StateNum, StateSet)]
-> StateT
     (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], DFAState m)
buildDFAState StateSet
nfaSs [(StateNum, StateSet)]
rest0
                forall m a. DFABuilder m a -> Nfa2DfaM m a
liftBuilderOp do forall m. StateNum -> DFAState m -> DFABuilder m ()
DFA.insertTrans StateNum
dfaSn DFAState m
dst
                [(StateNum, StateSet)] -> Nfa2DfaM m ()
buildStateMap [(StateNum, StateSet)]
rest1

        buildDFAState :: StateSet
-> [(StateNum, StateSet)]
-> StateT
     (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], DFAState m)
buildDFAState StateSet
nfaSs0 [(StateNum, StateSet)]
rest0 = do
            (EnumMap AcceptPriority (Accept m)
accs1, EnumMap Key StateSet
trans1, StateSet
otherTrans1) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                do \(EnumMap AcceptPriority (Accept m)
accs, EnumMap Key StateSet
trans, StateSet
otherTrans) StateNum
nfaSn ->
                    let nfaState :: NFAState m
nfaState = StateArray (NFAState m)
nfaTrans forall a. StateArray a -> StateNum -> a
`MState.indexArray` StateNum
nfaSn
                        accs' :: EnumMap AcceptPriority (Accept m)
accs' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                                do \EnumMap AcceptPriority (Accept m)
m Accept m
acc -> forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insert
                                    do forall a. Accept a -> AcceptPriority
Pattern.accPriority Accept m
acc
                                    do Accept m
acc
                                    do EnumMap AcceptPriority (Accept m)
m
                                do EnumMap AcceptPriority (Accept m)
accs
                                do forall a. NFAState a -> [Accept a]
NFA.nstAccepts NFAState m
nfaState
                        (EnumMap Key StateSet
trans', StateSet
otherTrans') = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (EnumMap Key StateSet, StateSet)
-> NFAStateTrans -> (EnumMap Key StateSet, StateSet)
insertTrans (EnumMap Key StateSet
trans, StateSet
otherTrans)
                                                    do forall a. NFAState a -> [NFAStateTrans]
NFA.nstTrans NFAState m
nfaState
                    in forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap AcceptPriority (Accept m)
accs', EnumMap Key StateSet
trans', StateSet
otherTrans')
                do (forall k a. EnumMap k a
EnumMap.empty, forall k a. EnumMap k a
EnumMap.empty, StateSet
MState.emptySet)
                do StateSet -> [StateNum]
MState.setToList StateSet
nfaSs0

            let getOrRegisterNfaSs :: StateSet
-> [(StateNum, StateSet)]
-> StateT
     (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum)
getOrRegisterNfaSs StateSet
nfaSs [(StateNum, StateSet)]
rest = do
                    Nfa2DfaContext m
ctx0 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
                    let stateMap :: HashMap StateSet StateNum
stateMap = forall m. Nfa2DfaContext m -> HashMap StateSet StateNum
nfa2DfaCtxStateMap Nfa2DfaContext m
ctx0
                    case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup StateSet
nfaSs HashMap StateSet StateNum
stateMap of
                        Just StateNum
dfaSn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(StateNum, StateSet)]
rest, StateNum
dfaSn)
                        Maybe StateNum
Nothing -> do
                            StateNum
dfaSn <- forall m. StateSet -> Nfa2DfaM m StateNum
registerNewState StateSet
nfaSs
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StateNum
dfaSn, StateSet
nfaSs)forall a. a -> [a] -> [a]
:[(StateNum, StateSet)]
rest, StateNum
dfaSn)

            ([(StateNum, StateSet)]
rest1, IntMap StateNum
trans2) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                do \([(StateNum, StateSet)]
rest, IntMap StateNum
trans) (Key
c, StateSet
nfaSs) -> do
                    ([(StateNum, StateSet)]
rest', StateNum
dfaSn) <- forall {m}.
StateSet
-> [(StateNum, StateSet)]
-> StateT
     (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum)
getOrRegisterNfaSs StateSet
nfaSs [(StateNum, StateSet)]
rest
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(StateNum, StateSet)]
rest', forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert (forall a. Enum a => a -> Key
fromEnum Key
c) StateNum
dfaSn IntMap StateNum
trans)
                do ([(StateNum, StateSet)]
rest0, forall a. IntMap a
IntMap.empty)
                do forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.assocs EnumMap Key StateSet
trans1

            ([(StateNum, StateSet)]
rest2, Maybe StateNum
otherTrans2) <- case StateSet -> Bool
MState.nullSet StateSet
otherTrans1 of
                Bool
True  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(StateNum, StateSet)]
rest1, forall a. Maybe a
Nothing)
                Bool
False -> do
                    ([(StateNum, StateSet)]
rest, StateNum
dfaSn) <- forall {m}.
StateSet
-> [(StateNum, StateSet)]
-> StateT
     (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum)
getOrRegisterNfaSs StateSet
otherTrans1 [(StateNum, StateSet)]
rest1
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(StateNum, StateSet)]
rest, forall a. a -> Maybe a
Just StateNum
dfaSn)

            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( [(StateNum, StateSet)]
rest2
                , DFA.DState
                    { $sel:dstAccepts:DState :: [Accept m]
dstAccepts = [ Accept m
acc | (AcceptPriority
_, Accept m
acc) <- forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.toDescList EnumMap AcceptPriority (Accept m)
accs1 ]
                    , $sel:dstTrans:DState :: IntMap StateNum
dstTrans = IntMap StateNum
trans2
                    , $sel:dstOtherTrans:DState :: Maybe StateNum
dstOtherTrans = Maybe StateNum
otherTrans2
                    }
                )

        insertTrans :: (EnumMap Key StateSet, StateSet)
-> NFAStateTrans -> (EnumMap Key StateSet, StateSet)
insertTrans (EnumMap Key StateSet
trans0, StateSet
otherTrans0) NFAStateTrans
st =
            let cs :: IntSet
cs = NFAStateTrans -> IntSet
NFA.nstTransRange NFAStateTrans
st
                nfaSn :: StateNum
nfaSn = NFAStateTrans -> StateNum
NFA.nstTransNextState NFAStateTrans
st
            in case NFAStateTrans -> Bool
NFA.nstTransIsStraight NFAStateTrans
st of
                Bool
True ->
                    let ~StateSet
newTrans = StateNum -> StateSet -> StateSet
insertNfaSn StateNum
nfaSn StateSet
otherTrans0
                        trans1 :: EnumMap Key StateSet
trans1 = forall a. (a -> Key -> a) -> a -> IntSet -> a
IntSet.foldl'
                            do \EnumMap Key StateSet
trans Key
c -> forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EnumMap.alter
                                do \case
                                    Maybe StateSet
Nothing -> forall a. a -> Maybe a
Just StateSet
newTrans
                                    Just StateSet
ss -> forall a. a -> Maybe a
Just do StateNum -> StateSet -> StateSet
insertNfaSn StateNum
nfaSn StateSet
ss
                                do Key
c
                                do EnumMap Key StateSet
trans
                            do EnumMap Key StateSet
trans0
                            do IntSet
cs
                    in (EnumMap Key StateSet
trans1, StateSet
otherTrans0)
                Bool
False ->
                    let (EnumMap Key StateSet
diffTrans1, EnumMap Key StateSet
trans1) = forall a. (a -> Key -> a) -> a -> IntSet -> a
IntSet.foldl'
                                                do \(EnumMap Key StateSet
diffTrans, EnumMap Key StateSet
trans) Key
c ->
                                                    ( forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EnumMap.delete Key
c EnumMap Key StateSet
diffTrans
                                                    , forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EnumMap.alter
                                                        do \case
                                                            Maybe StateSet
Nothing -> forall a. a -> Maybe a
Just StateSet
MState.emptySet
                                                            Just StateSet
ss -> forall a. a -> Maybe a
Just StateSet
ss
                                                        Key
c
                                                        EnumMap Key StateSet
trans
                                                    )
                                                do (EnumMap Key StateSet
trans0, EnumMap Key StateSet
trans0)
                                                do IntSet
cs
                        trans2 :: EnumMap Key StateSet
trans2 = forall k a b. Enum k => (a -> k -> b -> a) -> a -> EnumMap k b -> a
EnumMap.foldlWithKey'
                                    do \EnumMap Key StateSet
trans Key
c StateSet
ss -> forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insert Key
c
                                        do StateNum -> StateSet -> StateSet
insertNfaSn StateNum
nfaSn StateSet
ss
                                        do EnumMap Key StateSet
trans
                                    do EnumMap Key StateSet
trans1
                                    do EnumMap Key StateSet
diffTrans1
                    in (EnumMap Key StateSet
trans2, StateNum -> StateSet -> StateSet
insertNfaSn StateNum
nfaSn StateSet
otherTrans0)