tlex-core (empty) → 0.1.0.0
raw patch · 21 files changed
+1633/−0 lines, 21 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed
Dependencies added: QuickCheck, array, base, containers, doctest, hashable, hspec, tlex-core, transformers, unordered-containers
Files
- CHANGELOG.md +3/−0
- LICENSE +5/−0
- README.md +1/−0
- Setup.hs +6/−0
- src/Language/Lexer/Tlex/Data/Bag.hs +45/−0
- src/Language/Lexer/Tlex/Data/EnumMap.hs +103/−0
- src/Language/Lexer/Tlex/Data/EnumSet.hs +61/−0
- src/Language/Lexer/Tlex/Data/Graph.hs +13/−0
- src/Language/Lexer/Tlex/Data/SymEnumSet.hs +142/−0
- src/Language/Lexer/Tlex/Machine/DFA.hs +100/−0
- src/Language/Lexer/Tlex/Machine/NFA.hs +146/−0
- src/Language/Lexer/Tlex/Machine/Pattern.hs +67/−0
- src/Language/Lexer/Tlex/Machine/State.hs +144/−0
- src/Language/Lexer/Tlex/Pipeline/MinDfa.hs +362/−0
- src/Language/Lexer/Tlex/Pipeline/Nfa2Dfa.hs +159/−0
- src/Language/Lexer/Tlex/Pipeline/Pattern2Nfa.hs +40/−0
- src/Language/Lexer/Tlex/Prelude.hs +5/−0
- src/Language/Lexer/Tlex/Prelude/Core.hs +40/−0
- test/doctest/Doctest.hs +21/−0
- test/spec/HSpecDriver.hs +1/−0
- tlex-core.cabal +169/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1.0.0 -- 2021-01-XX++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,5 @@+Apache-2.0 OR MPL-2.0++---++See https://github.com/mizunashi-mana/tlex/blob/master/LICENSE
+ README.md view
@@ -0,0 +1,1 @@+See https://hackage.haskell.org/package/tlex
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctest"
+ src/Language/Lexer/Tlex/Data/Bag.hs view
@@ -0,0 +1,45 @@+module Language.Lexer.Tlex.Data.Bag (+ Bag,+ fromList,+ singleton,+) where++import Language.Lexer.Tlex.Prelude+++data Bag a+ = EmptyBag+ | UnitBag a+ | IncludeBags (Bag a) (Bag a)+ | ListBag [a]+ deriving (Show, Functor)++instance Foldable Bag where+ foldr k z = \case+ EmptyBag -> z+ UnitBag x -> k x z+ IncludeBags b1 b2 -> foldr k (foldr k z b2) b1+ ListBag xs -> foldr k z xs++ foldMap f = \case+ EmptyBag -> mempty+ UnitBag x -> f x+ IncludeBags b1 b2 -> foldMap f b1 <> foldMap f b2+ ListBag xs -> foldMap f xs++instance Eq a => Eq (Bag a) where+ b1 == b2 = toList b1 == toList b2++instance Semigroup (Bag a) where+ EmptyBag <> b2 = b2+ b1 <> EmptyBag = b1+ b1 <> b2 = IncludeBags b1 b2++instance Monoid (Bag a) where+ mempty = EmptyBag++fromList :: [a] -> Bag a+fromList xs = ListBag xs++singleton :: a -> Bag a+singleton x = UnitBag x
+ src/Language/Lexer/Tlex/Data/EnumMap.hs view
@@ -0,0 +1,103 @@+module Language.Lexer.Tlex.Data.EnumMap (+ EnumMap,+ empty,+ insert,+ assocs,+ keys,+ toAscList,+ toDescList,+ lookup,+ member,+ insertOrUpdate,+ fromList,+ foldlWithKey',+ update,+ delete,+ singleton,+ unionWith,+ intersectionWith,+ mapWithKey,+ mergeWithKey,+) where++import Prelude hiding (lookup)++import qualified Data.Coerce as Coerce+import qualified Data.IntMap.Strict as IntMap+++newtype EnumMap k a = EnumMap+ { unEnumMap :: IntMap.IntMap a+ }+ deriving (Eq, Show, Functor)++empty :: Enum k => EnumMap k a+empty = EnumMap IntMap.empty++singleton :: Enum k => k -> a -> EnumMap k a+singleton k x = EnumMap do IntMap.singleton (fromEnum k) x++insert :: Enum k => k -> a -> EnumMap k a -> EnumMap k a+insert k x (EnumMap m) = EnumMap do IntMap.insert (fromEnum k) x m++assocs :: Enum k => EnumMap k a -> [(k, a)]+assocs (EnumMap m) = [ (toEnum i, x) | (i, x) <- IntMap.assocs m ]++keys :: Enum k => EnumMap k a -> [k]+keys (EnumMap m) = [ toEnum k | k <- IntMap.keys m ]++toAscList :: Enum k => EnumMap k a -> [(k, a)]+toAscList (EnumMap m) = [ (toEnum i, x) | (i, x) <- IntMap.toAscList m ]++toDescList :: Enum k => EnumMap k a -> [(k, a)]+toDescList (EnumMap m) = [ (toEnum i, x) | (i, x) <- IntMap.toDescList m ]++lookup :: Enum k => k -> EnumMap k a -> Maybe a+lookup k (EnumMap m) = IntMap.lookup (fromEnum k) m++member :: Enum k => k -> EnumMap k a -> Bool+member k (EnumMap m) = IntMap.member (fromEnum k) m++insertOrUpdate :: Enum k => k -> a -> (a -> a) -> EnumMap k a -> EnumMap k a+insertOrUpdate k ~dx ~uf (EnumMap m) =+ let ik = fromEnum k+ in EnumMap case IntMap.lookup ik m of+ Nothing -> IntMap.insert ik dx m+ Just x -> IntMap.insert ik (uf x) m++fromList :: Enum k => [(k, a)] -> EnumMap k a+fromList xs = EnumMap do IntMap.fromList [ (fromEnum i, x) | (i, x) <- xs ]++delete :: Enum k => k -> EnumMap k a -> EnumMap k a+delete k (EnumMap m) = EnumMap do IntMap.delete (fromEnum k) m++foldlWithKey' :: Enum k => (b -> k -> a -> b) -> b -> EnumMap k a -> b+foldlWithKey' f acc0 (EnumMap m) = IntMap.foldlWithKey' (\acc i x -> f acc (toEnum i) x) acc0 m++update :: Enum k => (a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a+update f k (EnumMap m) = EnumMap do IntMap.update f (fromEnum k) m++unionWith :: Enum k => (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a+unionWith f (EnumMap m1) (EnumMap m2) = EnumMap do IntMap.unionWith f m1 m2++intersectionWith :: Enum k => (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a+intersectionWith f (EnumMap m1) (EnumMap m2) = EnumMap do IntMap.intersectionWith f m1 m2++mapWithKey :: Enum k => (k -> a -> b) -> EnumMap k a -> EnumMap k b+mapWithKey f (EnumMap m) = EnumMap do+ IntMap.mapWithKey+ do \i x -> f (toEnum i) x+ do m++mergeWithKey :: Enum k+ => (k -> a -> b -> Maybe c)+ -> (EnumMap k a -> EnumMap k c)+ -> (EnumMap k b -> EnumMap k c)+ -> EnumMap k a -> EnumMap k b -> EnumMap k c+mergeWithKey f g1 g2 (EnumMap m1) (EnumMap m2) = EnumMap do+ IntMap.mergeWithKey+ do \i x y -> f (toEnum i) x y+ do \m -> Coerce.coerce g1 m+ do \m -> Coerce.coerce g2 m+ do m1+ do m2
+ src/Language/Lexer/Tlex/Data/EnumSet.hs view
@@ -0,0 +1,61 @@+module Language.Lexer.Tlex.Data.EnumSet (+ EnumSet,+ empty,+ singleton,+ insert,+ union,+ intersection,+ difference,+ partition,+ fromList,+ toList,+ toIntSet,+) where++import Language.Lexer.Tlex.Prelude hiding (empty, toList)++import qualified Data.Hashable as Hashable+import qualified Data.IntSet as IntSet+++newtype EnumSet a = EnumSet IntSet.IntSet+ deriving (Eq, Show)++instance Hashable.Hashable (EnumSet a) where+ hashWithSalt s (EnumSet x) = Hashable.hashWithSalt s do IntSet.toAscList x++empty :: Enum a => EnumSet a+empty = EnumSet IntSet.empty++singleton :: Enum a => a -> EnumSet a+singleton x = EnumSet do IntSet.singleton do fromEnum x++insert :: Enum a => a -> EnumSet a -> EnumSet a+insert x (EnumSet s) = EnumSet+ do IntSet.insert+ do fromEnum x+ do s++union :: Enum a => EnumSet a -> EnumSet a -> EnumSet a+union (EnumSet s1) (EnumSet s2) = EnumSet do IntSet.union s1 s2++intersection :: Enum a => EnumSet a -> EnumSet a -> EnumSet a+intersection (EnumSet s1) (EnumSet s2) = EnumSet do IntSet.intersection s1 s2++difference :: Enum a => EnumSet a -> EnumSet a -> EnumSet a+difference (EnumSet s1) (EnumSet s2) = EnumSet do IntSet.difference s1 s2++partition :: Enum a => (a -> Bool) -> EnumSet a -> (EnumSet a, EnumSet a)+partition p (EnumSet s) = coerce+ do IntSet.partition+ do \i -> p do toEnum i+ s++fromList :: Enum a => [a] -> EnumSet a+fromList xs = EnumSet do IntSet.fromList [ fromEnum x | x <- xs ]++toList :: Enum a => EnumSet a -> [a]+toList (EnumSet xs) = [ toEnum x | x <- IntSet.toList xs ]++toIntSet :: Enum a => EnumSet a -> IntSet.IntSet+toIntSet (EnumSet m) = m
+ src/Language/Lexer/Tlex/Data/Graph.hs view
@@ -0,0 +1,13 @@+module Language.Lexer.Tlex.Data.Graph (+ transClosure,+) where++import qualified Data.Array as Array+import Data.Foldable+import qualified Data.Graph as Graph++transClosure :: Graph.Graph -> Graph.Graph+transClosure gr = Array.listArray r [ goDfs v | v <- Graph.vertices gr ] where+ r = Array.bounds gr++ goDfs v = foldMap (\t -> toList t) do Graph.dfs gr [v]
+ src/Language/Lexer/Tlex/Data/SymEnumSet.hs view
@@ -0,0 +1,142 @@+module Language.Lexer.Tlex.Data.SymEnumSet (+ SymEnumSet,+ empty,+ full,+ complement,+ singleton,+ union,+ intersection,+ difference,+ fromEnumSet,+ toEnumSet,+) where++import Prelude++import qualified Language.Lexer.Tlex.Data.EnumSet as EnumSet+++data SymEnumSet a = SymEnumSet+ { isStraight :: Bool+ , internalEnumSet :: EnumSet.EnumSet a+ }+ deriving (Eq, Show)++empty :: Enum a => SymEnumSet a+empty = SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.empty+ }++full :: Enum a => SymEnumSet a+full = SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.empty+ }++complement :: Enum a => SymEnumSet a -> SymEnumSet a+complement s = s+ { isStraight = not do isStraight s+ }++singleton :: Enum a => a -> SymEnumSet a+singleton x = SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.singleton x+ }++union :: Enum a => SymEnumSet a -> SymEnumSet a -> SymEnumSet a+union s1 s2 = case isStraight s1 of+ True -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.union+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s2+ do internalEnumSet s1+ }+ False -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.intersection+ do internalEnumSet s1+ do internalEnumSet s2+ }++intersection :: Enum a => SymEnumSet a -> SymEnumSet a -> SymEnumSet a+intersection s1 s2 = case isStraight s1 of+ True -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.intersection+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s2+ do internalEnumSet s1+ }+ False -> SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.union+ do internalEnumSet s1+ do internalEnumSet s2+ }++difference :: Enum a => SymEnumSet a -> SymEnumSet a -> SymEnumSet a+difference s1 s2 = case isStraight s1 of+ True -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.intersection+ do internalEnumSet s1+ do internalEnumSet s2+ }+ False -> case isStraight s2 of+ True -> SymEnumSet+ { isStraight = False+ , internalEnumSet = EnumSet.union+ do internalEnumSet s2+ do internalEnumSet s1+ }+ False -> SymEnumSet+ { isStraight = True+ , internalEnumSet = EnumSet.difference+ do internalEnumSet s2+ do internalEnumSet s1+ }++fromEnumSet :: Enum a => Bool -> EnumSet.EnumSet a -> SymEnumSet a+fromEnumSet b s = SymEnumSet+ { isStraight = b+ , internalEnumSet = s+ }++toEnumSet :: Enum a => SymEnumSet a -> (Bool, EnumSet.EnumSet a)+toEnumSet s = (isStraight s, internalEnumSet s)
+ src/Language/Lexer/Tlex/Machine/DFA.hs view
@@ -0,0 +1,100 @@+module Language.Lexer.Tlex.Machine.DFA (+ DFA (..),+ DFAState (..),+ DFABuilder,+ DFABuilderContext,+ buildDFA,+ newStateNum,+ insertTrans,+ accept,+ initial,+) where++import Language.Lexer.Tlex.Prelude++import qualified Data.IntMap as IntMap+import qualified Data.List as List+import qualified Language.Lexer.Tlex.Data.EnumMap as EnumMap+import qualified Language.Lexer.Tlex.Machine.Pattern as Pattern+import qualified Language.Lexer.Tlex.Machine.State as MState+++data DFA a = DFA+ { dfaInitials :: EnumMap.EnumMap Pattern.StartState MState.StateNum+ , dfaTrans :: MState.StateArray (DFAState a)+ }+ deriving (Eq, Show, Functor)++data DFAState a = DState+ { dstAccepts :: [Pattern.Accept a]+ , dstTrans :: IntMap.IntMap MState.StateNum+ , dstOtherTrans :: Maybe MState.StateNum+ }+ deriving (Eq, Show, Functor)+++data DFABuilderContext m = DFABuilderContext+ { dfaBCtxInitials :: EnumMap.EnumMap Pattern.StartState MState.StateNum+ , dfaBCtxNextStateNum :: MState.StateNum+ , dfaBCtxStateMap :: MState.StateMap (DFAState m)+ }+ deriving (Eq, Show, Functor)++type DFABuilder m = State (DFABuilderContext m)++buildDFA :: DFABuilder m () -> DFA m+buildDFA builder =+ let bctx = execState builder initialBCtx+ arr = MState.totalStateMapToArray+ do dfaBCtxNextStateNum bctx+ do dfaBCtxStateMap bctx+ in DFA+ { dfaInitials = dfaBCtxInitials bctx+ , dfaTrans = arr+ }+ where+ initialBCtx = DFABuilderContext+ { dfaBCtxInitials = EnumMap.empty+ , dfaBCtxNextStateNum = MState.initialStateNum+ , dfaBCtxStateMap = MState.emptyMap+ }++newStateNum :: DFABuilder m MState.StateNum+newStateNum = do+ ctx0 <- get+ let nextStateNum = dfaBCtxNextStateNum ctx0+ put do ctx0+ { dfaBCtxNextStateNum = succ nextStateNum+ }+ pure nextStateNum++insertTrans :: MState.StateNum -> DFAState m -> DFABuilder m ()+insertTrans sf st = modify' \ctx0@DFABuilderContext{ dfaBCtxStateMap } -> ctx0+ { dfaBCtxStateMap = addCondTrans dfaBCtxStateMap+ }+ where+ addCondTrans n = MState.insertMap sf st n++accept :: MState.StateNum -> Pattern.Accept m -> DFABuilder m ()+accept s x = modify' \ctx0@DFABuilderContext{ dfaBCtxStateMap } -> ctx0+ { dfaBCtxStateMap = addAccept dfaBCtxStateMap+ }+ where+ addAccept n = MState.insertOrUpdateMap s+ do DState+ { dstAccepts = [x]+ , dstTrans = IntMap.empty+ , dstOtherTrans = Nothing+ }+ do \ds@DState { dstAccepts } -> ds+ { dstAccepts = List.insertBy+ Pattern.compareAcceptsByPriority+ x+ dstAccepts+ }+ do n++initial :: MState.StateNum -> Pattern.StartState -> DFABuilder m ()+initial s x = modify' \ctx0@DFABuilderContext{ dfaBCtxInitials } -> ctx0+ { dfaBCtxInitials = EnumMap.insert x s dfaBCtxInitials+ }
+ src/Language/Lexer/Tlex/Machine/NFA.hs view
@@ -0,0 +1,146 @@+module Language.Lexer.Tlex.Machine.NFA+ (+ NFA (..),+ NFAState(..),+ NFAStateTrans(..),+ NFABuilder,+ NFABuilderContext,+ buildNFA,+ epsilonClosed,+ newStateNum,+ epsilonTrans,+ condTrans,+ accept,+ initial,+ ) where++import Language.Lexer.Tlex.Prelude++import qualified Data.IntSet as IntSet+import qualified Language.Lexer.Tlex.Data.Graph as Graph+import qualified Language.Lexer.Tlex.Machine.Pattern as Pattern+import qualified Language.Lexer.Tlex.Machine.State as MState+++data NFA a = NFA+ { nfaInitials :: [(MState.StateNum, Pattern.StartState)]+ , nfaTrans :: MState.StateArray (NFAState a)+ }+ deriving (Eq, Show, Functor)++data NFAState a = NState+ { nstAccepts :: [Pattern.Accept a]+ , nstEpsilonTrans :: [MState.StateNum]+ , nstTrans :: [NFAStateTrans]+ }+ deriving (Eq, Show, Functor)++data NFAStateTrans = NFAStateTrans+ { nstTransIsStraight :: Bool+ , nstTransRange :: IntSet.IntSet+ , nstTransNextState :: MState.StateNum+ }+ deriving (Eq, Show)++epsilonClosed :: NFA a -> NFA a+epsilonClosed nfa@NFA{ nfaTrans } = nfa+ { nfaTrans = MState.mapArrayWithIx go nfaTrans+ }+ where+ go v s = s+ { nstEpsilonTrans = gr `MState.indexGraph` v+ }++ gr = MState.liftGraphOp Graph.transClosure+ do MState.stateArrayToGraph do fmap nstEpsilonTrans nfaTrans+++data NFABuilderContext m = NFABuilderContext+ { nfaBCtxInitials :: [(MState.StateNum, Pattern.StartState)]+ , nfaBCtxNextStateNum :: MState.StateNum+ , nfaBCtxStateMap :: MState.StateMap (NFAState m)+ }++type NFABuilder m = State (NFABuilderContext m)++buildNFA :: NFABuilder m () -> NFA m+buildNFA builder =+ let bctx = execState builder initialBCtx+ arr = MState.totalStateMapToArray+ do nfaBCtxNextStateNum bctx+ do nfaBCtxStateMap bctx+ in epsilonClosed+ do NFA+ { nfaInitials = nfaBCtxInitials bctx+ , nfaTrans = arr+ }+ where+ initialBCtx = NFABuilderContext+ { nfaBCtxInitials = []+ , nfaBCtxNextStateNum = MState.initialStateNum+ , nfaBCtxStateMap = MState.emptyMap+ }++newStateNum :: NFABuilder m MState.StateNum+newStateNum = do+ ctx0 <- get+ let nextStateNum = nfaBCtxNextStateNum ctx0+ put do ctx0+ { nfaBCtxNextStateNum = succ nextStateNum+ }+ pure nextStateNum++epsilonTrans :: MState.StateNum -> MState.StateNum -> NFABuilder m ()+epsilonTrans sf st+ | sf == st = pure ()+ | otherwise = modify' \ctx0@NFABuilderContext{ nfaBCtxStateMap } -> ctx0+ { nfaBCtxStateMap = addEpsTrans nfaBCtxStateMap+ }+ where+ addEpsTrans n = MState.insertOrUpdateMap sf+ do NState+ { nstAccepts = []+ , nstEpsilonTrans = [st]+ , nstTrans = []+ }+ do \s@NState{ nstEpsilonTrans } -> s+ { nstEpsilonTrans = st:nstEpsilonTrans+ }+ do n++condTrans :: MState.StateNum -> NFAStateTrans -> NFABuilder m ()+condTrans sf st = modify' \ctx0@NFABuilderContext{ nfaBCtxStateMap } -> ctx0+ { nfaBCtxStateMap = addCondTrans nfaBCtxStateMap+ }+ where+ addCondTrans n = MState.insertOrUpdateMap sf+ do NState+ { nstAccepts = []+ , nstEpsilonTrans = []+ , nstTrans = [st]+ }+ do \s@NState{ nstTrans } -> s+ { nstTrans = st:nstTrans+ }+ do n++accept :: MState.StateNum -> Pattern.Accept m -> NFABuilder m ()+accept s x = modify' \ctx0@NFABuilderContext{ nfaBCtxStateMap } -> ctx0+ { nfaBCtxStateMap = addAccept nfaBCtxStateMap+ }+ where+ addAccept n = MState.insertOrUpdateMap s+ do NState+ { nstAccepts = [x]+ , nstEpsilonTrans = []+ , nstTrans = []+ }+ do \ns@NState{ nstAccepts } -> ns+ { nstAccepts = x:nstAccepts+ }+ do n++initial :: MState.StateNum -> Pattern.StartState -> NFABuilder m ()+initial s x = modify' \ctx0@NFABuilderContext{ nfaBCtxInitials } -> ctx0+ { nfaBCtxInitials = (s, x):nfaBCtxInitials+ }
+ src/Language/Lexer/Tlex/Machine/Pattern.hs view
@@ -0,0 +1,67 @@+module Language.Lexer.Tlex.Machine.Pattern (+ Pattern (..),+ enumsP,+ straightEnumSetP,+ anyoneP,+ AcceptPriority (..),+ mostPriority,+ Accept (..),+ compareAcceptsByPriority,+ StartState (..),+ startStateFromEnum,+) where++import Language.Lexer.Tlex.Prelude++import qualified Data.Hashable as Hashable+import qualified Language.Lexer.Tlex.Data.EnumSet as EnumSet+import qualified Language.Lexer.Tlex.Data.SymEnumSet as SymEnumSet+++newtype StartState = StartState Int+ deriving (Eq, Show)+ deriving Enum via Int++startStateFromEnum :: Enum s => s -> StartState+startStateFromEnum x = StartState do fromEnum x+++newtype AcceptPriority = AcceptPriority Int+ deriving (Eq, Show)+ deriving Ord via Down Int+ deriving (Hashable.Hashable, Enum) via Int++mostPriority :: AcceptPriority+mostPriority = AcceptPriority 0++data Accept a = Accept+ { accPriority :: AcceptPriority+ , accSemanticAction :: a+ }+ deriving (Eq, Show, Functor)++compareAcceptsByPriority :: Accept a -> Accept a -> Ordering+compareAcceptsByPriority Accept{ accPriority = p1 } Accept{ accPriority = p2 } = p1 `compare` p2++data Pattern e+ = Epsilon+ | Pattern e :^: Pattern e+ | Pattern e :|: Pattern e+ | Many (Pattern e)+ | Range (SymEnumSet.SymEnumSet e)+ deriving (Eq, Show)++instance Enum e => Semigroup (Pattern e) where+ (<>) = (:^:)++instance Enum e => Monoid (Pattern e) where+ mempty = Epsilon++enumsP :: Enum e => [e] -> Pattern e+enumsP l = straightEnumSetP do EnumSet.fromList l++straightEnumSetP :: Enum e => EnumSet.EnumSet e -> Pattern e+straightEnumSetP s = Range do SymEnumSet.fromEnumSet True s++anyoneP :: Enum e => Pattern e+anyoneP = Range SymEnumSet.full
+ src/Language/Lexer/Tlex/Machine/State.hs view
@@ -0,0 +1,144 @@+module Language.Lexer.Tlex.Machine.State (+ StateNum,+ initialStateNum,++ StateSet,+ emptySet,+ singletonSet,+ listToSet,+ setToList,+ nullSet,+ insertSet,+ intersectSet,+ diffSet,+ unionSet,+ lengthSet,+ memberSet,++ StateMap,+ emptyMap,+ insertOrUpdateMap,+ insertMap,+ lookupMap,+ assocsMap,++ StateArray,+ totalStateMapToArray,+ mapArrayWithIx,+ indexArray,+ arrayAssocs,++ StateGraph,+ stateArrayToGraph,+ liftGraphOp,+ indexGraph,+) where++import Language.Lexer.Tlex.Prelude++import qualified Data.Array as Array+import qualified Data.Graph as Graph+import qualified Data.Hashable as Hashable+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+++newtype StateNum = StateNum Int+ deriving (Eq, Ord, Show, Ix)+ deriving (Hashable.Hashable, Enum) via Int++initialStateNum :: StateNum+initialStateNum = StateNum 0+++newtype StateSet = StateSet IntSet.IntSet+ deriving (Eq, Show)++instance Hashable.Hashable StateSet where+ hashWithSalt s (StateSet x) = Hashable.hashWithSalt s do IntSet.toAscList x++emptySet :: StateSet+emptySet = StateSet IntSet.empty++singletonSet :: StateNum -> StateSet+singletonSet (StateNum s) = StateSet do IntSet.singleton s++insertSet :: StateNum -> StateSet -> StateSet+insertSet (StateNum s) (StateSet ss) = StateSet do IntSet.insert s ss++listToSet :: [StateNum] -> StateSet+listToSet ss = StateSet do IntSet.fromList do coerce ss++setToList :: StateSet -> [StateNum]+setToList (StateSet ss) = coerce do IntSet.toList ss++nullSet :: StateSet -> Bool+nullSet (StateSet ss) = IntSet.null ss++intersectSet :: StateSet -> StateSet -> StateSet+intersectSet (StateSet ss1) (StateSet ss2) = StateSet do IntSet.intersection ss1 ss2++diffSet :: StateSet -> StateSet -> StateSet+diffSet (StateSet ss1) (StateSet ss2) = StateSet do IntSet.difference ss1 ss2++unionSet :: StateSet -> StateSet -> StateSet+unionSet (StateSet ss1) (StateSet ss2) = StateSet do IntSet.union ss1 ss2++lengthSet :: StateSet -> Int+lengthSet (StateSet ss) = IntSet.size ss++memberSet :: StateNum -> StateSet -> Bool+memberSet (StateNum s) (StateSet ss) = IntSet.member s ss+++newtype StateMap a = StateMap (IntMap.IntMap a)+ deriving (Eq, Show, Functor)++emptyMap :: StateMap a+emptyMap = StateMap IntMap.empty++insertMap :: StateNum -> a -> StateMap a -> StateMap a+insertMap (StateNum k) x (StateMap m) = StateMap do IntMap.insert k x m++insertOrUpdateMap :: StateNum -> a -> (a -> a) -> StateMap a -> StateMap a+insertOrUpdateMap (StateNum k) ~dx ~uf (StateMap m) = StateMap case IntMap.lookup k m of+ Nothing -> IntMap.insert k dx m+ Just x -> IntMap.insert k (uf x) m++lookupMap :: StateNum -> StateMap a -> Maybe a+lookupMap (StateNum sn) (StateMap m) = IntMap.lookup sn m++assocsMap :: StateMap a -> [(StateNum, a)]+assocsMap (StateMap m) = coerce do IntMap.assocs m+++newtype StateArray a = StateArray (Array.Array Int a)+ deriving (Eq, Show, Functor, Foldable)++totalStateMapToArray :: StateNum -> StateMap a -> StateArray a+totalStateMapToArray (StateNum boundState) (StateMap m) = StateArray+ do Array.array (0, pred boundState) do IntMap.toAscList m++mapArrayWithIx :: (StateNum -> a -> a) -> StateArray a -> StateArray a+mapArrayWithIx f (StateArray arr) = StateArray+ do Array.listArray+ do Array.bounds arr+ do [ f (StateNum i) x | (i, x) <- Array.assocs arr ]++indexArray :: StateArray a -> StateNum -> a+indexArray (StateArray arr) (StateNum i) = arr Array.! i++arrayAssocs :: StateArray a -> [(StateNum, a)]+arrayAssocs (StateArray arr) = coerce do Array.assocs arr+++newtype StateGraph = StateGraph Graph.Graph++stateArrayToGraph :: StateArray [StateNum] -> StateGraph+stateArrayToGraph (StateArray m) = StateGraph do coerce m++liftGraphOp :: (Graph.Graph -> Graph.Graph) -> StateGraph -> StateGraph+liftGraphOp f x = coerce f x++indexGraph :: StateGraph -> StateNum -> [StateNum]+indexGraph (StateGraph x) (StateNum i) = coerce do x Array.! i
+ src/Language/Lexer/Tlex/Pipeline/MinDfa.hs view
@@ -0,0 +1,362 @@+module Language.Lexer.Tlex.Pipeline.MinDfa (+ minDfa,+) where++import Language.Lexer.Tlex.Prelude++import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.IntMap.Strict as IntMap+import qualified Language.Lexer.Tlex.Data.EnumMap as EnumMap+import qualified Language.Lexer.Tlex.Machine.DFA as DFA+import qualified Language.Lexer.Tlex.Machine.Pattern as Pattern+import qualified Language.Lexer.Tlex.Machine.State as MState+++minDfa :: DFA.DFA a -> DFA.DFA a+minDfa dfa = DFA.buildDFA+ do modify' \dfaBuilderCtx0 -> minDfaCtxDFABuilderCtx+ do execState+ do minDfaM dfa+ do MinDfaContext+ { minDfaCtxStateMap = MState.emptyMap+ , minDfaCtxDFABuilderCtx = dfaBuilderCtx0+ }+++data MinDfaContext m = MinDfaContext+ { minDfaCtxStateMap :: MState.StateMap MState.StateNum+ , minDfaCtxDFABuilderCtx :: DFA.DFABuilderContext m+ }+ deriving (Eq, Show, Functor)++type MinDfaM m = State (MinDfaContext m)++liftBuilderOp :: DFA.DFABuilder m a -> MinDfaM m a+liftBuilderOp builder = do+ ctx0 <- get+ let (x, builderCtx1) = runState builder do minDfaCtxDFABuilderCtx ctx0+ put do ctx0+ { minDfaCtxDFABuilderCtx = builderCtx1+ }+ pure x++registerNewState :: MState.StateNum -> MinDfaM m MState.StateNum+registerNewState r = do+ sn <- liftBuilderOp DFA.newStateNum+ modify' \ctx0@MinDfaContext{ minDfaCtxStateMap } -> ctx0+ { minDfaCtxStateMap = MState.insertMap r sn minDfaCtxStateMap+ }+ pure sn++getOrRegisterState :: MState.StateNum -> MinDfaM m MState.StateNum+getOrRegisterState r = do+ ctx0 <- get+ case MState.lookupMap r do minDfaCtxStateMap ctx0 of+ Just sn -> pure sn+ Nothing -> registerNewState r++minDfaM :: DFA.DFA a -> MinDfaM a ()+minDfaM dfa@DFA.DFA{ dfaTrans } = do+ forM_+ do EnumMap.assocs do DFA.dfaInitials dfa+ do \(startS, sn) -> do+ newSn <- getOrRegisterStateByOldState sn+ liftBuilderOp do DFA.initial newSn startS++ forM_+ do MState.assocsMap do partitionMember p+ do \(r, ss) -> do+ newSn <- getOrRegisterState r+ newDst <- buildDFAState ss+ liftBuilderOp do DFA.insertTrans newSn newDst+ where+ p = buildPartition dfa++ getOrRegisterStateByOldState oldSn =+ let r = case MState.lookupMap oldSn do partitionMap p of+ Nothing -> error "unreachable"+ Just s -> s+ in getOrRegisterState r++ buildDFAState ss = buildDst do+ forM_+ do MState.setToList ss+ do \s -> do+ let dst = MState.indexArray dfaTrans s+ forM_+ do DFA.dstAccepts dst+ do \acc -> insertAcceptToDst acc++ forM_+ do IntMap.assocs do DFA.dstTrans dst+ do \(c, sn) -> do+ ctx0 <- get+ case IntMap.lookup c do dstBuilderCtxTrans ctx0 of+ Just{} -> pure ()+ Nothing -> do+ newSn <- liftMinDfaOp do getOrRegisterStateByOldState sn+ modify' \ctx -> ctx+ { dstBuilderCtxTrans = IntMap.insert c newSn+ do dstBuilderCtxTrans ctx+ }++ case DFA.dstOtherTrans dst of+ Nothing -> pure ()+ Just sn -> do+ ctx <- get+ case dstBuilderCtxOtherTrans ctx of+ Just{} -> pure ()+ Nothing -> do+ newSn <- liftMinDfaOp do getOrRegisterStateByOldState sn+ put do ctx+ { dstBuilderCtxOtherTrans = Just newSn+ }++data DFAStateBuilderContext a = DStateBuilderContext+ { dstBuilderCtxAccepts :: EnumMap.EnumMap Pattern.AcceptPriority (Pattern.Accept a)+ , dstBuilderCtxTrans :: IntMap.IntMap MState.StateNum+ , dstBuilderCtxOtherTrans :: Maybe MState.StateNum+ , dstBuilderCtxMinDfaCtx :: MinDfaContext a+ }+ deriving (Eq, Show, Functor)++type DFAStateBuilder a = State (DFAStateBuilderContext a)++buildDst :: DFAStateBuilder a () -> MinDfaM a (DFA.DFAState a)+buildDst builder = do+ minDfaCtx0 <- get+ let ctx = execState builder do+ DStateBuilderContext+ { dstBuilderCtxAccepts = EnumMap.empty+ , dstBuilderCtxTrans = IntMap.empty+ , dstBuilderCtxOtherTrans = Nothing+ , dstBuilderCtxMinDfaCtx = minDfaCtx0+ }+ put do dstBuilderCtxMinDfaCtx ctx+ pure DFA.DState+ { DFA.dstAccepts = [ acc | (_, acc) <- EnumMap.toDescList do dstBuilderCtxAccepts ctx ]+ , DFA.dstTrans = dstBuilderCtxTrans ctx+ , DFA.dstOtherTrans = dstBuilderCtxOtherTrans ctx+ }++liftMinDfaOp :: MinDfaM m a -> DFAStateBuilder m a+liftMinDfaOp builder = do+ ctx0 <- get+ let (x, builderCtx1) = runState builder do dstBuilderCtxMinDfaCtx ctx0+ put do ctx0+ { dstBuilderCtxMinDfaCtx = builderCtx1+ }+ pure x++insertAcceptToDst :: Pattern.Accept a -> DFAStateBuilder a ()+insertAcceptToDst acc = modify' \builder -> builder+ { dstBuilderCtxAccepts = EnumMap.insert+ do Pattern.accPriority acc+ do acc+ do dstBuilderCtxAccepts builder+ }+++data Partition = Partition+ { partitionMap :: MState.StateMap MState.StateNum+ , partitionMember :: MState.StateMap MState.StateSet+ }+ deriving (Eq, Show)++emptyPartition :: Partition+emptyPartition = Partition+ { partitionMap = MState.emptyMap+ , partitionMember = MState.emptyMap+ }++insertToPartition :: MState.StateSet -> Partition -> Partition+insertToPartition ss p0 = case MState.setToList ss of+ [] -> p0+ s0:_ -> Partition+ { partitionMap = foldl'+ do \m s -> MState.insertMap s s0 m+ do partitionMap p0+ do MState.setToList ss+ , partitionMember = MState.insertMap s0 ss+ do partitionMember p0+ }++buildPartition :: DFA.DFA a -> Partition+buildPartition dfa =+ let (p0, q0) = foldl'+ do \(p, q) (k, ss) ->+ ( insertToPartition ss p+ , case k of+ Nothing -> q+ Just{} -> HashSet.insert ss q+ )+ do (emptyPartition, HashSet.empty)+ do HashMap.toList do acceptGroup dfa+ in go p0 q0+ where+ go p0 q0 = case HashSet.toList q0 of+ [] -> p0+ a:_ ->+ let (p1, q1) = go2 a p0 do+ HashSet.delete a q0+ in go p1 q1++ go2 a p0 q0 = foldl'+ do \(p, q) x -> go3 p q x+ do (p0, q0)+ let rt = findIncomingTrans a+ in HashSet.toList do+ HashSet.fromList+ [ x+ | x <- dfaRevTransOther rt:+ [ x | (_, x) <- IntMap.assocs do dfaRevTrans rt ]+ , not do MState.nullSet x+ ]++ go3 p0 q0 x = foldl'+ do \(p, q) (sp, xy) ->+ let y = case MState.lookupMap sp do partitionMember p0 of+ Nothing -> error "unreachable"+ Just ss -> ss+ lengthY = MState.lengthSet y+ lengthXY = MState.lengthSet xy+ in if+ | lengthY == lengthXY ->+ (p, q)+ | otherwise ->+ let diffYX = MState.diffSet y xy+ splitY s1 s2 = case MState.setToList s2 of+ [] -> error "unreachable"+ sp2:_ -> Partition+ { partitionMap = foldl'+ do \m s -> MState.insertMap s sp2 m+ do partitionMap p+ do MState.setToList s2+ , partitionMember = partitionMember p+ & MState.insertMap sp s1+ & MState.insertMap sp2 s2+ }+ p' = case MState.memberSet sp xy of+ True -> splitY xy diffYX+ False -> splitY diffYX xy+ q' = case HashSet.member y q of+ True -> HashSet.delete y q+ & HashSet.insert xy+ & HashSet.insert diffYX+ False ->+ let y' = case lengthXY <= lengthY `div` 2 of+ True -> xy+ False -> diffYX+ in HashSet.insert y' q+ in (p', q')+ do (p0, q0)+ do MState.assocsMap do findY p0 x++ findY Partition{ partitionMap } x = foldl'+ do \ym s -> case MState.lookupMap s partitionMap of+ Nothing -> error "unreachable"+ Just sp -> MState.insertOrUpdateMap sp+ do MState.singletonSet s+ do \ss -> MState.insertSet s ss+ do ym+ do MState.emptyMap+ do MState.setToList x++ findIncomingTrans ss = foldl'+ do \rt0 s -> case MState.lookupMap s rtrans of+ Nothing -> rt0+ Just rt -> DFARevTrans+ { dfaRevTrans = IntMap.mergeWithKey+ do \_ ss1 ss2 -> Just do MState.unionSet ss1 ss2+ do \t1 -> t1 <&> \ss1 -> MState.unionSet ss1+ do dfaRevTransOther rt+ do \t2 -> t2 <&> \ss2 -> MState.unionSet ss2+ do dfaRevTransOther rt0+ do dfaRevTrans rt0+ do dfaRevTrans rt+ , dfaRevTransOther = MState.unionSet+ do dfaRevTransOther rt0+ do dfaRevTransOther rt+ }+ do DFARevTrans+ { dfaRevTrans = IntMap.empty+ , dfaRevTransOther = MState.emptySet+ }+ do MState.setToList ss++ rtrans = revTrans dfa++acceptGroup :: DFA.DFA a -> HashMap.HashMap (Maybe Pattern.AcceptPriority) MState.StateSet+acceptGroup DFA.DFA{ dfaTrans } = foldl'+ do \m (s, dst) -> case DFA.dstAccepts dst of+ [] -> insertState Nothing s m+ acc:_ -> insertState+ do Just do Pattern.accPriority acc+ do s+ do m+ do HashMap.empty+ do MState.arrayAssocs dfaTrans+ where+ insertState k s m = case HashMap.lookup k m of+ Nothing -> HashMap.insert k+ do MState.singletonSet s+ do m+ Just ss -> HashMap.insert k+ do MState.insertSet s ss+ do m+++data DFARevTrans a = DFARevTrans+ { dfaRevTrans :: IntMap.IntMap MState.StateSet+ , dfaRevTransOther :: MState.StateSet+ }++revTrans :: DFA.DFA a -> MState.StateMap (DFARevTrans a)+revTrans DFA.DFA{ dfaTrans } = foldl'+ do \m0 (sf, dst) ->+ let trans = DFA.dstTrans dst+ m1 = foldl'+ do \m (c, st) -> insertTrans sf c st m+ do m0+ do IntMap.assocs trans+ in case DFA.dstOtherTrans dst of+ Nothing -> m1+ Just st -> insertOtherTrans sf st trans m1+ do MState.emptyMap+ do MState.arrayAssocs dfaTrans+ where+ insertTrans sf c st m0 = MState.insertOrUpdateMap st+ do DFARevTrans+ { dfaRevTrans = IntMap.singleton c do MState.singletonSet sf+ , dfaRevTransOther = MState.emptySet+ }+ do \rtrans ->+ let rtransRevTrans = dfaRevTrans rtrans+ in rtrans+ { dfaRevTrans = case IntMap.lookup c rtransRevTrans of+ Nothing -> IntMap.insert c+ do MState.insertSet sf do dfaRevTransOther rtrans+ do rtransRevTrans+ Just ss -> IntMap.insert c+ do MState.insertSet sf ss+ do rtransRevTrans+ }+ do m0++ insertOtherTrans sf st trans m0 = MState.insertOrUpdateMap st+ do DFARevTrans+ { dfaRevTrans = trans <&> \_ -> MState.emptySet+ , dfaRevTransOther = MState.singletonSet sf+ }+ do \rtrans -> DFARevTrans+ { dfaRevTrans = IntMap.mergeWithKey+ do \_ ss _ -> Just ss+ do \rt -> rt <&> \ss -> MState.insertSet sf ss+ do \t -> t <&> \_ -> dfaRevTransOther rtrans+ do dfaRevTrans rtrans+ do trans+ , dfaRevTransOther = MState.insertSet sf+ do dfaRevTransOther rtrans+ }+ do m0
+ src/Language/Lexer/Tlex/Pipeline/Nfa2Dfa.hs view
@@ -0,0 +1,159 @@+module Language.Lexer.Tlex.Pipeline.Nfa2Dfa (+ nfa2Dfa,+) where++import Language.Lexer.Tlex.Prelude++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.Data.EnumMap as EnumMap+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 = DFA.buildDFA+ do modify' \dfaBuilderCtx0 -> nfa2DfaCtxDFABuilderCtx+ do execState+ do nfa2DfaM nfa+ do Nfa2DfaContext+ { nfa2DfaCtxStateMap = HashMap.empty+ , nfa2DfaCtxDFABuilderCtx = dfaBuilderCtx0+ }+++data Nfa2DfaContext m = Nfa2DfaContext+ { nfa2DfaCtxStateMap :: HashMap.HashMap MState.StateSet MState.StateNum+ , nfa2DfaCtxDFABuilderCtx :: DFA.DFABuilderContext m+ }++type Nfa2DfaM m = State (Nfa2DfaContext m)++liftBuilderOp :: DFA.DFABuilder m a -> Nfa2DfaM m a+liftBuilderOp builder = do+ ctx0 <- get+ let (x, builderCtx1) = runState builder do nfa2DfaCtxDFABuilderCtx ctx0+ put do ctx0+ { nfa2DfaCtxDFABuilderCtx = builderCtx1+ }+ pure x++registerNewState :: MState.StateSet -> Nfa2DfaM m MState.StateNum+registerNewState nfaSs = do+ dfaSn <- liftBuilderOp DFA.newStateNum+ modify' \ctx0@Nfa2DfaContext{ nfa2DfaCtxStateMap } -> ctx0+ { nfa2DfaCtxStateMap = HashMap.insert nfaSs dfaSn nfa2DfaCtxStateMap+ }+ pure dfaSn++nfa2DfaM :: NFA.NFA m -> Nfa2DfaM m ()+nfa2DfaM NFA.NFA{ nfaInitials, nfaTrans } = do+ initials <- forM nfaInitials \(nfaSn, s) -> do+ let nfaSs = buildNfaSs nfaSn+ dfaSn <- registerNewState nfaSs+ liftBuilderOp do DFA.initial dfaSn s+ pure (dfaSn, nfaSs)++ buildStateMap initials+ where+ buildNfaSs nfaSn =+ let nfaState = nfaTrans `MState.indexArray` nfaSn+ in MState.listToSet do NFA.nstEpsilonTrans nfaState++ insertNfaSn nfaSn0 nfaSs0 =+ let nfaState0 = nfaTrans `MState.indexArray` nfaSn0+ in foldl'+ do \nfaSs nfaSn -> MState.insertSet nfaSn nfaSs+ do nfaSs0+ do NFA.nstEpsilonTrans nfaState0++ buildStateMap = \case+ [] -> pure ()+ (dfaSn, nfaSs):rest0 -> do+ (rest1, dst) <- buildDFAState nfaSs rest0+ liftBuilderOp do DFA.insertTrans dfaSn dst+ buildStateMap rest1++ buildDFAState nfaSs0 rest0 = do+ (accs1, trans1, otherTrans1) <- foldM+ do \(accs, trans, otherTrans) nfaSn ->+ let nfaState = nfaTrans `MState.indexArray` nfaSn+ accs' = foldl'+ do \m acc -> EnumMap.insert+ do Pattern.accPriority acc+ do acc+ do m+ do accs+ do NFA.nstAccepts nfaState+ (trans', otherTrans') = foldl' insertTrans (trans, otherTrans)+ do NFA.nstTrans nfaState+ in pure (accs', trans', otherTrans')+ do (EnumMap.empty, EnumMap.empty, MState.emptySet)+ do MState.setToList nfaSs0++ let getOrRegisterNfaSs nfaSs rest = do+ ctx0 <- get+ let stateMap = nfa2DfaCtxStateMap ctx0+ case HashMap.lookup nfaSs stateMap of+ Just dfaSn -> pure (rest, dfaSn)+ Nothing -> do+ dfaSn <- registerNewState nfaSs+ pure ((dfaSn, nfaSs):rest, dfaSn)++ (rest1, trans2) <- foldM+ do \(rest, trans) (c, nfaSs) -> do+ (rest', dfaSn) <- getOrRegisterNfaSs nfaSs rest+ pure (rest', IntMap.insert (fromEnum c) dfaSn trans)+ do (rest0, IntMap.empty)+ do EnumMap.assocs trans1++ (rest2, otherTrans2) <- case MState.nullSet otherTrans1 of+ True -> pure (rest1, Nothing)+ False -> do+ (rest, dfaSn) <- getOrRegisterNfaSs otherTrans1 rest1+ pure (rest, Just dfaSn)++ pure+ ( rest2+ , DFA.DState+ { dstAccepts = [ acc | (_, acc) <- EnumMap.toDescList accs1 ]+ , dstTrans = trans2+ , dstOtherTrans = otherTrans2+ }+ )++ insertTrans (trans0, otherTrans0) st =+ let cs = NFA.nstTransRange st+ nfaSn = NFA.nstTransNextState st+ in case NFA.nstTransIsStraight st of+ True ->+ let ~newTrans = insertNfaSn nfaSn otherTrans0+ trans1 = IntSet.foldl'+ do \trans c -> EnumMap.insertOrUpdate c+ do newTrans+ do \ss -> insertNfaSn nfaSn ss+ do trans+ do trans0+ do cs+ in (trans1, otherTrans0)+ False ->+ let (diffTrans1, trans1) = IntSet.foldl'+ do \(diffTrans, trans) c ->+ ( EnumMap.delete c diffTrans+ , EnumMap.insertOrUpdate c+ MState.emptySet+ id+ trans+ )+ do (trans0, trans0)+ do cs+ trans2 = EnumMap.foldlWithKey'+ do \trans c ss -> EnumMap.insert c+ do insertNfaSn nfaSn ss+ do trans+ do trans1+ do diffTrans1+ in (trans2, insertNfaSn nfaSn otherTrans0)
+ src/Language/Lexer/Tlex/Pipeline/Pattern2Nfa.hs view
@@ -0,0 +1,40 @@+module Language.Lexer.Tlex.Pipeline.Pattern2Nfa (+ pattern2Nfa,+) where++import Language.Lexer.Tlex.Prelude++import qualified Language.Lexer.Tlex.Data.EnumSet as EnumSet+import qualified Language.Lexer.Tlex.Data.SymEnumSet as SymEnumSet+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+++pattern2Nfa+ :: Enum e+ => MState.StateNum -> MState.StateNum -> Pattern.Pattern e+ -> NFA.NFABuilder m ()+pattern2Nfa = go where+ go b e = \case+ Pattern.Epsilon -> NFA.epsilonTrans b e+ Pattern.Range s -> NFA.condTrans b+ do+ let (isStraight, es) = SymEnumSet.toEnumSet s+ NFA.NFAStateTrans+ { NFA.nstTransIsStraight = isStraight+ , NFA.nstTransRange = EnumSet.toIntSet es+ , NFA.nstTransNextState = e+ }+ p1 Pattern.:^: p2 -> do+ s <- NFA.newStateNum+ pattern2Nfa b s p1+ pattern2Nfa s e p2+ p1 Pattern.:|: p2 -> do+ pattern2Nfa b e p1+ pattern2Nfa b e p2+ Pattern.Many p -> do+ s <- NFA.newStateNum+ NFA.epsilonTrans b s+ pattern2Nfa s s p+ NFA.epsilonTrans s e
+ src/Language/Lexer/Tlex/Prelude.hs view
@@ -0,0 +1,5 @@+module Language.Lexer.Tlex.Prelude (+ module Language.Lexer.Tlex.Prelude.Core,+) where++import Language.Lexer.Tlex.Prelude.Core
+ src/Language/Lexer/Tlex/Prelude/Core.hs view
@@ -0,0 +1,40 @@+module Language.Lexer.Tlex.Prelude.Core (+ module Prelude,+ module Control.Applicative,+ module Control.Monad,+ module Control.Monad.IO.Class,+ module Control.Monad.Trans.State.Strict,+ module Data.Coerce,+ module Data.Foldable,+ module Data.Function,+ module Data.Functor,+ module Data.Functor.Identity,+ module Data.Functor.Compose,+ module Data.Ix,+ module Data.Kind,+ module Data.List.NonEmpty,+ module Data.Ord,+ module Data.Proxy,+ module Data.Typeable,+ module Data.Word,+) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict hiding (modify)+import Data.Coerce+import Data.Foldable hiding (foldl, foldr')+import Data.Function hiding (($))+import Data.Functor+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Ix (Ix)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Ord (Down (..))+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import Data.Word (Word, Word8)+import Prelude hiding (String, foldl, foldr,+ head, pi, tail, ($))
+ test/doctest/Doctest.hs view
@@ -0,0 +1,21 @@+module Main where++import Prelude++import qualified Build_doctests as BuildF+import Control.Monad+import qualified System.Environment as IO+import qualified System.IO as IO+import Test.DocTest (doctest)++main :: IO ()+main = forM_ BuildF.components \(BuildF.Component name flags pkgs sources) -> do+ putStrLn "============================================="+ print name+ putStrLn "---------------------------------------------"+ IO.hFlush IO.stdout+ let args = flags ++ pkgs ++ sources+ IO.unsetEnv "GHC_ENVIRONMENT"+ doctest args+ putStrLn "============================================="+ IO.hFlush IO.stdout
+ test/spec/HSpecDriver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tlex-core.cabal view
@@ -0,0 +1,169 @@+cabal-version: 3.0+build-type: Custom++name: tlex-core+version: 0.1.0.0+license: Apache-2.0 OR MPL-2.0+license-file: LICENSE+copyright: (c) 2021 Mizunashi Mana+author: Mizunashi Mana+maintainer: mizunashi-mana@noreply.git++category: Parsing+homepage: https://github.com/mizunashi-mana/tlex+bug-reports: https://github.com/mizunashi-mana/tlex/issues+synopsis: A lexer generator+description:+ Tlex is haskell libraries and toolchains for generating lexical analyzer.+ See also: https://github.com/mizunashi-mana/tlex++extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mizunashi-mana/tlex.git++flag develop+ default: False+ manual: True+ description: Turn on some options for development++common general+ default-language:+ Haskell2010+ default-extensions:+ NoImplicitPrelude+ BangPatterns+ BinaryLiterals+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DerivingVia+ DuplicateRecordFields+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ LambdaCase+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NegativeLiterals+ NumericUnderscores+ OverloadedLabels+ PackageImports+ PatternSynonyms+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ Strict+ TypeApplications+ TypeFamilies+ TypeOperators+ UnboxedSums+ UnboxedTuples++ if flag(develop)+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wmonomorphism-restriction+ -Wpartial-fields++ -fprint-explicit-foralls+ -frefinement-level-hole-fits=1++ -dcore-lint++ build-depends:+ base >= 4.12.0 && < 4.15,++ -- project depends+ array >= 0.5.3 && < 0.6,+ containers >= 0.6.0 && < 0.7,+ hashable >= 1.3.0 && < 1.4,+ transformers >= 0.5.6 && < 0.6,+ unordered-containers >= 0.2.13 && < 0.3,++ autogen-modules:+ Paths_tlex_core+ other-modules:+ Paths_tlex_core++custom-setup+ setup-depends:+ base,+ Cabal,+ cabal-doctest,++library+ import:+ general,+ hs-source-dirs:+ src+ exposed-modules:+ Language.Lexer.Tlex.Prelude+ Language.Lexer.Tlex.Machine.State+ Language.Lexer.Tlex.Machine.Pattern+ Language.Lexer.Tlex.Machine.NFA+ Language.Lexer.Tlex.Machine.DFA+ Language.Lexer.Tlex.Pipeline.Pattern2Nfa+ Language.Lexer.Tlex.Pipeline.Nfa2Dfa+ Language.Lexer.Tlex.Pipeline.MinDfa+ Language.Lexer.Tlex.Data.EnumSet+ Language.Lexer.Tlex.Data.EnumMap+ Language.Lexer.Tlex.Data.SymEnumSet+ Language.Lexer.Tlex.Data.Bag++ other-modules:+ Language.Lexer.Tlex.Prelude.Core+ Language.Lexer.Tlex.Data.Graph++test-suite doctest+ import:+ general,+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test/doctest+ main-is:+ Doctest.hs+ build-depends:+ doctest,+ QuickCheck,+ autogen-modules:+ Build_doctests+ other-modules:+ Build_doctests++test-suite spec+ import:+ general,+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test/spec+ main-is:+ HSpecDriver.hs+ ghc-options:+ -Wno-missing-home-modules+ build-tool-depends:+ hspec-discover:hspec-discover,+ build-depends:+ tlex-core,++ hspec,+ QuickCheck,