regex-tdfa 1.1.2 → 1.1.3
raw patch · 7 files changed
+60/−58 lines, 7 files
Files
- Text/Regex/TDFA/CorePattern.hs +18/−19
- Text/Regex/TDFA/NewDFA/Engine.hs +10/−10
- Text/Regex/TDFA/NewDFA/Engine_FA.hs +8/−9
- Text/Regex/TDFA/Pattern.hs +3/−4
- Text/Regex/TDFA/ReadRegex.hs +4/−4
- Text/Regex/TDFA/TNFA.hs +15/−9
- regex-tdfa.cabal +2/−3
Text/Regex/TDFA/CorePattern.hs view
@@ -97,7 +97,7 @@ -- (i.e. with a Test) or unconditionally accept 0 characters. These -- are in the list in order of preference, with most preferred listed -- first.-type NullView = [(SetTestInfo,TagTasks)] -- Ordered list of null views, each is a set of tests and tags+type NullView = [(SetTestInfo,TagList)] -- Ordered list of null views, each is a set of tests and tags -- During the depth first traversal, children are told about tags by the parent. -- They may change Apply to Advice and they may generate new tags.@@ -140,19 +140,18 @@ -- preTags a b = promote a `mappend` promote b -- where promote = maybe [] (\x -> [(x,PreUpdate TagTask)]) -promoteTag :: HandleTag -> TagTasks-promoteTag = maybe [] (\x -> [(x,TagTask)]) . apply+promotePreTag :: HandleTag -> TagList+promotePreTag = maybe [] (\x -> [(x,PreUpdate TagTask)]) . apply makeEmptyNullView :: HandleTag -> HandleTag -> NullView-makeEmptyNullView a b = [(mempty, promoteTag a ++ promoteTag b)]+makeEmptyNullView a b = [(mempty, promotePreTag a ++ promotePreTag b)] makeTestNullView :: TestInfo -> HandleTag -> HandleTag -> NullView-makeTestNullView (w,d) a b = [(SetTestInfo (Map.singleton w (Set.singleton d))- , promoteTag a ++ promoteTag b)]+makeTestNullView (w,d) a b = [(SetTestInfo (Map.singleton w (Set.singleton d)), promotePreTag a ++ promotePreTag b)] tagWrapNullView :: HandleTag -> HandleTag -> NullView -> NullView tagWrapNullView a b oldNV =- case (promoteTag a, promoteTag b) of+ case (promotePreTag a, promotePreTag b) of ([],[]) -> oldNV (pre,post) -> do (oldTests,oldTasks) <- oldNV@@ -161,8 +160,8 @@ -- For PGroup, need to prepend reset tasks before others in nullView addGroupResetsToNullView :: [Tag] -> Tag -> NullView -> NullView addGroupResetsToNullView groupResets groupSet nv = [ (test, prepend (append tags) ) | (test,tags) <- nv ]- where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,ResetGroupStopTask)) $ groupResets- append = (++[(groupSet,SetGroupStopTask)])+ where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetGroupStopTask)) $ groupResets+ append = (++[(groupSet,PreUpdate SetGroupStopTask)]) -- For PStar, need to put in the orbit TagTasks orbitWrapNullView :: Maybe Tag -> [Tag] -> NullView -> NullView@@ -172,8 +171,8 @@ (Nothing,_) -> do (oldTests,oldTasks) <- oldNV return (oldTests,prepend oldTasks) (Just o,_) -> do (oldTests,oldTasks) <- oldNV- return (oldTests,prepend $ [(o,EnterOrbitTask)] ++ oldTasks ++ [(o,LeaveOrbitTask)])- where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,ResetOrbitTask)) $ orbitResets+ return (oldTests,prepend $ [(o,PreUpdate EnterOrbitTask)] ++ oldTasks ++ [(o,PreUpdate LeaveOrbitTask)])+ where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetOrbitTask)) $ orbitResets -- The NullViews are ordered, and later test sets that contain the -- tests from any earlier entry will never be chosen. This function@@ -386,19 +385,19 @@ (False,False,_,_) -> return (toAdvice a) (_,_,False,False) -> return (toAdvice b) _ -> if tagged qFront || tagged qEnd then uniq "combineSeq mid" else return NoTag--- qFront <- pFront a mid--- qEnd <- pEnd (toAdvice mid) b+ -- qFront <- pFront a mid+ -- qEnd <- pEnd (toAdvice mid) b (qFront,qEnd) <- front'end (pFront a mid) (pEnd (toAdvice mid) b) -- XXX: Perhaps a "produces" should be created to compliment "wants", -- then "produces qEnd" could be compared to "wants qFront" let wanted = if WantsEither == wants qEnd then wants qFront else wants qEnd return $ Q { nullQ = mergeNullViews (nullQ qFront) (nullQ qEnd)- , takes = seqTake (takes qFront) (takes qEnd)- , preReset = [], postSet = [], preTag = Nothing, postTag = Nothing- , tagged = bothVary- , childGroups = childGroups qFront || childGroups qEnd- , wants = wanted- , unQ = Seq qFront qEnd }+ , takes = seqTake (takes qFront) (takes qEnd)+ , preReset = [], postSet = [], preTag = Nothing, postTag = Nothing+ , tagged = bothVary+ , childGroups = childGroups qFront || childGroups qEnd+ , wants = wanted+ , unQ = Seq qFront qEnd } ) go :: Pattern -> HHQ go pIn m1 m2 =
Text/Regex/TDFA/NewDFA/Engine.hs view
@@ -52,7 +52,7 @@ -- trace _ a = a err :: String -> a-err s = common_error "Text.Regex.TDFA.NewDFA.Engine" s+err s = common_error "Text.Regex.TDFA.NewDFA" s {-# INLINE (!!) #-} (!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e@@ -115,7 +115,7 @@ goNext storeNext = {-# SCC "goNext" #-} do (SScratch s1In s2In (winQ,blank,which)) <- newScratch b_index b_tags- spawnStart b_tags blank startState s1In offsetIn+ _ <- spawnStart b_tags blank startState s1In offsetIn eliminatedStateFlag <- newSTRef False eliminatedRespawnFlag <- newSTRef False let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-}@@ -131,7 +131,7 @@ Just (c,input') -> case CMap.findWithDefault o c t of Transition {trans_many=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} ->- findTrans s1 s2 did did' dt' dtrans offset c input'+ findTrans s1 s2 did' dt' dtrans offset c input' | otherwise -> do (did',dt') <- processWinner s1 did dt w offset next' s1 s2 did' dt' offset prev input@@ -148,7 +148,7 @@ Just (c,input') -> case CMap.findWithDefault o c t of Transition {trans_many=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} ->- findTrans s1 s2 did did' dt' dtrans offset c input'+ findTrans s1 s2 did' dt' dtrans offset c input' -- compressOrbits gets all the current Tag-0 start information from -- the NFA states; then it loops through all the Orbit tags with@@ -257,10 +257,10 @@ -- "storeNext". If no winners are ready to be released then the -- computation continues immediately. - findTrans s1 s2 did did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do+ findTrans s1 s2 did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do -- findTrans part 0 -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead?- when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did offset)+ when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did' offset) -- findTrans part 1 let findTransTo (destIndex,sources) | IMap.null sources = set which destIndex ((-1,Instructions { newPos = [(0,SetPost)], newOrbits = Nothing })@@ -355,7 +355,7 @@ if respawn then do writeSTRef eliminatedRespawnFlag False- spawnStart b_tags blank startState s1 (succ offset)+ _ <- spawnStart b_tags blank startState s1 (succ offset) return (Trie.lookupAsc trie (sort (states'++[startState]))) else return (Trie.lookupAsc trie states') return (did',dt')@@ -692,15 +692,15 @@ -} -- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1 {-# INLINE copySTU #-}-copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s (STUArray s i e)-copySTU _souce@(STUArray _ _ _ msource) destination@(STUArray _ _ _ mdest) =+copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s () -- (STUArray s i e)+copySTU _souce@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) = -- do b1 <- getBounds s1 -- b2 <- getBounds s2 -- when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2))) ST $ \s1# -> case sizeofMutableByteArray# msource of { n# -> case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->- (# s2#, destination #) }}+ (# s2#, () #) }} {- #else /* !__GLASGOW_HASKELL__ */
Text/Regex/TDFA/NewDFA/Engine_FA.hs view
@@ -48,7 +48,7 @@ -- trace _ a = a err :: String -> a-err s = common_error "Text.Regex.TDFA.NewDFA.Engine_FA" s+err s = common_error "Text.Regex.TDFA.NewDFA" s {-# INLINE (!!) #-} (!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e@@ -103,7 +103,7 @@ case CMap.findWithDefault o c t of Transition {trans_single=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} | ISet.null did' -> finalizeWinner- | otherwise -> findTrans s1 s2 did did' dt' dtrans offset c input'+ | otherwise -> findTrans s1 s2 did' dt' dtrans offset c input' -- compressOrbits gets all the current Tag-0 start information from -- the NFA states; then it loops through all the Orbit tags with@@ -212,10 +212,10 @@ -- "storeNext". If no winners are ready to be released then the -- computation continues immediately. - findTrans s1 s2 did did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do+ findTrans s1 s2 did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do -- findTrans part 0 -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead?- when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did offset)+ when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did' offset) -- findTrans part 1 let findTransTo (destIndex,sources) | IMap.null sources = set which destIndex noSource@@ -521,7 +521,7 @@ {-# INLINE spawnAt #-} -- Reset the entry at "Index", or allocate such an entry. -- set tag 0 to the "Position"-spawnAt :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position+spawnAt :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s () spawnAt b_tags (BlankScratch blankPos) i s1 thisPos = do oldPos <- m_pos s1 !! i pos <- case oldPos of@@ -533,7 +533,6 @@ copySTU blankPos pos set (m_orbit s1) i $! mempty set pos 0 thisPos- return thisPos {-# INLINE updateCopy #-} updateCopy :: ((Index, Instructions), STUArray s Tag Position, OrbitLog)@@ -565,15 +564,15 @@ -} -- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1 {-# INLINE copySTU #-}-copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s (STUArray s i e)-copySTU _souce@(STUArray _ _ _ msource) destination@(STUArray _ _ _ mdest) =+copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s () -- (STUArray s i e)+copySTU _souce@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) = -- do b1 <- getBounds s1 -- b2 <- getBounds s2 -- when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2))) ST $ \s1# -> case sizeofMutableByteArray# msource of { n# -> case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->- (# s2#, destination #) }}+ (# s2#, () #) }} {- #else /* !__GLASGOW_HASKELL__ */
Text/Regex/TDFA/Pattern.hs view
@@ -173,7 +173,7 @@ {- The PStar should not capture 0 characters on its first iteration, so set its mayFirstBeNull flag to False -}- PPlus p | canOnlyMatchNull p -> nullGroup p+ PPlus p | canOnlyMatchNull p -> p | otherwise -> asGroup $ PConcat [reGroup p,PStar False p] {- "An ERE matching a single character repeated by an '*' , '?' , or@@ -261,7 +261,7 @@ | otherwise -> PStar True p PBound 0 (Just 1) p -> quest p -- Hard cases- PBound i Nothing p | canOnlyMatchNull p -> nullGroup p+ PBound i Nothing p | canOnlyMatchNull p -> p | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i) [reGroup p,PStar False p] where nc'p = nonCapture' p PBound 0 (Just j) p | canOnlyMatchNull p -> quest p@@ -281,7 +281,7 @@ where p' = nonCapture' p -} {- 0.99.7 add -}- PBound i (Just j) p | canOnlyMatchNull p -> nullGroup p+ PBound i (Just j) p | canOnlyMatchNull p -> p | i == j -> asGroup . PConcat $ apply (nc'p:) (pred i) [reGroup p] | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i) [reGroup p,apply (nonEmpty' . (concat' p)) (j-i-1) (ne'p) ]@@ -310,7 +310,6 @@ PNonCapture {} -> pass PNonEmpty {} -> pass -- TODO : remove PNonEmpty from program where- nullGroup p = p quest = (\ p -> POr [p,PEmpty]) -- require p to have been simplified -- quest' = (\ p -> simplify' $ POr [p,PEmpty]) -- require p to have been simplified concat' a b = simplify' $ PConcat [reGroup a,reGroup b] -- require a and b to have been simplified
Text/Regex/TDFA/ReadRegex.hs view
@@ -64,7 +64,7 @@ p_bound_spec atom = do lowS <- many1 digit let lowI = read lowS highMI <- option (Just lowI) $ try $ do - char ','+ _ <- char ',' -- parsec note: if 'many digits' fails below then the 'try' ensures -- that the ',' will not match the closing '}' in p_bound, same goes -- for any non '}' garbage after the 'many digits'.@@ -78,7 +78,7 @@ -- An anchor cannot be modified by a repetition specifier p_anchor = (char '^' >> liftM PCarat char_index) <|> (char '$' >> liftM PDollar char_index)- <|> try (do string "()" + <|> try (do _ <- string "()" index <- group_index return $ PGroup index PEmpty) <?> "empty () or anchor ^ or $"@@ -101,7 +101,7 @@ -- p_set :: Bool -> GenParser Char st Pattern p_set invert = do initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))) values <- many1 p_set_elem- char ']'+ _ <- char ']' ci <- char_index let chars = maybe'set $ initial ++ [c | BEChar c <- values ]@@ -129,7 +129,7 @@ p_set_elem_range = try $ do start <- noneOf "]-"- char '-'+ _ <- char '-' end <- noneOf "]" return (BEChars [start..end])
Text/Regex/TDFA/TNFA.hs view
@@ -52,7 +52,7 @@ import Text.Regex.TDFA.Common(QT(..),QNFA(..),QTrans,TagTask(..),TagUpdate(..),DoPa(..) ,CompOption(..)- ,Tag,TagTasks,TagList,Index,GroupIndex,GroupInfo(..)+ ,Tag,TagTasks,TagList,Index,WinTags,GroupIndex,GroupInfo(..) ,common_error,noWin,snd3,mapSnd) import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView ,SetTestInfo(..),Wanted(..),TestInfo@@ -96,7 +96,7 @@ notNullable = null . nullQ -- This asks if the preferred (i.e. first) NullView has no tests.-maybeOnlyEmpty :: Q -> Maybe TagTasks+maybeOnlyEmpty :: Q -> Maybe WinTags maybeOnlyEmpty (Q {nullQ = ((SetTestInfo sti,tags):_)}) = if EMap.null sti then Just tags else Nothing maybeOnlyEmpty _ = Nothing @@ -167,10 +167,9 @@ losing to a branch of "lose" and winning to a branch of "win". Tests not in sti are unchanged (but the losing DoPa index might be added). -}-dominate :: QT -> QT -> (SetTestInfo,TagTasks) -> QT-dominate win lose x@(SetTestInfo sti,tagTasks) = debug ("dominate "++show x) $+dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT+dominate win lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $ let -- The winning states are reached through the SetTag- tags = [ (tag,PreUpdate task) | (tag,task) <- tagTasks ] win' = prependTags' tags win -- get the SetTestInfo winTests = listTestInfo win $ mempty@@ -242,7 +241,7 @@ -- This takes a function which implements a policy on mergining -- winning transitions and then merges all the transitions. It opens -- the CharMap newtype for more efficient operation, then rewraps it.-mergeQTWith :: (TagList -> TagList -> TagList) -> QT -> QT -> QT+mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT mergeQTWith mergeWins = merge where merge :: QT -> QT -> QT merge (Simple w1 t1 o1) (Simple w2 t2 o2) =@@ -367,10 +366,17 @@ promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList promoteTasks promote tags = map (\(tag,task) -> (tag,promote task)) tags +-- only used in addWinTags+demoteTags :: TagList -> TagTasks+demoteTags = map helper+ where helper (tag,PreUpdate tt) = (tag,tt)+ helper (tag,PostUpdate tt) = (tag,tt)+ -- This is polymorphic so addWinTags can be cute below {-# INLINE addWinTags #-}-addWinTags :: TagTasks -> (TagTasks,a) -> (TagTasks,a)-addWinTags wtags (tags,cont) = (wtags `mappend` tags,cont)+addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a)+addWinTags wtags (tags,cont) = (demoteTags wtags `mappend` tags+ ,cont) {-# INLINE addTag' #-} -- This is polymorphic so addTagAC can be cute below@@ -429,7 +435,7 @@ ,fmap (addGroupSets tags) mE ,fmap (addGroupSets tags) mQNFA) -addWinTagsAC :: TagTasks -> ActCont -> ActCont+addWinTagsAC :: WinTags -> ActCont -> ActCont addWinTagsAC wtags (e,mE,mQNFA) = (addWinTags wtags e ,fmap (addWinTags wtags) mE ,fmap (addWinTags wtags) mQNFA)
regex-tdfa.cabal view
@@ -1,5 +1,5 @@ Name: regex-tdfa-Version: 1.1.2+Version: 1.1.3 -- 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@@ -39,7 +39,6 @@ -- 1.0.7 make NewDFA directory and String_NC -- 1.1.0 NewDFA code working -- 1.1.1 add gnu escapes--- 1.1.2 fix fatal error with wrong "d_id" passed to compressOrbits License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2007, Christopher Kuklewicz@@ -60,7 +59,7 @@ library Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, array, bytestring if flag(base4)- Build-Depends: base >= 4.0, ghc-prim+ Build-Depends: base >= 4.0 && < 5, ghc-prim else Build-Depends: base < 4.0