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 :: NFA a -> DFA a nfa2Dfa NFA a nfa = DFABuilder a () -> DFA a forall m. DFABuilder m () -> DFA m DFA.buildDFA do (DFABuilderContext a -> DFABuilderContext a) -> DFABuilder a () forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m () modify' \DFABuilderContext a dfaBuilderCtx0 -> Nfa2DfaContext a -> DFABuilderContext a forall m. Nfa2DfaContext m -> DFABuilderContext m nfa2DfaCtxDFABuilderCtx do State (Nfa2DfaContext a) () -> Nfa2DfaContext a -> Nfa2DfaContext a forall s a. State s a -> s -> s execState do NFA a -> State (Nfa2DfaContext a) () forall m. NFA m -> Nfa2DfaM m () nfa2DfaM NFA a nfa do Nfa2DfaContext :: forall m. HashMap StateSet StateNum -> DFABuilderContext m -> Nfa2DfaContext m Nfa2DfaContext { $sel:nfa2DfaCtxStateMap:Nfa2DfaContext :: HashMap StateSet StateNum nfa2DfaCtxStateMap = HashMap StateSet StateNum forall k v. HashMap k v HashMap.empty , $sel:nfa2DfaCtxDFABuilderCtx:Nfa2DfaContext :: DFABuilderContext a nfa2DfaCtxDFABuilderCtx = DFABuilderContext a dfaBuilderCtx0 } data Nfa2DfaContext m = Nfa2DfaContext { Nfa2DfaContext m -> HashMap StateSet StateNum nfa2DfaCtxStateMap :: HashMap.HashMap MState.StateSet MState.StateNum , Nfa2DfaContext m -> DFABuilderContext m nfa2DfaCtxDFABuilderCtx :: DFA.DFABuilderContext m } type Nfa2DfaM m = State (Nfa2DfaContext m) liftBuilderOp :: DFA.DFABuilder m a -> Nfa2DfaM m a liftBuilderOp :: DFABuilder m a -> Nfa2DfaM m a liftBuilderOp DFABuilder m a builder = do Nfa2DfaContext m ctx0 <- StateT (Nfa2DfaContext m) Identity (Nfa2DfaContext m) forall (m :: * -> *) s. Monad m => StateT s m s get let (a x, DFABuilderContext m builderCtx1) = DFABuilder m a -> DFABuilderContext m -> (a, DFABuilderContext m) forall s a. State s a -> s -> (a, s) runState DFABuilder m a builder do Nfa2DfaContext m -> DFABuilderContext m forall m. Nfa2DfaContext m -> DFABuilderContext m nfa2DfaCtxDFABuilderCtx Nfa2DfaContext m ctx0 Nfa2DfaContext m -> StateT (Nfa2DfaContext m) Identity () forall (m :: * -> *) s. Monad m => s -> StateT s m () put do Nfa2DfaContext m ctx0 { $sel:nfa2DfaCtxDFABuilderCtx:Nfa2DfaContext :: DFABuilderContext m nfa2DfaCtxDFABuilderCtx = DFABuilderContext m builderCtx1 } a -> Nfa2DfaM m a forall (f :: * -> *) a. Applicative f => a -> f a pure a x registerNewState :: MState.StateSet -> Nfa2DfaM m MState.StateNum registerNewState :: StateSet -> Nfa2DfaM m StateNum registerNewState StateSet nfaSs = do StateNum dfaSn <- DFABuilder m StateNum -> Nfa2DfaM m StateNum forall m a. DFABuilder m a -> Nfa2DfaM m a liftBuilderOp DFABuilder m StateNum forall m. DFABuilder m StateNum DFA.newStateNum (Nfa2DfaContext m -> Nfa2DfaContext m) -> StateT (Nfa2DfaContext m) Identity () 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 = StateSet -> StateNum -> HashMap StateSet StateNum -> HashMap StateSet StateNum 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 } StateNum -> Nfa2DfaM m StateNum forall (f :: * -> *) a. Applicative f => a -> f a pure StateNum dfaSn nfa2DfaM :: NFA.NFA m -> Nfa2DfaM m () nfa2DfaM :: 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 <- [(StateNum, StartState)] -> ((StateNum, StartState) -> StateT (Nfa2DfaContext m) Identity (StateNum, StateSet)) -> StateT (Nfa2DfaContext m) Identity [(StateNum, StateSet)] 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 <- StateSet -> Nfa2DfaM m StateNum forall m. StateSet -> Nfa2DfaM m StateNum registerNewState StateSet nfaSs DFABuilder m () -> Nfa2DfaM m () forall m a. DFABuilder m a -> Nfa2DfaM m a liftBuilderOp do StateNum -> StartState -> DFABuilder m () forall m. StateNum -> StartState -> DFABuilder m () DFA.initial StateNum dfaSn StartState s (StateNum, StateSet) -> StateT (Nfa2DfaContext m) Identity (StateNum, StateSet) 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 StateArray (NFAState m) -> StateNum -> NFAState m forall a. StateArray a -> StateNum -> a `MState.indexArray` StateNum nfaSn in [StateNum] -> StateSet MState.listToSet do NFAState m -> [StateNum] 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 StateArray (NFAState m) -> StateNum -> NFAState m forall a. StateArray a -> StateNum -> a `MState.indexArray` StateNum nfaSn0 in (StateSet -> StateNum -> StateSet) -> StateSet -> [StateNum] -> StateSet 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 NFAState m -> [StateNum] forall a. NFAState a -> [StateNum] NFA.nstEpsilonTrans NFAState m nfaState0 buildStateMap :: [(StateNum, StateSet)] -> Nfa2DfaM m () buildStateMap = \case [] -> () -> Nfa2DfaM m () 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 DFABuilder m () -> Nfa2DfaM m () forall m a. DFABuilder m a -> Nfa2DfaM m a liftBuilderOp do StateNum -> DFAState m -> DFABuilder m () 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) <- ((EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet) -> StateNum -> StateT (Nfa2DfaContext m) Identity (EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet)) -> (EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet) -> [StateNum] -> StateT (Nfa2DfaContext m) Identity (EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet) 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 StateArray (NFAState m) -> StateNum -> NFAState m forall a. StateArray a -> StateNum -> a `MState.indexArray` StateNum nfaSn accs' :: EnumMap AcceptPriority (Accept m) accs' = (EnumMap AcceptPriority (Accept m) -> Accept m -> EnumMap AcceptPriority (Accept m)) -> EnumMap AcceptPriority (Accept m) -> [Accept m] -> EnumMap AcceptPriority (Accept m) forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' do \EnumMap AcceptPriority (Accept m) m Accept m acc -> AcceptPriority -> Accept m -> EnumMap AcceptPriority (Accept m) -> EnumMap AcceptPriority (Accept m) forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a EnumMap.insert do Accept m -> AcceptPriority 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 NFAState m -> [Accept m] forall a. NFAState a -> [Accept a] NFA.nstAccepts NFAState m nfaState (EnumMap Key StateSet trans', StateSet otherTrans') = ((EnumMap Key StateSet, StateSet) -> NFAStateTrans -> (EnumMap Key StateSet, StateSet)) -> (EnumMap Key StateSet, StateSet) -> [NFAStateTrans] -> (EnumMap Key StateSet, StateSet) 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 NFAState m -> [NFAStateTrans] forall a. NFAState a -> [NFAStateTrans] NFA.nstTrans NFAState m nfaState in (EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet) -> StateT (Nfa2DfaContext m) Identity (EnumMap AcceptPriority (Accept m), EnumMap Key StateSet, StateSet) forall (f :: * -> *) a. Applicative f => a -> f a pure (EnumMap AcceptPriority (Accept m) accs', EnumMap Key StateSet trans', StateSet otherTrans') do (EnumMap AcceptPriority (Accept m) forall k a. EnumMap k a EnumMap.empty, EnumMap Key StateSet 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 <- StateT (Nfa2DfaContext m) Identity (Nfa2DfaContext m) forall (m :: * -> *) s. Monad m => StateT s m s get let stateMap :: HashMap StateSet StateNum stateMap = Nfa2DfaContext m -> HashMap StateSet StateNum forall m. Nfa2DfaContext m -> HashMap StateSet StateNum nfa2DfaCtxStateMap Nfa2DfaContext m ctx0 case StateSet -> HashMap StateSet StateNum -> Maybe StateNum 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 -> ([(StateNum, StateSet)], StateNum) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) forall (f :: * -> *) a. Applicative f => a -> f a pure ([(StateNum, StateSet)] rest, StateNum dfaSn) Maybe StateNum Nothing -> do StateNum dfaSn <- StateSet -> Nfa2DfaM m StateNum forall m. StateSet -> Nfa2DfaM m StateNum registerNewState StateSet nfaSs ([(StateNum, StateSet)], StateNum) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) forall (f :: * -> *) a. Applicative f => a -> f a pure ((StateNum dfaSn, StateSet nfaSs)(StateNum, StateSet) -> [(StateNum, StateSet)] -> [(StateNum, StateSet)] forall a. a -> [a] -> [a] :[(StateNum, StateSet)] rest, StateNum dfaSn) ([(StateNum, StateSet)] rest1, IntMap StateNum trans2) <- (([(StateNum, StateSet)], IntMap StateNum) -> (Key, StateSet) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], IntMap StateNum)) -> ([(StateNum, StateSet)], IntMap StateNum) -> [(Key, StateSet)] -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], IntMap StateNum) 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) <- StateSet -> [(StateNum, StateSet)] -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) forall m. StateSet -> [(StateNum, StateSet)] -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) getOrRegisterNfaSs StateSet nfaSs [(StateNum, StateSet)] rest ([(StateNum, StateSet)], IntMap StateNum) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], IntMap StateNum) forall (f :: * -> *) a. Applicative f => a -> f a pure ([(StateNum, StateSet)] rest', Key -> StateNum -> IntMap StateNum -> IntMap StateNum forall a. Key -> a -> IntMap a -> IntMap a IntMap.insert (Key -> Key forall a. Enum a => a -> Key fromEnum Key c) StateNum dfaSn IntMap StateNum trans) do ([(StateNum, StateSet)] rest0, IntMap StateNum forall a. IntMap a IntMap.empty) do EnumMap Key StateSet -> [(Key, StateSet)] 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 -> ([(StateNum, StateSet)], Maybe StateNum) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], Maybe StateNum) forall (f :: * -> *) a. Applicative f => a -> f a pure ([(StateNum, StateSet)] rest1, Maybe StateNum forall a. Maybe a Nothing) Bool False -> do ([(StateNum, StateSet)] rest, StateNum dfaSn) <- StateSet -> [(StateNum, StateSet)] -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) forall m. StateSet -> [(StateNum, StateSet)] -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], StateNum) getOrRegisterNfaSs StateSet otherTrans1 [(StateNum, StateSet)] rest1 ([(StateNum, StateSet)], Maybe StateNum) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], Maybe StateNum) forall (f :: * -> *) a. Applicative f => a -> f a pure ([(StateNum, StateSet)] rest, StateNum -> Maybe StateNum forall a. a -> Maybe a Just StateNum dfaSn) ([(StateNum, StateSet)], DFAState m) -> StateT (Nfa2DfaContext m) Identity ([(StateNum, StateSet)], DFAState m) forall (f :: * -> *) a. Applicative f => a -> f a pure ( [(StateNum, StateSet)] rest2 , DState :: forall a. [Accept a] -> IntMap StateNum -> Maybe StateNum -> DFAState a DFA.DState { $sel:dstAccepts:DState :: [Accept m] dstAccepts = [ Accept m acc | (AcceptPriority _, Accept m acc) <- EnumMap AcceptPriority (Accept m) -> [(AcceptPriority, Accept m)] 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 = (EnumMap Key StateSet -> Key -> EnumMap Key StateSet) -> EnumMap Key StateSet -> IntSet -> EnumMap Key StateSet forall a. (a -> Key -> a) -> a -> IntSet -> a IntSet.foldl' do \EnumMap Key StateSet trans Key c -> (Maybe StateSet -> Maybe StateSet) -> Key -> EnumMap Key StateSet -> EnumMap Key StateSet forall k a. Enum k => (Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a EnumMap.alter do \case Maybe StateSet Nothing -> StateSet -> Maybe StateSet forall a. a -> Maybe a Just StateSet newTrans Just StateSet ss -> StateSet -> Maybe StateSet 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) = ((EnumMap Key StateSet, EnumMap Key StateSet) -> Key -> (EnumMap Key StateSet, EnumMap Key StateSet)) -> (EnumMap Key StateSet, EnumMap Key StateSet) -> IntSet -> (EnumMap Key StateSet, EnumMap Key StateSet) forall a. (a -> Key -> a) -> a -> IntSet -> a IntSet.foldl' do \(EnumMap Key StateSet diffTrans, EnumMap Key StateSet trans) Key c -> ( Key -> EnumMap Key StateSet -> EnumMap Key StateSet forall k a. Enum k => k -> EnumMap k a -> EnumMap k a EnumMap.delete Key c EnumMap Key StateSet diffTrans , (Maybe StateSet -> Maybe StateSet) -> Key -> EnumMap Key StateSet -> EnumMap Key StateSet forall k a. Enum k => (Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a EnumMap.alter do \case Maybe StateSet Nothing -> StateSet -> Maybe StateSet forall a. a -> Maybe a Just StateSet MState.emptySet Just StateSet ss -> StateSet -> Maybe StateSet 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 = (EnumMap Key StateSet -> Key -> StateSet -> EnumMap Key StateSet) -> EnumMap Key StateSet -> EnumMap Key StateSet -> EnumMap Key StateSet 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 -> Key -> StateSet -> EnumMap Key StateSet -> EnumMap Key StateSet 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)