regex-tdfa-rc 1.1.8.1 → 1.1.8.2
raw patch · 7 files changed
+42/−156 lines, 7 filesdep ~base
Dependency ranges changed: base
Files
- Text/Regex/TDFA/Common.hs +5/−87
- Text/Regex/TDFA/CorePattern.hs +1/−19
- Text/Regex/TDFA/NewDFA/Engine.hs +2/−6
- Text/Regex/TDFA/NewDFA/Engine_FA.hs +2/−6
- Text/Regex/TDFA/TDFA.hs +4/−8
- Text/Regex/TDFA/TNFA.hs +26/−29
- regex-tdfa-rc.cabal +2/−1
Text/Regex/TDFA/Common.hs view
@@ -7,7 +7,6 @@ import Text.Regex.Base(RegexOptions(..)) {- By Chris Kuklewicz, 2007-2009. BSD License, see the LICENSE file. -}-import Text.Show.Functions() import Data.Array.IArray(Array) import Data.IntSet.EnumSet2(EnumSet) import qualified Data.IntSet.EnumSet2 as Set(toList)@@ -160,7 +159,6 @@ data WinEmpty = WinEmpty Instructions | WinTest WhichTest (Maybe WinEmpty) (Maybe WinEmpty)- deriving Show -- | Internal NFA node type data QNFA = QNFA {q_id :: Index, q_qt :: QT}@@ -200,7 +198,7 @@ type TagTasks = [(Tag,TagTask)] -- | When attached to a QTrans the TagTask can be done before or after -- accepting the character.-data TagUpdate = PreUpdate TagTask | PostUpdate TagTask deriving (Show,Eq)+data TagUpdate = PreUpdate TagTask | PostUpdate TagTask deriving (Eq) -- | Ordered list of tags and their associated update operation. type TagList = [(Tag,TagUpdate)] -- | A TagList and the location of the item in the original pattern@@ -212,7 +210,7 @@ -- | Internal DFA node, identified by the Set of indices of the QNFA -- nodes it represents.-data DFA = DFA { d_id :: SetIndex, d_dt :: DT } deriving(Show)+data DFA = DFA { d_id :: SetIndex, d_dt :: DT } data Transition = Transition { trans_many :: DFA -- ^ where to go (maximal), including respawning , trans_single :: DFA -- ^ where to go, not including respawning , trans_how :: DTrans -- ^ how to go, including respawning@@ -253,96 +251,16 @@ , basePos :: Position , ordinal :: (Maybe Int) , getOrbits :: !(Seq Position)- } deriving (Show)+ } -- | The 'newPos' and 'newFlags' lists in Instructions are sorted by, and unique in, the Tag values data Instructions = Instructions { newPos :: ![(Tag,Action)] -- False is preUpdate, True is postUpdate (there are no Orbit tags here) -- 2009 : Change to enum from bool? , newOrbits :: !(Maybe (Position -> OrbitTransformer))- } deriving (Show)-data Action = SetPre | SetPost | SetVal Int deriving (Show,Eq)+ }+data Action = SetPre | SetPost | SetVal Int deriving (Eq) type OrbitTransformer = OrbitLog -> OrbitLog type OrbitLog = IntMap Orbits--instance Show QNFA where- show (QNFA {q_id = i, q_qt = qt}) = "QNFA {q_id = "++show i- ++"\n ,q_qt = "++ show qt- ++"\n}"--instance Show QT where- show = showQT--showQT :: QT -> String-showQT (Simple win trans other) = "{qt_win=" ++ show win- ++ "\n, qt_trans=" ++ show (foo trans)- ++ "\n, qt_other=" ++ show (foo' other) ++ "}"- where foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])]- foo = mapSnd foo' . Map.toAscList- foo' :: QTrans -> [(Index,[TagCommand])]- foo' = IMap.toList -showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas)- ++"\n"++indent' a- ++"\n"++indent' b++"}"- where indent' = init . unlines . map (spaces++) . lines . showQT- spaces = replicate 9 ' '--instance Show DT where show = showDT--indent :: [String] -> String-indent = unlines . map (\x -> ' ':' ':x)--showDT :: DT -> String-showDT (Simple' w t o) =- "Simple' { dt_win = " ++ seeWin1- ++ "\n , dt_trans = " ++ seeTrans1- ++ "\n , dt_other = " ++ seeOther1 o- ++ "\n }"- where- seeWin1 | IMap.null w = "No win"- | otherwise = indent . map show . IMap.assocs $ w-- seeTrans1 :: String- seeTrans1 | Map.null t = "No (Char,Transition)"- | otherwise = ('\n':) . indent $- map (\(char,Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) ->- concat ["("- ,show char- ,", MANY "- ,show (d_id dfa)- ,", SINGLE "- ,show (d_id dfa2)- ,", \n"- ,seeDTrans dtrans- ,")"]) (Map.assocs t)-- seeOther1 (Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) =- concat ["(MANY "- ,show (d_id dfa)- ,", SINGLE "- ,show (d_id dfa2)- ,", \n"- ,seeDTrans dtrans- ,")"]--showDT (Testing' wt d a b) = "Testing' { dt_test = " ++ show wt- ++ "\n , dt_dopas = " ++ show d- ++ "\n , dt_a = " ++ indent' a- ++ "\n , dt_b = " ++ indent' b- ++ "\n }"- where indent' = init . unlines . (\s -> case s of- [] -> []- (h:t) -> h : (map (spaces ++) t)) . lines . showDT- spaces = replicate 10 ' '---seeDTrans :: DTrans -> String---seeDTrans x = concatMap (\(dest,y) -> unlines . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ y) (IMap.assocs x)-seeDTrans x | IMap.null x = "No DTrans"-seeDTrans x = concatMap seeSource (IMap.assocs x)- where seeSource (dest,srcMap) | IMap.null srcMap = indent [show (dest,"SPAWN")]- | otherwise = indent . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ srcMap--- spawnIns = Instructions { newPos = [(0,SetPost)], newOrbits = Nothing }- instance Eq QT where t1@(Testing {}) == t2@(Testing {}) =
Text/Regex/TDFA/CorePattern.hs view
@@ -66,7 +66,7 @@ | Test TestInfo -- Require the test to be true (merge with empty as (Test (Maybe TestInfo)) ??) | OneChar Pattern -- Bring the Pattern element that accepts a character | NonEmpty Q -- Don't let the Q pattern match nothing- deriving (Show,Eq)+ deriving (Eq) -- The diagnostics about the pattern. Note that when unQ is 'Seq' the -- the preTag and postTag are Nothing but the preReset might have tags@@ -115,24 +115,6 @@ -- In practice WantsBoth is treated identically to WantsQNFA and -- WantsBoth could be removed. data Wanted = WantsQNFA | WantsQT | WantsBoth | WantsEither deriving (Eq,Show)--instance Show Q where- show = showQ--showQ :: Q -> String-showQ q = "Q { nullQ = "++show (nullQ q)++- "\n , takes = "++show (takes q)++- "\n , preReset = "++show (preReset q)++- "\n , postSet = "++show (postSet q)++- "\n , preTag = "++show (preTag q)++- "\n , postTag = "++show (postTag q)++- "\n , tagged = "++show (tagged q)++- "\n , wants = "++show (wants q)++- "\n , unQ = "++ indent' (unQ q)++" }"- where indent' = unlines . (\s -> case s of- [] -> []- (h:t) -> h : (map (spaces ++) t)) . lines . show- spaces = replicate 10 ' ' -- Smart constructors for NullView notNull :: NullView
Text/Regex/TDFA/NewDFA/Engine.hs view
@@ -544,7 +544,7 @@ (SetPre,SetPost) -> LT (SetPost,SetPre) -> GT (SetVal v1,SetVal v2) -> compare v1 v2- _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2)+ _ -> err $ "bestTrans.compareWith.choose sees incomparable" ditzyComp'3 :: forall s. Array Tag OP -> C s ditzyComp'3 aTagOP = comp0 where@@ -618,11 +618,7 @@ comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of EQ -> next comps preTag x1 np1 x2 np2 answer -> return answer- _ -> err $ unlines [ "challenge_Orb is too stupid to handle mismatched orbit data :"- , show(tag,preTag,np1,np2)- , show s1- , show s2- ]+ _ -> err $ "challenge_Orb is too stupid to handle mismatched orbit data\n" challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering
Text/Regex/TDFA/NewDFA/Engine_FA.hs view
@@ -403,7 +403,7 @@ (SetPre,SetPost) -> LT (SetPost,SetPre) -> GT (SetVal v1,SetVal v2) -> compare v1 v2- _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2)+ _ -> err $ "bestTrans.compareWith.choose sees incomparable" ditzyComp'3 :: forall s. Array Tag OP -> C s ditzyComp'3 aTagOP = comp0 where@@ -477,11 +477,7 @@ comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of EQ -> next comps preTag x1 np1 x2 np2 answer -> return answer- _ -> err $ unlines [ "challenge_Orb is too stupid to handle mismatched orbit data :"- , show(tag,preTag,np1,np2)- , show s1- , show s2- ]+ _ -> err $ "challenge_Orb is too stupid to handle mismatched orbit data\n" challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering
Text/Regex/TDFA/TDFA.hs view
@@ -3,7 +3,7 @@ -- of Index which are used to lookup the DFA state in a lazy Trie -- which holds all possible subsets of QNFA states. module Text.Regex.TDFA.TDFA(patternToRegex,DFA(..),DT(..)- ,examineDFA,nfaToDFA,dfaMap) where+ ,nfaToDFA,dfaMap) where --import Control.Arrow((***)) import Data.Monoid(Monoid(..))@@ -19,7 +19,7 @@ --import Data.IntSet(IntSet) import qualified Data.IntSet as ISet(empty,singleton,null) import Data.List(foldl')-import qualified Data.Map (Map,empty,member,insert,elems)+import qualified Data.Map (Map,empty,member,insert) import Data.Sequence as S((|>),{-viewl,ViewL(..)-}) import Text.Regex.TDFA.Common {- all -}@@ -172,10 +172,6 @@ flattenDT (Simple' {dt_trans=(CharMap mt),dt_other=o}) = concatMap (\d -> [trans_many d {-,trans_single d-}]) . (:) o . IMap.elems $ mt flattenDT (Testing' {dt_a=a,dt_b=b}) = flattenDT a ++ flattenDT b -examineDFA :: Regex -> String-examineDFA (Regex {regex_dfa=dfa}) = unlines . (:) ("Number of reachable DFA states: "++show (length dfas)) . map show $ dfas- where dfas = Data.Map.elems $ dfaMap dfa- {- fillMap :: Tag -> IntMap (Position,Bool)@@ -278,7 +274,7 @@ (SetPre,SetPost) -> LT (SetPost,SetPre) -> GT (SetVal v1,SetVal v2) -> compare v1 v2- _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (tag,post1,post2)+ _ -> err $ "bestTrans.compareWith.choose sees incomparable " {-# INLINE compareWith #-}@@ -354,7 +350,7 @@ PostUpdate TagTask -> setPostTag tag PostUpdate ResetGroupStopTask -> resetGroupTag tag PostUpdate SetGroupStopTask -> setGroupTag tag- _ -> err ("assemble : Weird orbit command: "++show (tag,command))+ _ -> err ("assemble : Weird orbit command") setPreTag :: Tag -> CompileInstructions () setPreTag = modifyPos SetPre
Text/Regex/TDFA/TNFA.hs view
@@ -83,8 +83,7 @@ ,Array GroupIndex [GroupInfo]) patternToNFA compOpt pattern = let (q,tags,groups) = patternToQ compOpt pattern- msg = unlines [ show q ]- in debug msg (qToNFA compOpt q,tags,groups)+ in (qToNFA compOpt q,tags,groups) -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Query function on Q@@ -168,7 +167,7 @@ not in sti are unchanged (but the losing DoPa index might be added). -} dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT-dominate win lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $+dominate win lose x@(SetTestInfo sti,tags) = let -- The winning states are reached through the SetTag win' = prependTags' tags win -- get the SetTestInfo @@ -391,12 +390,12 @@ {-# INLINE addGroupResets #-} -- This is polymorphic so addGroupResetsAC can be cute below-addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)+addGroupResets :: [Tag] -> (TagTasks,a) -> (TagTasks,a) addGroupResets [] x = x addGroupResets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,ResetGroupStopTask)) $ tags ,cont) -addGroupSets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)+addGroupSets :: [Tag] -> (TagTasks,a) -> (TagTasks,a) addGroupSets [] x = x addGroupSets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,SetGroupStopTask)) $ tags ,cont)@@ -458,7 +457,7 @@ startState = (0,id) getTrans,getTransTagless :: Q -> E -> S E- getTrans qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post,unQ=pIn}) e = debug (">< getTrans "++show qIn++" <>") $+ getTrans qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post,unQ=pIn}) e = case pIn of -- The case below is the ultimate consumer of every single OneChar in the input and the only caller of -- newTrans/acceptTrans which is the sole source of QT/Simple nodes.@@ -467,7 +466,7 @@ Test ti -> return . addGroupResets resets . addTag pre . addTest ti . addTag post . addGroupSets sets $ e _ -> return . addGroupResets resets . addTag pre =<< getTransTagless qIn (addTag post . addGroupSets sets $ e) - getTransTagless qIn e = debug (">< getTransTagless "++show qIn++" <>") $+ getTransTagless qIn e = case unQ qIn of Seq q1 q2 -> getTrans q1 =<< getTrans q2 e Or [] -> return e@@ -495,7 +494,7 @@ in if cannotAccept q then return e' else mdo mqt <- inStar q this (this,ans) <- case mqt of- Nothing -> err ("Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn))+ Nothing -> err "Weird pattern in getTransTagless/Star" Just qt -> do let qt' = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit $ qt -- resetOrbitsQT and enterOrbitQT commute thisQT = mergeQT qt' . getQT . leaveOrbit mOrbit $ e -- capture of subpattern or leave via next pattern (avoid null of subpattern on way out)@@ -509,29 +508,27 @@ else this) {- NonEmpty is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -}- NonEmpty q -> ecart ("\n> getTransTagless/NonEmpty"++show qIn) $ do+ NonEmpty q -> do -- Assertion to check than Pattern.starTrans did its job right:- when (cannotAccept q) (err $ "getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn))- when (mustAccept q) (err $ "getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn))+ when (cannotAccept q) (err $ "getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: ")+ when (mustAccept q) (err $ "getTransTagless/NonEmpty : provided with a *mustAccept* pattern: ") let e' = case maybeOnlyEmpty qIn of Just [] -> e Just _wtags -> e -- addWinTags wtags e XXX was duplicating tags- Nothing -> err $ "getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "++show qIn+ Nothing -> err $ "getTransTagless/NonEmpty is supposed to have an emptyNull nullView : " mqt <- inStar q e return $ case mqt of- Nothing -> err ("Weird pattern in getTransTagless/NonEmpty: " ++ show (qTop,qIn))+ Nothing -> err ("Weird pattern in getTransTagless/NonEmpty: ") Just qt -> fromQT . mergeQT_2nd qt . getQT $ e' -- ...and then this sets qt_win to exactly that of e'- _ -> err ("This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" ++ show (qTop,qIn))+ _ -> err ("This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen") inStar,inStarNullableTagless :: Q -> E -> S (Maybe QT) inStar qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post}) eLoop | notNullable qIn =- debug (">< inStar/1 "++show qIn++" <>") $ return . Just . getQT =<< getTrans qIn eLoop | otherwise =- debug (">< inStar/2 "++show qIn++" <>") $ return . fmap (prependGroupResets resets . prependPreTag pre) =<< inStarNullableTagless qIn (addTag post . addGroupSets sets $ eLoop) - inStarNullableTagless qIn eLoop = debug (">< inStarNullableTagless "++show qIn++" <>") $ do+ inStarNullableTagless qIn eLoop = do case unQ qIn of Empty -> return Nothing -- with Or this discards () branch in "(^|foo|())*" Or [] -> return Nothing@@ -553,7 +550,7 @@ -- Calls to act are inlined by hand and are we losing the tags? Star {} -> do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut)- NonEmpty {} -> ecart ("\n> inStarNullableTagless/NonEmpty"++show qIn) $+ NonEmpty {} -> do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut) Test {} -> return Nothing -- with Or this discards ^ branch in "(^|foo|())*"@@ -603,20 +600,20 @@ act :: Q -> ActCont -> S (Maybe E) act qIn c | nullable qIn = fmap snd3 $ actNullable qIn c- | otherwise = debug (">< act "++show qIn++" <>") $ do+ | otherwise = do mqt <- return . Just =<< getTrans qIn ( getE $ c ) return mqt -- or "return (fromQT qtlose,mqt,Nothing)" actNullable,actNullableTagless :: Q -> ActCont -> S ActCont actNullable qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post,unQ=pIn}) ac =- debug (">< actNullable "++show qIn++" <>") $ do+ do case pIn of Empty -> return . addGroupResetsAC resets . addTagAC pre . addTagAC post . addGroupSetsAC sets $ ac Test ti -> return . addGroupResetsAC resets . addTagAC pre . addTestAC ti . addTagAC post . addGroupSetsAC sets $ ac OneChar {} -> err ("OneChar cannot have nullable True ") _ -> return . addGroupResetsAC resets . addTagAC pre =<< actNullableTagless qIn ( addTagAC post . addGroupSetsAC sets $ ac ) - actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = debug (">< actNullableTagless "++show (qIn)++" <>") $ do+ actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = do case unQ qIn of Seq q1 q2 -> actNullable q1 =<< actNullable q2 ac -- We know q1 and q2 are nullable @@ -662,7 +659,7 @@ mChildAccepting <- act q (this,Nothing,Nothing) (thisAC@(this,_,_),ansAC) <- case mChildAccepting of- Nothing -> err $ "Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn)+ Nothing -> err "Weird pattern in getTransTagless/Star" Just childAccepting -> do let childQT = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit . getQT $ childAccepting thisQT = mergeQT childQT . getQT . leaveOrbit mOrbit . getE $ ac@@ -683,19 +680,19 @@ return (thisAll,ansAll) return (if mayFirstBeNull then (if clear then thisAC else ansAC) else thisAC)- NonEmpty q -> ecart ("\n> actNullableTagless/NonEmpty"++show qIn) $ do+ NonEmpty q -> do -- We *know* that q is nullable from Pattern and CorePattern checks, but assert here anyway- when (mustAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn))- when (cannotAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn))+ when (mustAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *mustAccept* pattern")+ when (cannotAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern") {- This is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -} let (clearE,_,_) = case maybeOnlyEmpty qIn of Just [] -> ac Just _wtags -> ac -- addWinTagsAC wtags ac XXX was duplicating tags- Nothing -> err $ "actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "++show (qTop,qIn)+ Nothing -> err $ "actNullableTagless/NonEmpty is supposed to have an emptyNull nullView" (_,mChildAccepting,_) <- actNullable q ac case mChildAccepting of- Nothing -> err $ "Weird pattern in actNullableTagless/NonEmpty: " ++ show (qTop,qIn)+ Nothing -> err $ "Weird pattern in actNullableTagless/NonEmpty" -- cannotAccept q checked for and excluded the above condition (and starTrans!) Just childAccepting -> do let childQT = getQT childAccepting@@ -704,7 +701,7 @@ Just futureAcceptingE -> Just . fromQT . mergeQT childQT . getQT $ futureAcceptingE -- I _think_ there is no need for mergeQT_2nd in the above. return (clearE,thisAccepting,Nothing)- _ -> err $ "This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "++show (qTop,qIn)+ _ -> err $ "This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen" -- This is applied directly to any qt immediately before passing to mergeQT resetOrbitsQT :: [Tag] -> QT -> QT@@ -755,7 +752,7 @@ PAnyNot _ ps -> let trans = toMap mempty . S.toAscList . addNewline . decodePatternSet $ ps in Simple { qt_win = mempty, qt_trans = trans, qt_other = target }- _ -> err ("Cannot acceptTrans pattern "++show (qTop,pIn))+ _ -> err "Cannot acceptTrans pattern " where -- Take a common destination and a sorted list of unique chraceters -- and create a map from those characters to the common destination toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]
regex-tdfa-rc.cabal view
@@ -1,5 +1,5 @@ Name: regex-tdfa-rc-Version: 1.1.8.1+Version: 1.1.8.2 -- 0.99.4 tests pnonempty' = \ p -> POr [ PEmpty, p ] instead of PNonEmpty -- 0.99.5 remove PNonEmpty constructor -- 0.99.6 change to nested nonEmpty calls for PBound@@ -47,6 +47,7 @@ -- 1.1.7 fix url below -- 1.1.8 Make ghc-7.0.2 on platorm 2011.2.0.0.0 happy -- 1.1.8.1 Fix for ghc 7.8+-- 1.1.8.2 Remove Show instances License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2007, Christopher Kuklewicz