diff --git a/Text/Regex/TDFA/ByteString.hs b/Text/Regex/TDFA/ByteString.hs --- a/Text/Regex/TDFA/ByteString.hs +++ b/Text/Regex/TDFA/ByteString.hs @@ -8,6 +8,7 @@ This exports instances of the high level API and the medium level API of 'compile','execute', and 'regexec'. -} +{- By Chris Kuklewicz, 2009. BSD License, see the LICENSE file. -} module Text.Regex.TDFA.ByteString( Regex ,CompOption @@ -25,9 +26,12 @@ import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String import Text.Regex.TDFA.TDFA(patternToRegex) -import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) +import Text.Regex.TDFA.Common(Regex(..),CompOption,ExecOption(captureGroups)) +import Text.Regex.TDFA.Wrap() -{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} +import Data.Maybe(listToMaybe) +import Text.Regex.TDFA.NewDFA.Engine(execMatch) +import Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest) instance RegexContext Regex B.ByteString B.ByteString where match = polymatch @@ -37,10 +41,11 @@ makeRegexOptsM c e source = makeRegexOptsM c e (B.unpack source) instance RegexLike Regex B.ByteString where - matchOnce r = matchOnce r . B.unpack - matchAll r = matchAll r . B.unpack - matchCount r = matchCount r . B.unpack - matchTest r = matchTest r . B.unpack + matchOnce r s = listToMaybe (matchAll r s) + matchAll r s = execMatch r 0 '\n' s + matchCount r s = length (matchAll r' s) + where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} } + matchTest = Tester.matchTest matchOnceText regex source = fmap (\ma -> let (o,l) = ma!0 in (B.take o source diff --git a/Text/Regex/TDFA/ByteString/Lazy.hs b/Text/Regex/TDFA/ByteString/Lazy.hs --- a/Text/Regex/TDFA/ByteString/Lazy.hs +++ b/Text/Regex/TDFA/ByteString/Lazy.hs @@ -17,7 +17,7 @@ ,regexec ) where -import Data.Array((!),elems) +import Data.Array.IArray((!),elems,amap) import qualified Data.ByteString.Lazy.Char8 as L import Text.Regex.Base(MatchArray,RegexContext(..),RegexMaker(..),RegexLike(..)) @@ -25,8 +25,13 @@ import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String import Text.Regex.TDFA.TDFA(patternToRegex) -import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) +import Text.Regex.TDFA.Common(Regex(..),CompOption,ExecOption(captureGroups)) +import Text.Regex.TDFA.Wrap() +import Data.Maybe(listToMaybe) +import Text.Regex.TDFA.NewDFA.Engine(execMatch) +import Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest) + {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} instance RegexContext Regex L.ByteString L.ByteString where @@ -37,10 +42,11 @@ makeRegexOptsM c e source = makeRegexOptsM c e (L.unpack source) instance RegexLike Regex L.ByteString where - matchOnce r = matchOnce r . L.unpack - matchAll r = matchAll r . L.unpack - matchCount r = matchCount r . L.unpack - matchTest r = matchTest r . L.unpack + matchOnce r s = listToMaybe (matchAll r s) + matchAll r s = execMatch r 0 '\n' s + matchCount r s = length (matchAll r' s) + where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} } + matchTest = Tester.matchTest matchOnceText regex source = fmap (\ma -> let (o32,l32) = ma!0 @@ -54,8 +60,14 @@ ,L.drop (o+l) source)) (matchOnce regex source) matchAllText regex source = - map (fmap (\ol@(off32,len32) -> (L.take (fi len32) (L.drop (fi off32) source),ol))) - (matchAll regex source) + let go i _ _ | i `seq` False = undefined + go i t [] = [] + go i t (x:xs) = + let (off0,len0) = x!0 + trans pair@(off32,len32) = (L.take (fi len32) (L.drop (fi (off32-i)) t),pair) + t' = L.drop (fi (off0+len0-i)) t + in amap trans x : seq t' (go (i+off0+len0) t' xs) + in go 0 source (matchAll regex source) fi = fromIntegral diff --git a/Text/Regex/TDFA/Common.hs b/Text/Regex/TDFA/Common.hs --- a/Text/Regex/TDFA/Common.hs +++ b/Text/Regex/TDFA/Common.hs @@ -121,6 +121,7 @@ ,regex_trie :: TrieSet DFA -- ^ All DFA states ,regex_tags :: Array Tag OP -- ^ information about each tag ,regex_groups :: Array GroupIndex [GroupInfo] -- ^ information about each group + ,regex_isFrontAnchored :: Bool -- ^ used for optimizing execution ,regex_compOptions :: CompOption -- ,regex_execOptions :: ExecOption} @@ -178,7 +179,7 @@ -- | Internal to the DFA node data DT = Simple' { dt_win :: IntMap {- Source Index -} Instructions -- ^ Actions to perform to win , dt_trans :: CharMap Transition -- ^ Transition to accept Char - , dt_other :: Maybe Transition -- ^ Optional default accepting transition + , dt_other :: Transition -- ^ default accepting transition } | Testing' { dt_test :: WhichTest -- ^ The test to perform , dt_dopas :: EnumSet DoPa -- ^ location(s) of the anchor(s) in the original regexp @@ -273,8 +274,7 @@ ,seeDTrans dtrans ,")"]) (Map.assocs t) - seeOther1 Nothing = "None" - seeOther1 (Just (Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans})) = + seeOther1 (Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) = concat ["(MANY " ,show (d_id dfa) ,", SINGLE " diff --git a/Text/Regex/TDFA/NewDFA.hs b/Text/Regex/TDFA/NewDFA.hs deleted file mode 100644 --- a/Text/Regex/TDFA/NewDFA.hs +++ /dev/null @@ -1,884 +0,0 @@ --- | This is the "rewrite" of RunMutState ++ MutRun. It is supposed --- to never backtrack in the consumption of the input. This is more --- complicated then RunMutState which only considered a single --- starting offset, and MutRun which incremented the starting offset --- by one with each failed match. --- --- This is not optimized for speed. -module Text.Regex.TDFA.NewDFA(matchAll,matchOnce,matchCount,matchTest) where - -import Control.Monad(when,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM) -import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) --- #ifdef __GLASGOW_HASKELL__ -import GHC.Arr(STArray(..)) -import GHC.ST(ST(..)) -import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) -{- --- #else -import Control.Monad.ST(ST) -import Data.Array.ST(STArray) --- #endif --} -import Prelude hiding ((!!)) - -import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs) -import Data.Array.IArray(Array,bounds,assocs) ---import qualified Data.Foldable as F -import qualified Data.IntMap.CharMap2 as CMap(lookup) -import Data.IntMap(IntMap) -import qualified Data.IntMap as IMap(null,toList,lookup,insert) -import Data.Ix(Ix,rangeSize,range) -import Data.Maybe(catMaybes,listToMaybe) -import Data.Monoid(Monoid(..)) ---import Data.IntSet(IntSet) -import qualified Data.IntSet as ISet(toAscList) -import qualified Data.Array.ST -import Data.Array.IArray((!)) -import qualified Data.Array.MArray -import Data.List(partition,sort,foldl',sortBy,groupBy) -import Data.STRef -import qualified Control.Monad.ST.Lazy as L -import qualified Control.Monad.ST.Strict as S -import Data.Sequence(ViewL(..),viewl) -import qualified Data.Sequence as Seq - -import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) -import qualified Text.Regex.TDFA.IntArrTrieSet as Trie -import Text.Regex.TDFA.Common hiding (indent) -import Text.Regex.TDFA.TDFA(isDFAFrontAnchored) - ---import Debug.Trace - --- trace :: String -> a -> a --- trace _ a = a - -err :: String -> a -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 -(!!) = unsafeRead -{-# INLINE set #-} -set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () -set = unsafeWrite - -matchAll :: Regex -> String -> [MatchArray] -matchAll r s = execMatch r 0 '\n' s - -matchOnce :: Regex -> String -> Maybe MatchArray -matchOnce r s = listToMaybe (matchAll r s) - -matchCount :: Regex -> String -> Int -matchCount regexIn stringIn = length (matchAll regexNC stringIn) - where regexNC = regexIn { regex_execOptions = (regex_execOptions regexIn) {captureGroups = False} } - -matchTest :: Regex -> String -> Bool -matchTest regexIn stringIn = not (null (matchAll regexNC stringIn)) - where regexNC = regexIn { regex_execOptions = (regex_execOptions regexIn) {captureGroups = False,testMatch = True} } - -execMatch :: Regex -> Position -> Char -> String -> [MatchArray] -execMatch (Regex { regex_dfa = dfaIn - , regex_init = startState - , regex_b_index = b_index - , regex_b_tags = b_tags_all - , regex_trie = trie - , regex_tags = aTags - , regex_groups = aGroups - , regex_compOptions = CompOption { multiline = newline } - , regex_execOptions = ExecOption { captureGroups = capture - , testMatch = _checkMatch }}) - offsetIn prevIn inputIn = L.runST runCaptureGroup where - -{- - msg = "subCapture "++show subCapture - ++ ", frontAnchored "++show (frontAnchored,(not newline,isDFAFrontAnchored dfaIn)) - ++ ", b_index "++show b_index - ++ ", b_tags "++show b_tags - ++ ", orbitTags "++show orbitTags --} - - subCapture,frontAnchored :: Bool - !subCapture = capture && (1<=rangeSize (bounds aGroups)) - !frontAnchored = (not newline) && isDFAFrontAnchored dfaIn - - b_tags :: (Tag,Tag) - !b_tags | subCapture = b_tags_all - | otherwise = (0,1) - - orbitTags :: [Tag] - !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags - - test :: WhichTest -> Index -> Char -> String -> Bool - !test = mkTest newline - - spawnStart :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position - spawnStart | frontAnchored = \ _ _ _ _ _ -> return maxBound - | otherwise = spawnAt -- regardless of subCapture - - doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () - doActions | subCapture = doAllActions - | otherwise = \ _ _ _ -> return () - - doFinalActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () - doFinalActions | subCapture = doAllActions - | otherwise = do01Actions - - comp :: C s - comp | subCapture = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags - | otherwise = comp01 - - tagsToGroupsST | subCapture = tagsToAllGroupsST - | otherwise = tagsToGroup0ST - - runCaptureGroup :: L.ST s [MatchArray] - runCaptureGroup = {-# SCC "runCaptureGroup" #-} do - obtainNext <- L.strictToLazyST constructNewEngine - let loop = do vals <- L.strictToLazyST obtainNext - if null vals -- force vals before defining valsRest - then return [] - else do valsRest <- loop - return (vals ++ valsRest) - loop - --- constructNewEngine :: forall s. S.ST s (S.ST s [MatchArray]) - constructNewEngine = {-# SCC "constructNewEngine" #-} do - (SScratch s1In s2In restScratch@(_winQ,blank,_which)) <- newScratch b_index b_tags - spawnAt b_tags blank startState s1In offsetIn - storeNext <- newSTRef undefined - writeSTRef storeNext (goNext storeNext restScratch s1In s2In dfaIn offsetIn prevIn inputIn) - let obtainNext = join (readSTRef storeNext) - return obtainNext - - goNext storeNext (winQ,blank,which) s1In' s2In' dfaIn' offsetIn' prevIn' inputIn' = {-# SCC "goNext" #-} do - writeSTRef storeNext (err "obtainNext called while goNext is running!") - eliminatedStateFlag <- newSTRef False - eliminatedRespawnFlag <- newSTRef False - let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-} - case dt of - Testing' {dt_test=wt,dt_a=a,dt_b=b} -> - if test wt offset prev input - then next s1 s2 did a offset prev input - else next s1 s2 did b offset prev input - Simple' {dt_win=w} -> do - if IMap.null w then proceedNow s1 s2 did dt offset prev input - else newWinnerThenProceed s1 s2 did dt offset prev input - - proceedNow | frontAnchored = proceedNowSingle - | otherwise = proceedNowMany - - proceedNowSingle s1 s2 did dt offset prev input = {-# SCC "goNext.proceedNowSingle" #-} - case dt of - Testing' {dt_test=wt,dt_a=a,dt_b=b} -> - if test wt offset prev input - then proceedNow s1 s2 did a offset prev input - else proceedNow s1 s2 did b offset prev input - Simple' {dt_trans=t, dt_other=o} -> - case input of - [] -> finalizeWinners - (c:input') -> do - case (CMap.lookup c t) `mplus` o of - Nothing -> return [] - Just (Transition {trans_single=dfa',trans_how=dtrans}) -> - findTrans s1 s2 (d_id dfa') (d_dt dfa') dtrans offset c input' - - proceedNowMany s1 s2 did dt offset prev input = {-# SCC "goNext.proceedNowMany" #-} - case dt of - Testing' {dt_test=wt,dt_a=a,dt_b=b} -> - if test wt offset prev input - then proceedNow s1 s2 did a offset prev input - else proceedNow s1 s2 did b offset prev input - Simple' {dt_trans=t, dt_other=o} -> - case input of - [] -> finalizeWinners - (c:input') -> do - case (CMap.lookup c t) `mplus` o of - Nothing -> error "proceedNowMany found no destination (should always include startstate)" - Just (Transition {trans_many=dfa',trans_how=dtrans}) -> - findTrans s1 s2 (d_id dfa') (d_dt dfa') 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 --- compressOrbit. --- --- compressOrbit on such a Tag loops through all the NFS states' --- m_orbit record, discardind ones that are Nothing and discarding --- ones that are too new to care about (after the cutoff value). --- --- compressOrbit then groups the Orbits records by the Tag-0 start --- position and the basePos position. Entried in different groups --- will never be comparable in the future so they can be processed --- separately. Groups could probably be even more finely --- distinguished, as a futher optimization, but the justification will --- be tricky. --- --- Current Tag-0 values are at most offset and all newly spawned --- groups will have Tag-0 of at least (succ offset) so the current --- groups are closed to those spawned in the future. The basePos may --- be as large as offset and may be overwritten later with values of --- offset or larger (and this will also involve deleting the Orbits --- record). Thus there could be a future collision between a current --- group with basePos==offset and an updated record that acquires --- basePos==offset. By excluding groups with basePos before the --- current offset the collision between existing and future records --- is avoided. --- --- An entry in a group can only collide with that group's --- descendents. compressOrbit sends each group to the compressGroup --- command. --- --- compressGroup on a single record checks whether it's Seq can be --- cleared and if so it will clear it (and set ordinal to Nothing but --- this this not particularly important). --- --- compressGroup on many records sorts and groups the members and zips --- the groups with their new ordinal value. The comparision is based --- on the old ordinal value, then the inOrbit value, and then the (Seq --- Position) data. --- --- The old ordinals of the group will all be Nothing or all be Just, --- but this condition is neither checked nor violations detected. --- This comparision is justified because once records get different --- ordinals assigned they will never change places. --- --- The inOrbit Bool is only different if one of them has set the stop --- position to at most (succ offset). They will obly be compared if --- the other one leaves, an its stop position will be at least offset. --- The previous sentence is justified by inspectin of the "assemble" --- function in the TDFA module: there is no (PostUpdate --- LeaveOrbitTask) so the largest possible value for the stop Tag is --- (pred offset). Thus the record with inOrbit==False would beat (be --- GT than) the record with inOrbit==True. --- --- The Seq comparison is safe because the largest existing Position --- value is (pred offset) and the smallest future Position value is --- offset. The previous sentence is justified by inspectin of the --- "assemble" function in the TDFA module: there is no (PostUpdate --- EnterOrbitTags) so the largest possible value in the Seq is (pred --- offset). --- --- The updated Orbits get the new ordinal value and an empty (Seq --- Position). - - compressOrbits s1 did offset = do - let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state - return (state,start) - cutoff = offset - 50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50 - ss <- mapM getStart (ISet.toAscList did) - let compressOrbit tag = do - mos <- forM ss ( \ p@(state,_start) -> do - mo <- fmap (IMap.lookup tag) (m_orbit s1 !! state) - case mo of - Just orbits | basePos orbits < cutoff -> return (Just (p,orbits)) - | otherwise -> return Nothing - _ -> return Nothing ) - let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return () - | otherwise = - set (m_orbit s1) state - . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty})) - =<< m_orbit s1 !! state - - compressGroup gs = do - let sortPos (_,b1) (_,b2) = compare (ordinal b1) (ordinal b2) `mappend` - compare (inOrbit b2) (inOrbit b1) `mappend` - comparePos (viewl (getOrbits b1)) (viewl (getOrbits b2)) - groupPos (_,b1) (_,b2) = ordinal b1 == ordinal b2 && getOrbits b1 == getOrbits b2 - gs' = zip [(1::Int)..] (groupBy groupPos . sortBy sortPos $ gs) - forM_ gs' $ \ (!n,eqs) -> do - forM_ eqs $ \ ((state,_),orbit) -> - set (m_orbit s1) state - . (IMap.insert tag $! (orbit { ordinal = Just n, getOrbits = mempty })) - =<< m_orbit s1 !! state - let sorter ((_,a1),b1) ((_,a2),b2) = compare a1 a2 `mappend` compare (basePos b1) (basePos b2) - grouper ((_,a1),b1) ((_,a2),b2) = a1==a2 && basePos b1 == basePos b2 - orbitGroups = groupBy grouper . sortBy sorter . catMaybes $ mos - mapM_ compressGroup orbitGroups - mapM_ compressOrbit orbitTags - --- findTrans has to (part 1) decide, for each destination, "which" of --- zero or more source NFA states will be the chosen source. Then it --- has to (part 2) perform the transition or spawn. It keeps track of --- the starting index while doing so, and compares the earliest start --- with the stored winners. (part 3) If some winners are ready to be --- released then the future continuation of the search is placed in --- "storeNext". If no winners are ready to be released then the --- computation continues immediately. - - 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) - -- findTrans part 1 - let findTransTo (destIndex,sources) | IMap.null sources = - set which destIndex ((-1,Instructions { newPos = [(0,SetPost)], newOrbits = Nothing }) - ,blank_pos blank,mempty) - | otherwise = do - let prep (sourceIndex,(_dopa,instructions)) = {-# SCC "goNext.findTrans.prep" #-} do -{- - ms1 <- showMS s1 sourceIndex - let msg = unlines $ [ "findTrans prep: "++show (sourceIndex,destIndex) ++ " at offset "++show offset ++ "for d_id of "++show did' - , ms1 - , show instructions - ] - trace msg $ do --} - pos <- maybe (err $ "findTrans,1 : "++show (sourceIndex,destIndex,did')) return - =<< m_pos s1 !! sourceIndex - orbit <- m_orbit s1 !! sourceIndex - let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) - return ((sourceIndex,instructions),pos,orbit') - challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do - check <- comp offset x1 (newPos ins1) x2 (newPos ins2) -{- - ms1 <- showMS s1 _si1 - ms2 <- showMS s1 _si2 - let msg = unlines $ [ "findTrans challenge: "++show ((_si1,_si2),destIndex) ++ " at offset "++show offset ++ "for d_id of "++show did' - , ms1 - , show ins1 - , show _o1 - , ms2 - , show ins2 - , show _o2 - , "Result "++show check - ] - trace msg $ do --} - if check==LT then return x2 else return x1 - (first:rest) <- mapM prep (IMap.toList sources) - set which destIndex =<< foldM challenge first rest - let dl = IMap.toList dtrans - mapM_ findTransTo dl - -- findTrans part 2 - let performTransTo (destIndex,_) = {-# SCC "goNext.findTrans.performTransTo" #-} do - x@((sourceIndex,_instructions),_pos,_orbit') <- which !! destIndex - if sourceIndex == (-1) - then spawnStart b_tags blank destIndex s2 (succ offset) - else updateCopy doActions x offset s2 destIndex - earlyStart <- fmap minimum $ mapM performTransTo dl - -- findTrans part 3 - earlyWin <- readSTRef (mq_earliest winQ) - if earlyWin < earlyStart - then do - winners <- fmap (foldl' (\ rest ws -> ws : rest) []) $ - getMQ earlyStart winQ - writeSTRef storeNext (next s2 s1 did' dt' (succ offset) prev' input') - mapM (tagsToGroupsST aGroups) winners - else do - let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input' - --- The "newWinnerThenProceed" can find both a new non-empty winner and --- a new empty winner. A new non-empty winner can cause some of the --- NFA states that comprise the DFA state to be eliminated, and if the --- startState is eliminated then it must then be respawned. And --- imperative flag setting and resetting style is used. --- --- A non-empty winner from the startState might obscure a potential --- empty winner (form the startState at the current offset). This --- winEmpty possibility is also checked for. (unit test pattern ".*") --- (futher test "(.+|.+.)*" on "aa\n") - - newWinnerThenProceed s1 s2 did dt offset prev input = {-# SCC "goNext.newWinnerThenProceed" #-} - case dt of - Testing' {dt_test=wt,dt_a=a,dt_b=b} -> - if test wt offset prev input - then newWinnerThenProceed s1 s2 did a offset prev input - else newWinnerThenProceed s1 s2 did b offset prev input - Simple' {dt_win=w} -> do - let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do - pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex - startPos <- pos !! 0 - orbit <- m_orbit s1 !! sourceIndex - let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) - return (startPos,(x,pos,orbit')) - challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do - check <- comp offset x1 (newPos ins1) x2 (newPos ins2) -{- - ms1 <- showMS s1 _si1 - ms2 <- showMS s1 _si2 - let msg = unlines $ [ "newWinnerThenProceed challenge: "++show (_si1,_si2) ++ " at offset "++show offset - , ms1 - , show ins1 - , show _o1 - , ms2 - , show ins2 - , show _o2 - , "Result "++show check - ] - trace msg $ do --} - if check==LT then return x2 else return x1 - prep'd <- mapM prep (IMap.toList w) - let (emptyFalse,emptyTrue) = partition ((offset >) . fst) prep'd - mayID <- {-# SCC "goNext.newWinnerThenProceed.mayID" #-} - case map snd emptyFalse of - [] -> return Nothing - (first:rest) -> do - best@((_sourceIndex,_instructions),bp,_orbit') <- foldM challenge first rest - newWinner offset best - startWin <- bp !! 0 - let states = ISet.toAscList did - keepState i1 = do - pos <- maybe (err "newWinnerThenProceed,2") return =<< m_pos s1 !! i1 - startsAt <- pos !! 0 - let keep = (startsAt <= startWin) || (offset <= startsAt) - when (not keep) $ do - writeSTRef eliminatedStateFlag True - when (i1 == startState) (writeSTRef eliminatedRespawnFlag True) - return keep - states' <- filterM keepState states - changed <- readSTRef eliminatedStateFlag - if changed then return (Just states') else return Nothing - case emptyTrue of - [] -> case IMap.lookup startState w of - Nothing -> return () - Just ins -> winEmpty offset ins - [first] -> newWinner offset (snd first) - _ -> err "newWinnerThenProceed,3 : too many emptyTrue values" - case mayID of - Nothing -> proceedNow s1 s2 did dt offset prev input - Just states' -> do - writeSTRef eliminatedStateFlag False - respawn <- readSTRef eliminatedRespawnFlag - if respawn - then do - writeSTRef eliminatedRespawnFlag False - spawnStart b_tags blank startState s1 (succ offset) - let dfa' = Trie.lookupAsc trie (sort (states'++[startState])) - proceedNow s1 s2 (d_id dfa') (d_dt dfa') offset prev input - else do - let dfa' = Trie.lookupAsc trie states' - proceedNow s1 s2 (d_id dfa') (d_dt dfa') offset prev input - - winEmpty preTag winInstructions = {-# SCC "goNext.winEmpty" #-} do - newerPos <- newA_ b_tags - copySTU (blank_pos blank) newerPos - set newerPos 0 preTag - doFinalActions preTag newerPos (newPos winInstructions) - putMQ (WScratch newerPos) winQ - - newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do - newerPos <- newA_ b_tags - copySTU oldPos newerPos - doFinalActions preTag newerPos (newPos winInstructions) - putMQ (WScratch newerPos) winQ - - finalizeWinners = do - winners <- fmap (foldl' (\ rest mqa -> mqa_ws mqa : rest) []) $ - readSTRef (mq_list winQ) -- reverses the winner list - resetMQ winQ - writeSTRef storeNext (return []) - mapM (tagsToGroupsST aGroups) winners - - -- goNext then ends with the next statement - next s1In' s2In' (d_id dfaIn') (d_dt dfaIn') offsetIn' prevIn' inputIn' - -{-# INLINE do01Actions #-} -do01Actions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () -do01Actions preTag pos ins = doAllActions preTag pos (filter ((1>=) . fst) ins) - -{-# INLINE doAllActions #-} -doAllActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () -doAllActions preTag pos ins = mapM_ doAction ins where - postTag = succ preTag - doAction (tag,SetPre) = set pos tag preTag - doAction (tag,SetPost) = set pos tag postTag - doAction (tag,SetVal v) = set pos tag v - - -{- - -Lets say that NFA states start at positions 0,1,2,3,4,5 and offset is 5. -Thus none are in the startState. -We are about to process the 6th character. -The first winner is now found, and it starts with the index 2 and ends at index 5 (always the offset). -In addition a null winner starting and ending at 5 is found (between 5th and 6th characters). -Lets also say that the 0,2,4 NFA states _may_ transition next to include the startState -position 0 -> keep (might win startState, which is okay) -position 1 -> keep (normal keep case) -position 2 -> keep (just created winner, may be extended) -position 3 -> drop (normal drop case) -position 4 -> drop (must not win startState) -position 5 -> keep (just created empty winner) - -if "position 0" does feed a start state then a new one will be respawn, starting with "position 6". - --} - ----- - -{-# INLINE mkTest #-} -mkTest :: Bool -> WhichTest -> Index -> Char -> String -> Bool -mkTest isMultiline = if isMultiline then test_multiline else test_singleline - where test_multiline Test_BOL _off prev _input = prev == '\n' - test_multiline Test_EOL _off _prev input = case input of - [] -> True - (next:_) -> next == '\n' - test_singleline Test_BOL off _prev _input = off == 0 - test_singleline Test_EOL _off _prev input = null input - ----- - -{- MUTABLE WINNER QUEUE -} - -data MQA s = MQA {mqa_start :: !Position, mqa_ws :: !(WScratch s)} - -data MQ s = MQ { mq_earliest :: !(STRef s Position) - , mq_list :: !(STRef s [MQA s]) - } - -newMQ :: S.ST s (MQ s) -newMQ = do - earliest <- newSTRef maxBound - list <- newSTRef [] - return (MQ earliest list) - -resetMQ :: MQ s -> S.ST s () -resetMQ (MQ {mq_earliest=earliest,mq_list=list}) = do - writeSTRef earliest maxBound - writeSTRef list [] - -putMQ :: WScratch s -> MQ s -> S.ST s () -putMQ ws (MQ {mq_earliest=earliest,mq_list=list}) = do -{- - sws <-s howWS ws - let msg = "putMQ\n"++sws - trace msg $ do --} - start <- w_pos ws !! 0 - let mqa = MQA start ws - startE <- readSTRef earliest - if start <= startE - then writeSTRef earliest start >> writeSTRef list [mqa] - else do - old <- readSTRef list - let !rest = dropWhile (\ m -> start <= mqa_start m) old - !new = mqa : rest - writeSTRef list new - -getMQ :: Position -> MQ s -> ST s [WScratch s] -getMQ pos (MQ {mq_earliest=earliest,mq_list=list}) = do - old <- readSTRef list - case span (\m -> pos <= mqa_start m) old of - ([],ans) -> do - writeSTRef earliest maxBound - writeSTRef list [] - return (map mqa_ws ans) - (new,ans) -> do - writeSTRef earliest (mqa_start (last new)) - writeSTRef list new - return (map mqa_ws ans) - -{- MUTABLE SCRATCH DATA STRUCTURES -} - -data SScratch s = SScratch { _s_1 :: !(MScratch s) - , _s_2 :: !(MScratch s) - , _s_rest :: !( MQ s - , BlankScratch s - , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog) - ) - } -data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position))) - , m_orbit :: !(STArray s Index OrbitLog) - } -newtype BlankScratch s = BlankScratch { blank_pos :: (STUArray s Tag Position) - } -newtype WScratch s = WScratch { w_pos :: (STUArray s Tag Position) - } - -{- DEBUGGING HELPERS -} - -{- -indent :: String -> String -indent xs = ' ':' ':xs - -showMS :: MScratch s -> Index -> ST s String -showMS s i = do - ma <- m_pos s !! i - mc <- m_orbit s !! i - a <- case ma of - Nothing -> return "No pos" - Just pos -> fmap show (getAssocs pos) - let c = show mc - return $ unlines [ "MScratch, index = "++show i - , indent a - , indent c] - -showWS :: WScratch s -> ST s String -showWS (WScratch pos) = do - a <- getAssocs pos - return $ unlines [ "WScratch" - , indent (show a)] --} -{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -} - -{-# INLINE newA #-} -newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e) -newA b_tags initial = newArray b_tags initial - -{-# INLINE newA_ #-} -newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e) -newA_ b_tags = newArray_ b_tags - -newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s) -newScratch b_index b_tags = do - s1 <- newMScratch b_index - s2 <- newMScratch b_index - winQ <- newMQ - blank <- fmap BlankScratch (newA b_tags (-1)) - which <- (newArray b_index ((-1,err "newScratch which 1"),err "newScratch which 2",err "newScratch which 3")) - return (SScratch s1 s2 (winQ,blank,which)) - -newMScratch :: (Index,Index) -> S.ST s (MScratch s) -newMScratch b_index = do - pos's <- newArray b_index Nothing - orbit's <- newArray b_index mempty - return (MScratch pos's orbit's) - -{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -} - -newtype F s = F ([F s] -> C s) -type C s = Position - -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) - -> [(Int, Action)] - -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) - -> [(Int, Action)] - -> ST s Ordering - -{-# INLINE orderOf #-} -orderOf :: Action -> Action -> Ordering -orderOf post1 post2 = - case (post1,post2) of - (SetPre,SetPre) -> EQ - (SetPost,SetPost) -> EQ - (SetPre,SetPost) -> LT - (SetPost,SetPre) -> GT - (SetVal v1,SetVal v2) -> compare v1 v2 - _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2) - -comp01 :: C s -comp01 preTag (_state1,pos1,_orbit1') np1 (_state2,pos2,_orbit2') np2 = do - c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize - case c of - EQ -> challenge1 - answer -> return answer - where - challenge1 = do - case np1 of - ((t1,b1):_rest1) | t1==1 -> do - let p1 = case b1 of SetPre -> preTag - SetPost -> succ preTag - SetVal v -> v - case np2 of - ((t2,b2):_rest2) | t2==1 -> do - let p2 = case b2 of SetPre -> preTag - SetPost -> succ preTag - SetVal v -> v - return (compare p1 p2) - _ -> do - p2 <- pos2 !! 1 - return (compare p1 p2) - _ -> do - p1 <- pos1 !! 1 - case np2 of - ((t2,b2):_rest2) | t2==1 -> do - let p2 = case b2 of SetPre -> preTag - SetPost -> succ preTag - SetVal v -> v - return (compare p1 p2) - _ -> do - p2 <- pos2 !! 1 - return (compare p1 p2) - -ditzyComp'3 :: forall s. Array Tag OP -> C s -ditzyComp'3 aTagOP = comp0 where - (F comp1:compsRest) = allcomps 1 - - comp0 :: C s - comp0 preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = do - c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize - case c of - EQ -> comp1 compsRest preTag x1 np1 x2 np2 - answer -> return answer - - allcomps :: Tag -> [F s] - allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)] - | otherwise = - case aTagOP ! tag of - Orbit -> F (challenge_Orb tag) : allcomps (succ tag) - Maximize -> F (challenge_Max tag) : allcomps (succ tag) - Ignore -> F (challenge_Ignore tag) : allcomps (succ tag) - Minimize -> err "allcomps Minimize" - where top = snd (bounds aTagOP) - - challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 = - case np1 of - ((t1,_):rest1) | t1==tag -> - case np2 of - ((t2,_):rest2) | t2==tag -> next comps preTag x1 rest1 x2 rest2 - _ -> next comps preTag x1 rest1 x2 np2 - _ -> do - case np2 of - ((t2,_):rest2) | t2==tag -> next comps preTag x1 np1 x2 rest2 - _ -> next comps preTag x1 np1 x2 np2 - challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867" - - challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = - case np1 of - ((t1,b1):rest1) | t1==tag -> - case np2 of - ((t2,b2):rest2) | t2==tag -> - if b1==b2 then next comps preTag x1 rest1 x2 rest2 - else return (orderOf b1 b2) - _ -> do - p2 <- pos2 !! tag - let p1 = case b1 of SetPre -> preTag - SetPost -> succ preTag - SetVal v -> v - if p1==p2 then next comps preTag x1 rest1 x2 np2 - else return (compare p1 p2) - _ -> do - p1 <- pos1 !! tag - case np2 of - ((t2,b2):rest2) | t2==tag -> do - let p2 = case b2 of SetPre -> preTag - SetPost -> succ preTag - SetVal v -> v - if p1==p2 then next comps preTag x1 np1 x2 rest2 - else return (compare p1 p2) - _ -> do - p2 <- pos2 !! tag - if p1==p2 then next comps preTag x1 np1 x2 np2 - else return (compare p1 p2) - challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" - - challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = - let s1 = IMap.lookup tag orbit1' - s2 = IMap.lookup tag orbit2' - in case (s1,s2) of - (Nothing,Nothing) -> next comps preTag x1 np1 x2 np2 - (Just o1,Just o2) | inOrbit o1 == inOrbit o2 -> - case compare (ordinal o1) (ordinal o2) `mappend` - 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 - ] - challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" - -comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering -comparePos EmptyL EmptyL = EQ -comparePos EmptyL _ = GT -comparePos _ EmptyL = LT -comparePos (p1 :< ps1) (p2 :< ps2) = - compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2) - -{- CONVERT WINNERS TO MATCHARRAY -} - -tagsToGroup0ST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray -tagsToGroup0ST _aGroups (WScratch {w_pos=pos})= do - ma <- newArray (0,0) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) - startPos0 <- pos !! 0 - stopPos0 <- pos !! 1 - set ma 0 (startPos0,stopPos0-startPos0) - unsafeFreeze ma - -tagsToAllGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray -tagsToAllGroupsST aGroups (WScratch {w_pos=pos})= do - let b_max = snd (bounds (aGroups)) - ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) - startPos0 <- pos !! 0 - stopPos0 <- pos !! 1 - set ma 0 (startPos0,stopPos0-startPos0) - let act _this_index [] = return () - act this_index ((GroupInfo _ parent start stop flagtag):gs) = do - flagVal <- pos !! flagtag - if (-1) == flagVal then act this_index gs - else do - startPos <- pos !! start - stopPos <- pos !! stop - (startParent,lengthParent) <- ma !! parent - let ok = (0 <= startParent && - 0 <= lengthParent && - startParent <= startPos && - stopPos <= startPos + lengthParent) - if not ok then act this_index gs - else set ma this_index (startPos,stopPos-startPos) - forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i)) - unsafeFreeze ma - -{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -} - -{-# 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 b_tags (BlankScratch blankPos) i s1 thisPos = do - oldPos <- m_pos s1 !! i - pos <- case oldPos of - Nothing -> do - pos' <- newA_ b_tags - set (m_pos s1) i (Just pos') - return pos' - Just pos -> return pos - copySTU blankPos pos - set (m_orbit s1) i $! mempty - set pos 0 thisPos - return thisPos - -{-# INLINE updateCopy #-} -updateCopy :: (Index -> STUArray s Tag Position -> [(Tag, Action)] -> ST s a) - -> ((Index, Instructions), STUArray s Tag Position, OrbitLog) - -> Index - -> MScratch s - -> Int - -> ST s Position -updateCopy doActions ((_i1,instructions),oldPos,newOrbit) preTag s2 i2 = do - b_tags <- getBounds oldPos - newerPos <- maybe (do - a <- newA_ b_tags - set (m_pos s2) i2 (Just a) - return a) return =<< m_pos s2 !! i2 - copySTU oldPos newerPos - doActions preTag newerPos (newPos instructions) - set (m_orbit s2) i2 $! newOrbit - newerPos !! 0 - -{- USING memcpy TO COPY STUARRAY DATA -} - --- #ifdef __GLASGOW_HASKELL__ -foreign import ccall unsafe "memcpy" - memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO () - -{- -Prelude Data.Array.Base> :i STUArray -data STUArray s i e - = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s) - -- Defined in Data.Array.Base --} --- 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) = --- 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 #) }} -{- -#else /* !__GLASGOW_HASKELL__ */ - -copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) -copySTU source destination = do - b@(start,stop) <- getBounds source - b' <- getBounds destination - -- traceCopy ("> copySTArray "++show b) $ do - when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b')) - forM_ (range b) $ \index -> - set destination index =<< source !! index - return destination -#endif /* !__GLASGOW_HASKELL__ */ --} diff --git a/Text/Regex/TDFA/NewDFA/Engine.hs b/Text/Regex/TDFA/NewDFA/Engine.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Engine.hs @@ -0,0 +1,774 @@ +-- | This is the code for the main engine. This captures the posix subexpressions. This 'execMatch' +-- also dispatches to "Engine_NC", "Engine_FA", and "Engine_FC_NA" +-- +-- It is polymorphic over the internal Uncons type class, and specialized to produce the needed +-- variants. +module Text.Regex.TDFA.NewDFA.Engine(execMatch) where + +import Control.Monad(when,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM) +import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) +-- #ifdef __GLASGOW_HASKELL__ +import GHC.Arr(STArray(..)) +import GHC.ST(ST(..)) +import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) +{- +-- #else +import Control.Monad.ST(ST) +import Data.Array.ST(STArray) +-- #endif +-} +import Prelude hiding ((!!)) + +import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs) +import Data.Array.IArray(Array,bounds,assocs) +--import qualified Data.Foldable as F +import qualified Data.IntMap.CharMap2 as CMap(lookup,findWithDefault) +import Data.IntMap(IntMap) +import qualified Data.IntMap as IMap(null,toList,lookup,insert) +import Data.Ix(Ix,rangeSize,range) +import Data.Maybe(catMaybes,listToMaybe) +import Data.Monoid(Monoid(..)) +--import Data.IntSet(IntSet) +import qualified Data.IntSet as ISet(toAscList,null) +import qualified Data.Array.ST +import Data.Array.IArray((!)) +import qualified Data.Array.MArray +import Data.List(partition,sort,foldl',sortBy,groupBy) +import Data.STRef +import qualified Control.Monad.ST.Lazy as L +import qualified Control.Monad.ST.Strict as S +import Data.Sequence(Seq,ViewL(..),viewl) +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) +import qualified Text.Regex.TDFA.IntArrTrieSet as Trie +import Text.Regex.TDFA.Common hiding (indent) +import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) +import qualified Text.Regex.TDFA.NewDFA.Engine_FA as FA(execMatch) +import qualified Text.Regex.TDFA.NewDFA.Engine_NC as NC(execMatch) +import qualified Text.Regex.TDFA.NewDFA.Engine_NC_FA as NC_FA(execMatch) + +--import Debug.Trace + +-- trace :: String -> a -> a +-- trace _ a = a + +err :: String -> a +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 +(!!) = unsafeRead +{-# INLINE set #-} +set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () +set = unsafeWrite + +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-} +execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] +execMatch r@(Regex { regex_dfa = DFA {d_id=didIn,d_dt=dtIn} + , regex_init = startState + , regex_b_index = b_index + , regex_b_tags = b_tags_all + , regex_trie = trie + , regex_tags = aTags + , regex_groups = aGroups + , regex_isFrontAnchored = frontAnchored + , regex_compOptions = CompOption { multiline = newline } + , regex_execOptions = ExecOption { captureGroups = capture + , testMatch = _checkMatch }}) + offsetIn prevIn inputIn = case (subCapture,frontAnchored) of + (True ,False) -> L.runST runCaptureGroup + (True ,True) -> FA.execMatch r offsetIn prevIn inputIn + (False ,False) -> NC.execMatch r offsetIn prevIn inputIn + (False ,True) -> NC_FA.execMatch r offsetIn prevIn inputIn + where + subCapture :: Bool + subCapture = capture && (1<=rangeSize (bounds aGroups)) + + b_tags :: (Tag,Tag) + !b_tags = b_tags_all + + orbitTags :: [Tag] + !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags + + !test = mkTest newline + + comp :: C s + comp = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags + + runCaptureGroup :: L.ST s [MatchArray] + runCaptureGroup = {-# SCC "runCaptureGroup" #-} do + obtainNext <- L.strictToLazyST constructNewEngine + let loop = do vals <- L.strictToLazyST obtainNext + if null vals -- force vals before defining valsRest + then return [] -- end of capturing + else do valsRest <- loop + return (vals ++ valsRest) + loop + + constructNewEngine :: S.ST s (S.ST s [MatchArray]) + constructNewEngine = {-# SCC "constructNewEngine" #-} do + storeNext <- newSTRef undefined + writeSTRef storeNext (goNext storeNext) + let obtainNext = join (readSTRef storeNext) + return obtainNext + + goNext storeNext = {-# SCC "goNext" #-} do + (SScratch s1In s2In (winQ,blank,which)) <- newScratch b_index b_tags + 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" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset prev input + then next s1 s2 did a offset prev input + else next s1 s2 did b offset prev input + Simple' {dt_win=w,dt_trans=t, dt_other=o} + | IMap.null w -> + case uncons input of + Nothing -> finalizeWinners + 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' dt' dtrans offset c input' + | otherwise -> do + (did',dt') <- processWinner s1 did dt w offset + next' s1 s2 did' dt' offset prev input + + next' s1 s2 did dt offset prev input = {-# SCC "goNext.next'" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset prev input + then next' s1 s2 did a offset prev input + else next' s1 s2 did b offset prev input + Simple' {dt_win=w,dt_trans=t, dt_other=o} -> + case uncons input of + Nothing -> finalizeWinners + 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' 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 +-- compressOrbit. +-- +-- compressOrbit on such a Tag loops through all the NFS states' +-- m_orbit record, discardind ones that are Nothing and discarding +-- ones that are too new to care about (after the cutoff value). +-- +-- compressOrbit then groups the Orbits records by the Tag-0 start +-- position and the basePos position. Entried in different groups +-- will never be comparable in the future so they can be processed +-- separately. Groups could probably be even more finely +-- distinguished, as a futher optimization, but the justification will +-- be tricky. +-- +-- Current Tag-0 values are at most offset and all newly spawned +-- groups will have Tag-0 of at least (succ offset) so the current +-- groups are closed to those spawned in the future. The basePos may +-- be as large as offset and may be overwritten later with values of +-- offset or larger (and this will also involve deleting the Orbits +-- record). Thus there could be a future collision between a current +-- group with basePos==offset and an updated record that acquires +-- basePos==offset. By excluding groups with basePos before the +-- current offset the collision between existing and future records +-- is avoided. +-- +-- An entry in a group can only collide with that group's +-- descendents. compressOrbit sends each group to the compressGroup +-- command. +-- +-- compressGroup on a single record checks whether it's Seq can be +-- cleared and if so it will clear it (and set ordinal to Nothing but +-- this this not particularly important). +-- +-- compressGroup on many records sorts and groups the members and zips +-- the groups with their new ordinal value. The comparision is based +-- on the old ordinal value, then the inOrbit value, and then the (Seq +-- Position) data. +-- +-- The old ordinals of the group will all be Nothing or all be Just, +-- but this condition is neither checked nor violations detected. +-- This comparision is justified because once records get different +-- ordinals assigned they will never change places. +-- +-- The inOrbit Bool is only different if one of them has set the stop +-- position to at most (succ offset). They will obly be compared if +-- the other one leaves, an its stop position will be at least offset. +-- The previous sentence is justified by inspectin of the "assemble" +-- function in the TDFA module: there is no (PostUpdate +-- LeaveOrbitTask) so the largest possible value for the stop Tag is +-- (pred offset). Thus the record with inOrbit==False would beat (be +-- GT than) the record with inOrbit==True. +-- +-- The Seq comparison is safe because the largest existing Position +-- value is (pred offset) and the smallest future Position value is +-- offset. The previous sentence is justified by inspectin of the +-- "assemble" function in the TDFA module: there is no (PostUpdate +-- EnterOrbitTags) so the largest possible value in the Seq is (pred +-- offset). +-- +-- The updated Orbits get the new ordinal value and an empty (Seq +-- Position). + + compressOrbits s1 did offset = do + let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state + return (state,start) + cutoff = offset - 50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50 + ss <- mapM getStart (ISet.toAscList did) + let compressOrbit tag = do + mos <- forM ss ( \ p@(state,_start) -> do + mo <- fmap (IMap.lookup tag) (m_orbit s1 !! state) + case mo of + Just orbits | basePos orbits < cutoff -> return (Just (p,orbits)) + | otherwise -> return Nothing + _ -> return Nothing ) + let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return () + | otherwise = + set (m_orbit s1) state + . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty})) + =<< m_orbit s1 !! state + + compressGroup gs = do + let sortPos (_,b1) (_,b2) = compare (ordinal b1) (ordinal b2) `mappend` + compare (inOrbit b2) (inOrbit b1) `mappend` + comparePos (viewl (getOrbits b1)) (viewl (getOrbits b2)) + groupPos (_,b1) (_,b2) = ordinal b1 == ordinal b2 && getOrbits b1 == getOrbits b2 + gs' = zip [(1::Int)..] (groupBy groupPos . sortBy sortPos $ gs) + forM_ gs' $ \ (!n,eqs) -> do + forM_ eqs $ \ ((state,_),orbit) -> + set (m_orbit s1) state + . (IMap.insert tag $! (orbit { ordinal = Just n, getOrbits = mempty })) + =<< m_orbit s1 !! state + let sorter ((_,a1),b1) ((_,a2),b2) = compare a1 a2 `mappend` compare (basePos b1) (basePos b2) + grouper ((_,a1),b1) ((_,a2),b2) = a1==a2 && basePos b1 == basePos b2 + orbitGroups = groupBy grouper . sortBy sorter . catMaybes $ mos + mapM_ compressGroup orbitGroups + mapM_ compressOrbit orbitTags + +-- findTrans has to (part 1) decide, for each destination, "which" of +-- zero or more source NFA states will be the chosen source. Then it +-- has to (part 2) perform the transition or spawn. It keeps track of +-- the starting index while doing so, and compares the earliest start +-- with the stored winners. (part 3) If some winners are ready to be +-- released then the future continuation of the search is placed in +-- "storeNext". If no winners are ready to be released then the +-- computation continues immediately. + + 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) + -- findTrans part 1 + let findTransTo (destIndex,sources) | IMap.null sources = + set which destIndex ((-1,Instructions { newPos = [(0,SetPost)], newOrbits = Nothing }) + ,blank_pos blank,mempty) + | otherwise = do + let prep (sourceIndex,(_dopa,instructions)) = {-# SCC "goNext.findTrans.prep" #-} do + pos <- maybe (err $ "findTrans,1 : "++show (sourceIndex,destIndex,did')) return + =<< m_pos s1 !! sourceIndex + orbit <- m_orbit s1 !! sourceIndex + let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) + return ((sourceIndex,instructions),pos,orbit') + challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do + check <- comp offset x1 (newPos ins1) x2 (newPos ins2) + if check==LT then return x2 else return x1 + (first:rest) <- mapM prep (IMap.toList sources) + set which destIndex =<< foldM challenge first rest + let dl = IMap.toList dtrans + mapM_ findTransTo dl + -- findTrans part 2 + let performTransTo (destIndex,_) = {-# SCC "goNext.findTrans.performTransTo" #-} do + x@((sourceIndex,_instructions),_pos,_orbit') <- which !! destIndex + if sourceIndex == (-1) + then spawnStart b_tags blank destIndex s2 (succ offset) + else updateCopy doActions x offset s2 destIndex + earlyStart <- fmap minimum $ mapM performTransTo dl + -- findTrans part 3 + earlyWin <- readSTRef (mq_earliest winQ) + if earlyWin < earlyStart + then do + winners <- fmap (foldl' (\ rest ws -> ws : rest) []) $ + getMQ earlyStart winQ + writeSTRef storeNext (next s2 s1 did' dt' (succ offset) prev' input') + mapM (tagsToGroupsST aGroups) winners + else do + let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input' + +-- The "newWinnerThenProceed" can find both a new non-empty winner and +-- a new empty winner. A new non-empty winner can cause some of the +-- NFA states that comprise the DFA state to be eliminated, and if the +-- startState is eliminated then it must then be respawned. And +-- imperative flag setting and resetting style is used. +-- +-- A non-empty winner from the startState might obscure a potential +-- empty winner (form the startState at the current offset). This +-- winEmpty possibility is also checked for. (unit test pattern ".*") +-- (futher test "(.+|.+.)*" on "aa\n") + + {-# INLINE processWinner #-} + processWinner s1 did dt w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do + let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do + pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex + startPos <- pos !! 0 + orbit <- m_orbit s1 !! sourceIndex + let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) + return (startPos,(x,pos,orbit')) + challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do + check <- comp offset x1 (newPos ins1) x2 (newPos ins2) + if check==LT then return x2 else return x1 + prep'd <- mapM prep (IMap.toList w) + let (emptyFalse,emptyTrue) = partition ((offset >) . fst) prep'd + mayID <- {-# SCC "goNext.newWinnerThenProceed.mayID" #-} + case map snd emptyFalse of + [] -> return Nothing + (first:rest) -> do + best@((_sourceIndex,_instructions),bp,_orbit') <- foldM challenge first rest + newWinner offset best + startWin <- bp !! 0 + let states = ISet.toAscList did + keepState i1 = do + pos <- maybe (err "newWinnerThenProceed,2") return =<< m_pos s1 !! i1 + startsAt <- pos !! 0 + let keep = (startsAt <= startWin) || (offset <= startsAt) + when (not keep) $ do + writeSTRef eliminatedStateFlag True + when (i1 == startState) (writeSTRef eliminatedRespawnFlag True) + return keep + states' <- filterM keepState states + changed <- readSTRef eliminatedStateFlag + if changed then return (Just states') else return Nothing + case emptyTrue of + [] -> case IMap.lookup startState w of + Nothing -> return () + Just ins -> winEmpty offset ins + [first] -> newWinner offset (snd first) + _ -> err "newWinnerThenProceed,3 : too many emptyTrue values" + case mayID of + Nothing -> return (did,dt) -- proceedNow s1 s2 did dt offset prev input + Just states' -> do + writeSTRef eliminatedStateFlag False + respawn <- readSTRef eliminatedRespawnFlag + DFA {d_id=did',d_dt=dt'} <- + if respawn + then do + writeSTRef eliminatedRespawnFlag False + spawnStart b_tags blank startState s1 (succ offset) + return (Trie.lookupAsc trie (sort (states'++[startState]))) + else return (Trie.lookupAsc trie states') + return (did',dt') + + winEmpty preTag winInstructions = {-# SCC "goNext.winEmpty" #-} do + newerPos <- newA_ b_tags + copySTU (blank_pos blank) newerPos + set newerPos 0 preTag + doActions preTag newerPos (newPos winInstructions) + putMQ (WScratch newerPos) winQ + + newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do + newerPos <- newA_ b_tags + copySTU oldPos newerPos + doActions preTag newerPos (newPos winInstructions) + putMQ (WScratch newerPos) winQ + + finalizeWinners = do + winners <- fmap (foldl' (\ rest mqa -> mqa_ws mqa : rest) []) $ + readSTRef (mq_list winQ) -- reverses the winner list + resetMQ winQ + writeSTRef storeNext (return []) + mapM (tagsToGroupsST aGroups) winners + + -- goNext then ends with the next statement + next s1In s2In didIn dtIn offsetIn prevIn inputIn + +{-# INLINE doActions #-} +doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () +doActions preTag pos ins = mapM_ doAction ins where + postTag = succ preTag + doAction (tag,SetPre) = set pos tag preTag + doAction (tag,SetPost) = set pos tag postTag + doAction (tag,SetVal v) = set pos tag v + +---- + +{-# INLINE mkTest #-} +mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool +mkTest isMultiline = if isMultiline then test_multiline else test_singleline + where test_multiline Test_BOL _off prev _input = prev == '\n' + test_multiline Test_EOL _off _prev input = case uncons input of + Nothing -> True + Just (next,_) -> next == '\n' + test_singleline Test_BOL off _prev _input = off == 0 + test_singleline Test_EOL _off _prev input = case uncons input of + Nothing -> True + _ -> False + +---- + +{- MUTABLE WINNER QUEUE -} + +data MQA s = MQA {mqa_start :: !Position, mqa_ws :: !(WScratch s)} + +data MQ s = MQ { mq_earliest :: !(STRef s Position) + , mq_list :: !(STRef s [MQA s]) + } + +newMQ :: S.ST s (MQ s) +newMQ = do + earliest <- newSTRef maxBound + list <- newSTRef [] + return (MQ earliest list) + +resetMQ :: MQ s -> S.ST s () +resetMQ (MQ {mq_earliest=earliest,mq_list=list}) = do + writeSTRef earliest maxBound + writeSTRef list [] + +putMQ :: WScratch s -> MQ s -> S.ST s () +putMQ ws (MQ {mq_earliest=earliest,mq_list=list}) = do + start <- w_pos ws !! 0 + let mqa = MQA start ws + startE <- readSTRef earliest + if start <= startE + then writeSTRef earliest start >> writeSTRef list [mqa] + else do + old <- readSTRef list + let !rest = dropWhile (\ m -> start <= mqa_start m) old + !new = mqa : rest + writeSTRef list new + +getMQ :: Position -> MQ s -> ST s [WScratch s] +getMQ pos (MQ {mq_earliest=earliest,mq_list=list}) = do + old <- readSTRef list + case span (\m -> pos <= mqa_start m) old of + ([],ans) -> do + writeSTRef earliest maxBound + writeSTRef list [] + return (map mqa_ws ans) + (new,ans) -> do + writeSTRef earliest (mqa_start (last new)) + writeSTRef list new + return (map mqa_ws ans) + +{- MUTABLE SCRATCH DATA STRUCTURES -} + +data SScratch s = SScratch { _s_1 :: !(MScratch s) + , _s_2 :: !(MScratch s) + , _s_rest :: !( MQ s + , BlankScratch s + , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog) + ) + } +data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position))) + , m_orbit :: !(STArray s Index OrbitLog) + } +newtype BlankScratch s = BlankScratch { blank_pos :: (STUArray s Tag Position) + } +newtype WScratch s = WScratch { w_pos :: (STUArray s Tag Position) + } + +{- DEBUGGING HELPERS -} + +{- +indent :: String -> String +indent xs = ' ':' ':xs + +showMS :: MScratch s -> Index -> ST s String +showMS s i = do + ma <- m_pos s !! i + mc <- m_orbit s !! i + a <- case ma of + Nothing -> return "No pos" + Just pos -> fmap show (getAssocs pos) + let c = show mc + return $ unlines [ "MScratch, index = "++show i + , indent a + , indent c] + +showWS :: WScratch s -> ST s String +showWS (WScratch pos) = do + a <- getAssocs pos + return $ unlines [ "WScratch" + , indent (show a)] +-} +{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -} + +{-# INLINE newA #-} +newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e) +newA b_tags initial = newArray b_tags initial + +{-# INLINE newA_ #-} +newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e) +newA_ b_tags = newArray_ b_tags + +newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s) +newScratch b_index b_tags = do + s1 <- newMScratch b_index + s2 <- newMScratch b_index + winQ <- newMQ + blank <- fmap BlankScratch (newA b_tags (-1)) + which <- (newArray b_index ((-1,err "newScratch which 1"),err "newScratch which 2",err "newScratch which 3")) + return (SScratch s1 s2 (winQ,blank,which)) + +newMScratch :: (Index,Index) -> S.ST s (MScratch s) +newMScratch b_index = do + pos's <- newArray b_index Nothing + orbit's <- newArray b_index mempty + return (MScratch pos's orbit's) + +{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -} + +newtype F s = F ([F s] -> C s) +type C s = Position + -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) + -> [(Int, Action)] + -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) + -> [(Int, Action)] + -> ST s Ordering + +{-# INLINE orderOf #-} +orderOf :: Action -> Action -> Ordering +orderOf post1 post2 = + case (post1,post2) of + (SetPre,SetPre) -> EQ + (SetPost,SetPost) -> EQ + (SetPre,SetPost) -> LT + (SetPost,SetPre) -> GT + (SetVal v1,SetVal v2) -> compare v1 v2 + _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2) + +comp01 :: C s +comp01 preTag (_state1,pos1,_orbit1') np1 (_state2,pos2,_orbit2') np2 = do + c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize + case c of + EQ -> challenge1 + answer -> return answer + where + challenge1 = do + case np1 of + ((t1,b1):_rest1) | t1==1 -> do + let p1 = case b1 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + case np2 of + ((t2,b2):_rest2) | t2==1 -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + return (compare p1 p2) + _ -> do + p2 <- pos2 !! 1 + return (compare p1 p2) + _ -> do + p1 <- pos1 !! 1 + case np2 of + ((t2,b2):_rest2) | t2==1 -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + return (compare p1 p2) + _ -> do + p2 <- pos2 !! 1 + return (compare p1 p2) + +ditzyComp'3 :: forall s. Array Tag OP -> C s +ditzyComp'3 aTagOP = comp0 where + (F comp1:compsRest) = allcomps 1 + + comp0 :: C s + comp0 preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = do + c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize + case c of + EQ -> comp1 compsRest preTag x1 np1 x2 np2 + answer -> return answer + + allcomps :: Tag -> [F s] + allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)] + | otherwise = + case aTagOP ! tag of + Orbit -> F (challenge_Orb tag) : allcomps (succ tag) + Maximize -> F (challenge_Max tag) : allcomps (succ tag) + Ignore -> F (challenge_Ignore tag) : allcomps (succ tag) + Minimize -> err "allcomps Minimize" + where top = snd (bounds aTagOP) + + challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 = + case np1 of + ((t1,_):rest1) | t1==tag -> + case np2 of + ((t2,_):rest2) | t2==tag -> next comps preTag x1 rest1 x2 rest2 + _ -> next comps preTag x1 rest1 x2 np2 + _ -> do + case np2 of + ((t2,_):rest2) | t2==tag -> next comps preTag x1 np1 x2 rest2 + _ -> next comps preTag x1 np1 x2 np2 + challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867" + + challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = + case np1 of + ((t1,b1):rest1) | t1==tag -> + case np2 of + ((t2,b2):rest2) | t2==tag -> + if b1==b2 then next comps preTag x1 rest1 x2 rest2 + else return (orderOf b1 b2) + _ -> do + p2 <- pos2 !! tag + let p1 = case b1 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + if p1==p2 then next comps preTag x1 rest1 x2 np2 + else return (compare p1 p2) + _ -> do + p1 <- pos1 !! tag + case np2 of + ((t2,b2):rest2) | t2==tag -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + if p1==p2 then next comps preTag x1 np1 x2 rest2 + else return (compare p1 p2) + _ -> do + p2 <- pos2 !! tag + if p1==p2 then next comps preTag x1 np1 x2 np2 + else return (compare p1 p2) + challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" + + challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = + let s1 = IMap.lookup tag orbit1' + s2 = IMap.lookup tag orbit2' + in case (s1,s2) of + (Nothing,Nothing) -> next comps preTag x1 np1 x2 np2 + (Just o1,Just o2) | inOrbit o1 == inOrbit o2 -> + case compare (ordinal o1) (ordinal o2) `mappend` + 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 + ] + challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" + +comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering +comparePos EmptyL EmptyL = EQ +comparePos EmptyL _ = GT +comparePos _ EmptyL = LT +comparePos (p1 :< ps1) (p2 :< ps2) = + compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2) + +{- CONVERT WINNERS TO MATCHARRAY -} + +tagsToGroup0ST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray +tagsToGroup0ST _aGroups (WScratch {w_pos=pos})= do + ma <- newArray (0,0) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) + startPos0 <- pos !! 0 + stopPos0 <- pos !! 1 + set ma 0 (startPos0,stopPos0-startPos0) + unsafeFreeze ma + +tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray +tagsToGroupsST aGroups (WScratch {w_pos=pos})= do + let b_max = snd (bounds (aGroups)) + ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) + startPos0 <- pos !! 0 + stopPos0 <- pos !! 1 + set ma 0 (startPos0,stopPos0-startPos0) + let act _this_index [] = return () + act this_index ((GroupInfo _ parent start stop flagtag):gs) = do + flagVal <- pos !! flagtag + if (-1) == flagVal then act this_index gs + else do + startPos <- pos !! start + stopPos <- pos !! stop + (startParent,lengthParent) <- ma !! parent + let ok = (0 <= startParent && + 0 <= lengthParent && + startParent <= startPos && + stopPos <= startPos + lengthParent) + if not ok then act this_index gs + else set ma this_index (startPos,stopPos-startPos) + forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i)) + unsafeFreeze ma + +{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -} + +{-# INLINE spawnStart #-} +-- Reset the entry at "Index", or allocate such an entry. +-- set tag 0 to the "Position" +spawnStart :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position +spawnStart b_tags (BlankScratch blankPos) i s1 thisPos = do + oldPos <- m_pos s1 !! i + pos <- case oldPos of + Nothing -> do + pos' <- newA_ b_tags + set (m_pos s1) i (Just pos') + return pos' + Just pos -> return pos + copySTU blankPos pos + set (m_orbit s1) i $! mempty + set pos 0 thisPos + return thisPos + +{-# INLINE updateCopy #-} +updateCopy :: (Index -> STUArray s Tag Position -> [(Tag, Action)] -> ST s a) + -> ((Index, Instructions), STUArray s Tag Position, OrbitLog) + -> Index + -> MScratch s + -> Int + -> ST s Position +updateCopy doActions ((_i1,instructions),oldPos,newOrbit) preTag s2 i2 = do + b_tags <- getBounds oldPos + newerPos <- maybe (do + a <- newA_ b_tags + set (m_pos s2) i2 (Just a) + return a) return =<< m_pos s2 !! i2 + copySTU oldPos newerPos + doActions preTag newerPos (newPos instructions) + set (m_orbit s2) i2 $! newOrbit + newerPos !! 0 + +{- USING memcpy TO COPY STUARRAY DATA -} + +-- #ifdef __GLASGOW_HASKELL__ +foreign import ccall unsafe "memcpy" + memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO () + +{- +Prelude Data.Array.Base> :i STUArray +data STUArray s i e + = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s) + -- Defined in Data.Array.Base +-} +-- 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) = +-- 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 #) }} +{- +#else /* !__GLASGOW_HASKELL__ */ + +copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) +copySTU source destination = do + b@(start,stop) <- getBounds source + b' <- getBounds destination + -- traceCopy ("> copySTArray "++show b) $ do + when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b')) + forM_ (range b) $ \index -> + set destination index =<< source !! index + return destination +#endif /* !__GLASGOW_HASKELL__ */ +-} diff --git a/Text/Regex/TDFA/NewDFA/Engine_FA.hs b/Text/Regex/TDFA/NewDFA/Engine_FA.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Engine_FA.hs @@ -0,0 +1,652 @@ +-- | This is the code for the main engine. This captures the posix +-- subexpressions. There is also a non-capturing engine, and a +-- testing engine. +-- +-- It is polymorphic over the internal Uncons type class, and +-- specialized to produce the needed variants. +module Text.Regex.TDFA.NewDFA.Engine_FA(execMatch) where + +import Control.Monad(when,unless,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM) +import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) +-- #ifdef __GLASGOW_HASKELL__ +import GHC.Arr(STArray(..)) +import GHC.ST(ST(..)) +import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) +{- +-- #else +import Control.Monad.ST(ST) +import Data.Array.ST(STArray) +-- #endif +-} +import Prelude hiding ((!!)) + +import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs) +import Data.Array.IArray(Array,bounds,assocs) +--import qualified Data.Foldable as F +import qualified Data.IntMap.CharMap2 as CMap(lookup,findWithDefault) +import Data.IntMap(IntMap) +import qualified Data.IntMap as IMap(null,toList,lookup,insert) +import Data.Ix(Ix,rangeSize,range) +import Data.Maybe(catMaybes,listToMaybe) +import Data.Monoid(Monoid(..)) +--import Data.IntSet(IntSet) +import qualified Data.IntSet as ISet(toAscList,null) +import qualified Data.Array.ST +import Data.Array.IArray((!)) +import qualified Data.Array.MArray +import Data.List(partition,sort,foldl',sortBy,groupBy) +import Data.STRef +import qualified Control.Monad.ST.Lazy as L +import qualified Control.Monad.ST.Strict as S +import Data.Sequence(Seq,ViewL(..),viewl) +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) +import qualified Text.Regex.TDFA.IntArrTrieSet as Trie +import Text.Regex.TDFA.Common hiding (indent) +import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) + +--import Debug.Trace + +-- trace :: String -> a -> a +-- trace _ a = a + +err :: String -> a +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 +(!!) = unsafeRead +{-# INLINE set #-} +set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () +set = unsafeWrite + +noSource :: ((Index, Instructions),STUArray s Tag Position,OrbitLog) +noSource = ((-1,err "noSource"),err "noSource",err "noSource") + +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-} +execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] +execMatch r@(Regex { regex_dfa = DFA {d_id=didIn,d_dt=dtIn} + , regex_init = startState + , regex_b_index = b_index + , regex_b_tags = b_tags_all + , regex_trie = trie + , regex_tags = aTags + , regex_groups = aGroups + , regex_compOptions = CompOption { multiline = newline } + , regex_execOptions = ExecOption { captureGroups = capture + , testMatch = _checkMatch }}) + offsetIn prevIn inputIn = S.runST goNext where + + b_tags :: (Tag,Tag) + !b_tags = b_tags_all + + orbitTags :: [Tag] + !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags + + !test = mkTest newline + + comp :: C s + comp = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags + + goNext = {-# SCC "goNext" #-} do + (SScratch s1In s2In (winQ,blank,which)) <- newScratch b_index b_tags + spawnAt b_tags blank startState s1In offsetIn + let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset prev input + then next s1 s2 did a offset prev input + else next s1 s2 did b offset prev input + Simple' {dt_win=w,dt_trans=t,dt_other=o} -> do + unless (IMap.null w) $ + processWinner s1 w offset + case uncons input of + Nothing -> finalizeWinner + Just (c,input') -> + 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' 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 +-- compressOrbit. +-- +-- compressOrbit on such a Tag loops through all the NFS states' +-- m_orbit record, discardind ones that are Nothing and discarding +-- ones that are too new to care about (after the cutoff value). +-- +-- compressOrbit then groups the Orbits records by the Tag-0 start +-- position and the basePos position. Entried in different groups +-- will never be comparable in the future so they can be processed +-- separately. Groups could probably be even more finely +-- distinguished, as a futher optimization, but the justification will +-- be tricky. +-- +-- Current Tag-0 values are at most offset and all newly spawned +-- groups will have Tag-0 of at least (succ offset) so the current +-- groups are closed to those spawned in the future. The basePos may +-- be as large as offset and may be overwritten later with values of +-- offset or larger (and this will also involve deleting the Orbits +-- record). Thus there could be a future collision between a current +-- group with basePos==offset and an updated record that acquires +-- basePos==offset. By excluding groups with basePos before the +-- current offset the collision between existing and future records +-- is avoided. +-- +-- An entry in a group can only collide with that group's +-- descendents. compressOrbit sends each group to the compressGroup +-- command. +-- +-- compressGroup on a single record checks whether it's Seq can be +-- cleared and if so it will clear it (and set ordinal to Nothing but +-- this this not particularly important). +-- +-- compressGroup on many records sorts and groups the members and zips +-- the groups with their new ordinal value. The comparision is based +-- on the old ordinal value, then the inOrbit value, and then the (Seq +-- Position) data. +-- +-- The old ordinals of the group will all be Nothing or all be Just, +-- but this condition is neither checked nor violations detected. +-- This comparision is justified because once records get different +-- ordinals assigned they will never change places. +-- +-- The inOrbit Bool is only different if one of them has set the stop +-- position to at most (succ offset). They will obly be compared if +-- the other one leaves, an its stop position will be at least offset. +-- The previous sentence is justified by inspectin of the "assemble" +-- function in the TDFA module: there is no (PostUpdate +-- LeaveOrbitTask) so the largest possible value for the stop Tag is +-- (pred offset). Thus the record with inOrbit==False would beat (be +-- GT than) the record with inOrbit==True. +-- +-- The Seq comparison is safe because the largest existing Position +-- value is (pred offset) and the smallest future Position value is +-- offset. The previous sentence is justified by inspectin of the +-- "assemble" function in the TDFA module: there is no (PostUpdate +-- EnterOrbitTags) so the largest possible value in the Seq is (pred +-- offset). +-- +-- The updated Orbits get the new ordinal value and an empty (Seq +-- Position). + + compressOrbits s1 did offset = do + let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state + return (state,start) + cutoff = offset - 50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50 + ss <- mapM getStart (ISet.toAscList did) + let compressOrbit tag = do + mos <- forM ss ( \ p@(state,_start) -> do + mo <- fmap (IMap.lookup tag) (m_orbit s1 !! state) + case mo of + Just orbits | basePos orbits < cutoff -> return (Just (p,orbits)) + | otherwise -> return Nothing + _ -> return Nothing ) + let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return () + | otherwise = + set (m_orbit s1) state + . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty})) + =<< m_orbit s1 !! state + + compressGroup gs = do + let sortPos (_,b1) (_,b2) = compare (ordinal b1) (ordinal b2) `mappend` + compare (inOrbit b2) (inOrbit b1) `mappend` + comparePos (viewl (getOrbits b1)) (viewl (getOrbits b2)) + groupPos (_,b1) (_,b2) = ordinal b1 == ordinal b2 && getOrbits b1 == getOrbits b2 + gs' = zip [(1::Int)..] (groupBy groupPos . sortBy sortPos $ gs) + forM_ gs' $ \ (!n,eqs) -> do + forM_ eqs $ \ ((state,_),orbit) -> + set (m_orbit s1) state + . (IMap.insert tag $! (orbit { ordinal = Just n, getOrbits = mempty })) + =<< m_orbit s1 !! state + let sorter ((_,a1),b1) ((_,a2),b2) = compare a1 a2 `mappend` compare (basePos b1) (basePos b2) + grouper ((_,a1),b1) ((_,a2),b2) = a1==a2 && basePos b1 == basePos b2 + orbitGroups = groupBy grouper . sortBy sorter . catMaybes $ mos + mapM_ compressGroup orbitGroups + mapM_ compressOrbit orbitTags + +-- findTrans has to (part 1) decide, for each destination, "which" of +-- zero or more source NFA states will be the chosen source. Then it +-- has to (part 2) perform the transition or spawn. It keeps track of +-- the starting index while doing so, and compares the earliest start +-- with the stored winners. (part 3) If some winners are ready to be +-- released then the future continuation of the search is placed in +-- "storeNext". If no winners are ready to be released then the +-- computation continues immediately. + + 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) + -- findTrans part 1 + let findTransTo (destIndex,sources) | IMap.null sources = + set which destIndex noSource + | otherwise = do + let prep (sourceIndex,(_dopa,instructions)) = {-# SCC "goNext.findTrans.prep" #-} do + pos <- maybe (err $ "findTrans,1 : "++show (sourceIndex,destIndex,did')) return + =<< m_pos s1 !! sourceIndex + orbit <- m_orbit s1 !! sourceIndex + let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) + return ((sourceIndex,instructions),pos,orbit') + challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do + check <- comp offset x1 (newPos ins1) x2 (newPos ins2) + if check==LT then return x2 else return x1 + (first:rest) <- mapM prep (IMap.toList sources) + set which destIndex =<< foldM challenge first rest + let dl = IMap.toList dtrans + mapM_ findTransTo dl + -- findTrans part 2 + let performTransTo (destIndex,_sources) = {-# SCC "goNext.findTrans.performTransTo" #-} do + x@((sourceIndex,_instructions),_pos,_orbit') <- which !! destIndex + unless (sourceIndex == (-1)) $ + (updateCopy doActions x offset s2 destIndex) + mapM_ performTransTo dl + -- findTrans part 3 + let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input' + +-- The "newWinnerThenProceed" can find both a new non-empty winner and +-- a new empty winner. A new non-empty winner can cause some of the +-- NFA states that comprise the DFA state to be eliminated, and if the +-- startState is eliminated then it must then be respawned. And +-- imperative flag setting and resetting style is used. +-- +-- A non-empty winner from the startState might obscure a potential +-- empty winner (form the startState at the current offset). This +-- winEmpty possibility is also checked for. (unit test pattern ".*") +-- (futher test "(.+|.+.)*" on "aa\n") + + {-# INLINE processWinner #-} + processWinner s1 w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do + let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do + pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex + startPos <- pos !! 0 + orbit <- m_orbit s1 !! sourceIndex + let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) + return (startPos,(x,pos,orbit')) + challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do + check <- comp offset x1 (newPos ins1) x2 (newPos ins2) + if check==LT then return x2 else return x1 + prep'd <- mapM prep (IMap.toList w) + case map snd prep'd of + [] -> return () + (first:rest) -> do + best@((_sourceIndex,_instructions),bp,_orbit') <- foldM challenge first rest + newWinner offset best + + newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do + newerPos <- newA_ b_tags + copySTU oldPos newerPos + doActions preTag newerPos (newPos winInstructions) + putMQ (WScratch newerPos) winQ + + finalizeWinner = do + mWinner <- readSTRef (mq_mWin winQ) + case mWinner of + Nothing -> return [] + Just winner -> resetMQ winQ >> mapM (tagsToGroupsST aGroups) [winner] + + -- goNext then ends with the next statement + next s1In s2In didIn dtIn offsetIn prevIn inputIn + +{-# INLINE doActions #-} +doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () +doActions preTag pos ins = mapM_ doAction ins where + postTag = succ preTag + doAction (tag,SetPre) = set pos tag preTag + doAction (tag,SetPost) = set pos tag postTag + doAction (tag,SetVal v) = set pos tag v + +---- + +{-# INLINE mkTest #-} +mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool +mkTest isMultiline = if isMultiline then test_multiline else test_singleline + where test_multiline Test_BOL _off prev _input = prev == '\n' + test_multiline Test_EOL _off _prev input = case uncons input of + Nothing -> True + Just (next,_) -> next == '\n' + test_singleline Test_BOL off _prev _input = off == 0 + test_singleline Test_EOL _off _prev input = case uncons input of + Nothing -> True + _ -> False + +---- + +{- MUTABLE WINNER QUEUE -} + +newtype MQ s = MQ { mq_mWin :: STRef s (Maybe (WScratch s)) } + +newMQ :: S.ST s (MQ s) +newMQ = do + mWin <- newSTRef Nothing + return (MQ mWin) + +resetMQ :: MQ s -> S.ST s () +resetMQ (MQ {mq_mWin=mWin}) = do + writeSTRef mWin Nothing + +putMQ :: WScratch s -> MQ s -> S.ST s () +putMQ ws (MQ {mq_mWin=mWin}) = do + writeSTRef mWin (Just ws) + +{- MUTABLE SCRATCH DATA STRUCTURES -} + +data SScratch s = SScratch { _s_1 :: !(MScratch s) + , _s_2 :: !(MScratch s) + , _s_rest :: !( MQ s + , BlankScratch s + , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog) + ) + } +data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position))) + , m_orbit :: !(STArray s Index OrbitLog) + } +newtype BlankScratch s = BlankScratch { blank_pos :: (STUArray s Tag Position) + } +newtype WScratch s = WScratch { w_pos :: (STUArray s Tag Position) + } + +{- DEBUGGING HELPERS -} + +{- +indent :: String -> String +indent xs = ' ':' ':xs + +showMS :: MScratch s -> Index -> ST s String +showMS s i = do + ma <- m_pos s !! i + mc <- m_orbit s !! i + a <- case ma of + Nothing -> return "No pos" + Just pos -> fmap show (getAssocs pos) + let c = show mc + return $ unlines [ "MScratch, index = "++show i + , indent a + , indent c] + +showWS :: WScratch s -> ST s String +showWS (WScratch pos) = do + a <- getAssocs pos + return $ unlines [ "WScratch" + , indent (show a)] +-} +{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -} + +{-# INLINE newA #-} +newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e) +newA b_tags initial = newArray b_tags initial + +{-# INLINE newA_ #-} +newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e) +newA_ b_tags = newArray_ b_tags + +newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s) +newScratch b_index b_tags = do + s1 <- newMScratch b_index + s2 <- newMScratch b_index + winQ <- newMQ + blank <- fmap BlankScratch (newA b_tags (-1)) + which <- (newArray b_index ((-1,err "newScratch which 1"),err "newScratch which 2",err "newScratch which 3")) + return (SScratch s1 s2 (winQ,blank,which)) + +newMScratch :: (Index,Index) -> S.ST s (MScratch s) +newMScratch b_index = do + pos's <- newArray b_index Nothing + orbit's <- newArray b_index mempty + return (MScratch pos's orbit's) + +{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -} + +newtype F s = F ([F s] -> C s) +type C s = Position + -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) + -> [(Int, Action)] + -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) + -> [(Int, Action)] + -> ST s Ordering + +{-# INLINE orderOf #-} +orderOf :: Action -> Action -> Ordering +orderOf post1 post2 = + case (post1,post2) of + (SetPre,SetPre) -> EQ + (SetPost,SetPost) -> EQ + (SetPre,SetPost) -> LT + (SetPost,SetPre) -> GT + (SetVal v1,SetVal v2) -> compare v1 v2 + _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2) + +comp01 :: C s +comp01 preTag (_state1,pos1,_orbit1') np1 (_state2,pos2,_orbit2') np2 = do + c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize + case c of + EQ -> challenge1 + answer -> return answer + where + challenge1 = do + case np1 of + ((t1,b1):_rest1) | t1==1 -> do + let p1 = case b1 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + case np2 of + ((t2,b2):_rest2) | t2==1 -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + return (compare p1 p2) + _ -> do + p2 <- pos2 !! 1 + return (compare p1 p2) + _ -> do + p1 <- pos1 !! 1 + case np2 of + ((t2,b2):_rest2) | t2==1 -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + return (compare p1 p2) + _ -> do + p2 <- pos2 !! 1 + return (compare p1 p2) + +ditzyComp'3 :: forall s. Array Tag OP -> C s +ditzyComp'3 aTagOP = comp0 where + (F comp1:compsRest) = allcomps 1 + + comp0 :: C s + comp0 preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = do + c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize + case c of + EQ -> comp1 compsRest preTag x1 np1 x2 np2 + answer -> return answer + + allcomps :: Tag -> [F s] + allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)] + | otherwise = + case aTagOP ! tag of + Orbit -> F (challenge_Orb tag) : allcomps (succ tag) + Maximize -> F (challenge_Max tag) : allcomps (succ tag) + Ignore -> F (challenge_Ignore tag) : allcomps (succ tag) + Minimize -> err "allcomps Minimize" + where top = snd (bounds aTagOP) + + challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 = + case np1 of + ((t1,_):rest1) | t1==tag -> + case np2 of + ((t2,_):rest2) | t2==tag -> next comps preTag x1 rest1 x2 rest2 + _ -> next comps preTag x1 rest1 x2 np2 + _ -> do + case np2 of + ((t2,_):rest2) | t2==tag -> next comps preTag x1 np1 x2 rest2 + _ -> next comps preTag x1 np1 x2 np2 + challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867" + + challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = + case np1 of + ((t1,b1):rest1) | t1==tag -> + case np2 of + ((t2,b2):rest2) | t2==tag -> + if b1==b2 then next comps preTag x1 rest1 x2 rest2 + else return (orderOf b1 b2) + _ -> do + p2 <- pos2 !! tag + let p1 = case b1 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + if p1==p2 then next comps preTag x1 rest1 x2 np2 + else return (compare p1 p2) + _ -> do + p1 <- pos1 !! tag + case np2 of + ((t2,b2):rest2) | t2==tag -> do + let p2 = case b2 of SetPre -> preTag + SetPost -> succ preTag + SetVal v -> v + if p1==p2 then next comps preTag x1 np1 x2 rest2 + else return (compare p1 p2) + _ -> do + p2 <- pos2 !! tag + if p1==p2 then next comps preTag x1 np1 x2 np2 + else return (compare p1 p2) + challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" + + challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = + let s1 = IMap.lookup tag orbit1' + s2 = IMap.lookup tag orbit2' + in case (s1,s2) of + (Nothing,Nothing) -> next comps preTag x1 np1 x2 np2 + (Just o1,Just o2) | inOrbit o1 == inOrbit o2 -> + case compare (ordinal o1) (ordinal o2) `mappend` + 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 + ] + challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" + +comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering +comparePos EmptyL EmptyL = EQ +comparePos EmptyL _ = GT +comparePos _ EmptyL = LT +comparePos (p1 :< ps1) (p2 :< ps2) = + compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2) + +{- CONVERT WINNERS TO MATCHARRAY -} + +tagsToGroup0ST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray +tagsToGroup0ST _aGroups (WScratch {w_pos=pos})= do + ma <- newArray (0,0) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) + startPos0 <- pos !! 0 + stopPos0 <- pos !! 1 + set ma 0 (startPos0,stopPos0-startPos0) + unsafeFreeze ma + +tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray +tagsToGroupsST aGroups (WScratch {w_pos=pos})= do + let b_max = snd (bounds (aGroups)) + ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) + startPos0 <- pos !! 0 + stopPos0 <- pos !! 1 + set ma 0 (startPos0,stopPos0-startPos0) + let act _this_index [] = return () + act this_index ((GroupInfo _ parent start stop flagtag):gs) = do + flagVal <- pos !! flagtag + if (-1) == flagVal then act this_index gs + else do + startPos <- pos !! start + stopPos <- pos !! stop + (startParent,lengthParent) <- ma !! parent + let ok = (0 <= startParent && + 0 <= lengthParent && + startParent <= startPos && + stopPos <= startPos + lengthParent) + if not ok then act this_index gs + else set ma this_index (startPos,stopPos-startPos) + forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i)) + unsafeFreeze ma + +{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -} + +{-# 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 b_tags (BlankScratch blankPos) i s1 thisPos = do + oldPos <- m_pos s1 !! i + pos <- case oldPos of + Nothing -> do + pos' <- newA_ b_tags + set (m_pos s1) i (Just pos') + return pos' + Just pos -> return pos + copySTU blankPos pos + set (m_orbit s1) i $! mempty + set pos 0 thisPos + return thisPos + +{-# INLINE updateCopy #-} +updateCopy :: (Index -> STUArray s Tag Position -> [(Tag, Action)] -> ST s a) + -> ((Index, Instructions), STUArray s Tag Position, OrbitLog) + -> Index + -> MScratch s + -> Int + -> ST s () +updateCopy doActions ((_i1,instructions),oldPos,newOrbit) preTag s2 i2 = do + b_tags <- getBounds oldPos + newerPos <- maybe (do + a <- newA_ b_tags + set (m_pos s2) i2 (Just a) + return a) return =<< m_pos s2 !! i2 + copySTU oldPos newerPos + doActions preTag newerPos (newPos instructions) + set (m_orbit s2) i2 $! newOrbit + +{- USING memcpy TO COPY STUARRAY DATA -} + +-- #ifdef __GLASGOW_HASKELL__ +foreign import ccall unsafe "memcpy" + memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO () + +{- +Prelude Data.Array.Base> :i STUArray +data STUArray s i e + = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s) + -- Defined in Data.Array.Base +-} +-- 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) = +-- 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 #) }} +{- +#else /* !__GLASGOW_HASKELL__ */ + +copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) +copySTU source destination = do + b@(start,stop) <- getBounds source + b' <- getBounds destination + -- traceCopy ("> copySTArray "++show b) $ do + when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b')) + forM_ (range b) $ \index -> + set destination index =<< source !! index + return destination +#endif /* !__GLASGOW_HASKELL__ */ +-} diff --git a/Text/Regex/TDFA/NewDFA/Engine_NC.hs b/Text/Regex/TDFA/NewDFA/Engine_NC.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Engine_NC.hs @@ -0,0 +1,288 @@ +-- | This is the non-capturing form of Text.Regex.TDFA.NewDFA.String +module Text.Regex.TDFA.NewDFA.Engine_NC(execMatch) where + +import Control.Monad(when,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM) +import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) +-- #ifdef __GLASGOW_HASKELL__ +import GHC.Arr(STArray(..)) +import GHC.ST(ST(..)) +import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) +{- +-- #else +import Control.Monad.ST(ST) +import Data.Array.ST(STArray) +-- #endif +-} +import Prelude hiding ((!!)) + +import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs) +import Data.Array.IArray(Array,bounds,assocs) +--import qualified Data.Foldable as F +import qualified Data.IntMap.CharMap2 as CMap(lookup,findWithDefault) +import Data.IntMap(IntMap) +import qualified Data.IntMap as IMap(null,toList,lookup,insert,keys,member) +import Data.Ix(Ix,rangeSize,range) +import Data.Maybe(catMaybes,listToMaybe) +import Data.Monoid(Monoid(..)) +--import Data.IntSet(IntSet) +import qualified Data.IntSet as ISet(toAscList,null) +import qualified Data.Array.ST +import Data.Array.IArray((!)) +import qualified Data.Array.MArray as MA +import Data.List(partition,sort,foldl',sortBy,groupBy) +import Data.STRef +import qualified Control.Monad.ST.Lazy as L +import qualified Control.Monad.ST.Strict as S +import Data.Sequence(Seq,ViewL(..),viewl) +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) +import qualified Text.Regex.TDFA.IntArrTrieSet as Trie +import Text.Regex.TDFA.Common hiding (indent) +import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) + +-- import Debug.Trace + +-- trace :: String -> a -> a +-- trace _ a = a + +err :: String -> a +err s = common_error "Text.Regex.TDFA.NewDFA.Engine_NC" s + +{-# INLINE (!!) #-} +(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> i -> S.ST s e +(!!) = MA.readArray -- unsafeRead +{-# INLINE set #-} +set :: (MArray a e (S.ST s),Ix i) => a i e -> i -> e -> S.ST s () +set = MA.writeArray -- unsafeWrite + +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-} +execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] +execMatch (Regex { regex_dfa = (DFA {d_id=didIn,d_dt=dtIn}) + , regex_init = startState + , regex_b_index = b_index + , regex_b_tags = b_tags_all + , regex_trie = trie + , regex_tags = aTags + , regex_groups = aGroups + , regex_compOptions = CompOption { multiline = newline } + , regex_execOptions = ExecOption { captureGroups = capture + , testMatch = _checkMatch }}) + offsetIn prevIn inputIn = L.runST runCaptureGroup where + + !test = mkTest newline + + runCaptureGroup = {-# SCC "runCaptureGroup" #-} do + obtainNext <- L.strictToLazyST constructNewEngine + let loop = do vals <- L.strictToLazyST obtainNext + if null vals -- force vals before defining valsRest + then return [] + else do valsRest <- loop + return (vals ++ valsRest) + loop + + constructNewEngine :: S.ST s (S.ST s [MatchArray]) + constructNewEngine = {-# SCC "constructNewEngine" #-} do + storeNext <- newSTRef undefined + writeSTRef storeNext (goNext storeNext) + let obtainNext = join (readSTRef storeNext) + return obtainNext + + goNext storeNext = {-# SCC "goNext" #-} do + (SScratch s1In s2In winQ) <- newScratch b_index + set s1In startState offsetIn + writeSTRef storeNext (err "obtainNext called while goNext is running!") + eliminatedStateFlag <- newSTRef False + eliminatedRespawnFlag <- newSTRef False + let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset prev input + then next s1 s2 did a offset prev input + else next s1 s2 did b offset prev input + Simple' {dt_win=w,dt_trans=t, dt_other=o} + | IMap.null w -> + case uncons input of + Nothing -> finalizeWinners + Just (c,input') -> do + case CMap.findWithDefault o c t of + Transition {trans_many=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} -> + 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 + + next' s1 s2 did dt offset prev input = {-# SCC "goNext'.next" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset prev input + then next' s1 s2 did a offset prev input + else next' s1 s2 did b offset prev input + Simple' {dt_win=w,dt_trans=t, dt_other=o} -> + case uncons input of + Nothing -> finalizeWinners + Just (c,input') -> do + case CMap.findWithDefault o c t of + Transition {trans_many=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} -> + findTrans s1 s2 did' dt' dtrans offset c input' + + findTrans s1 s2 did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do + -- + let findTransTo (destIndex,sources) = do + val <- if IMap.null sources then return (succ offset) + else return . minimum =<< mapM (s1 !!) (IMap.keys sources) + set s2 destIndex val + return val + earlyStart <- fmap minimum $ mapM findTransTo (IMap.toList dtrans) + -- + earlyWin <- readSTRef (mq_earliest winQ) + if earlyWin < earlyStart + then do + winnersR <- getMQ earlyStart winQ + writeSTRef storeNext (next s2 s1 did' dt' (succ offset) prev' input') + mapM wsToGroup (reverse winnersR) + else do + let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input' + + processWinner s1 did dt w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do + let getStart (sourceIndex,_) = s1 !! sourceIndex + vals <- mapM getStart (IMap.toList w) + let low = minimum vals -- perhaps a non-empty winner + high = maximum vals -- perhaps an empty winner + if low < offset + then do + putMQ (WScratch low offset) winQ + when (high==offset || IMap.member startState w) $ + putMQ (WScratch offset offset) winQ + let keepState i1 = do + startsAt <- s1 !! i1 + let keep = (startsAt <= low) || (offset <= startsAt) + if keep + then return True + else if i1 == startState + then {- check for additional empty winner -} + set s1 i1 (succ offset) >> return True + else writeSTRef eliminatedStateFlag True >> return False + states' <- filterM keepState (ISet.toAscList did) + flag <- readSTRef eliminatedStateFlag + if flag + then do + writeSTRef eliminatedStateFlag False + let DFA {d_id=did',d_dt=dt'} = Trie.lookupAsc trie states' + return (did',dt') + else do + return (did,dt) + else do + -- offset == low == minimum vals == maximum vals == high; vals == [offset] + putMQ (WScratch offset offset) winQ + return (did,dt) + + finalizeWinners = do + winnersR <- readSTRef (mq_list winQ) + resetMQ winQ + writeSTRef storeNext (return []) + mapM wsToGroup (reverse winnersR) + + -- goNext then ends with the next statement + next s1In s2In didIn dtIn offsetIn prevIn inputIn + +---- + +{-# INLINE mkTest #-} +mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool +mkTest isMultiline = if isMultiline then test_multiline else test_singleline + where test_multiline Test_BOL _off prev _input = prev == '\n' + test_multiline Test_EOL _off _prev input = case uncons input of + Nothing -> True + Just (next,_) -> next == '\n' + test_singleline Test_BOL off _prev _input = off == 0 + test_singleline Test_EOL _off _prev input = case uncons input of + Nothing -> True + _ -> False + +---- + +{- MUTABLE WINNER QUEUE -} + +data MQ s = MQ { mq_earliest :: !(STRef s Position) + , mq_list :: !(STRef s [WScratch]) + } + +newMQ :: S.ST s (MQ s) +newMQ = do + earliest <- newSTRef maxBound + list <- newSTRef [] + return (MQ earliest list) + +resetMQ :: MQ s -> S.ST s () +resetMQ (MQ {mq_earliest=earliest,mq_list=list}) = do + writeSTRef earliest maxBound + writeSTRef list [] + +putMQ :: WScratch -> MQ s -> S.ST s () +putMQ ws@(WScratch {ws_start=start,ws_stop=stop}) (MQ {mq_earliest=earliest,mq_list=list}) = do + startE <- readSTRef earliest + if start <= startE + then writeSTRef earliest start >> writeSTRef list [ws] + else do + old <- readSTRef list + let !rest = dropWhile (\ w -> start <= ws_start w) old + !new = ws : rest + writeSTRef list new + +getMQ :: Position -> MQ s -> ST s [WScratch] +getMQ pos (MQ {mq_earliest=earliest,mq_list=list}) = do + old <- readSTRef list + case span (\ w -> pos <= ws_start w) old of + ([],ans) -> do + writeSTRef earliest maxBound + writeSTRef list [] + return ans + (new,ans) -> do + writeSTRef earliest (ws_start (last new)) + writeSTRef list new + return ans + +{- MUTABLE SCRATCH DATA STRUCTURES -} + +data SScratch s = SScratch { _s_1 :: !(MScratch s) + , _s_2 :: !(MScratch s) + , _s_mq :: !(MQ s) + } +type MScratch s = STUArray s Index Position +data WScratch = WScratch {ws_start,ws_stop :: !Position} + deriving Show + +{- DEBUGGING HELPERS -} +{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -} + +{-# INLINE newA #-} +newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e) +newA b_tags initial = newArray b_tags initial + +{-# INLINE newA_ #-} +newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e) +newA_ b_tags = newArray_ b_tags + +newScratch :: (Index,Index) -> S.ST s (SScratch s) +newScratch b_index = do + s1 <- newMScratch b_index + s2 <- newMScratch b_index + winQ <- newMQ + return (SScratch s1 s2 winQ) + +newMScratch :: (Index,Index) -> S.ST s (MScratch s) +newMScratch b_index = newA b_index (-1) + +{- CONVERT WINNERS TO MATCHARRAY -} + +wsToGroup :: WScratch -> ST s MatchArray +wsToGroup (WScratch start stop) = do + ma <- newArray (0,0) (start,stop-start) :: ST s (STArray s Int (MatchOffset,MatchLength)) + unsafeFreeze ma + diff --git a/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs b/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs @@ -0,0 +1,110 @@ +-- | This is the non-capturing form of Text.Regex.TDFA.NewDFA.String +module Text.Regex.TDFA.NewDFA.Engine_NC_FA(execMatch) where + +import Control.Monad(when,unless,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM) +import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) +-- #ifdef __GLASGOW_HASKELL__ +import GHC.Arr(STArray(..)) +import GHC.ST(ST(..)) +import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) +{- +-- #else +import Control.Monad.ST(ST) +import Data.Array.ST(STArray) +-- #endif +-} +import Prelude hiding ((!!)) + +import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs) +import Data.Array.IArray(Array,bounds,assocs) +import qualified Data.Foldable as F +import qualified Data.IntMap.CharMap2 as CMap(lookup,findWithDefault) +import Data.IntMap(IntMap) +import qualified Data.IntMap as IMap(null,toList,lookup,insert,keys,member) +import Data.Ix(Ix,rangeSize,range) +import Data.Maybe(catMaybes,listToMaybe) +import Data.Monoid(Monoid(..)) +--import Data.IntSet(IntSet) +import qualified Data.IntSet as ISet(toAscList,null) +import qualified Data.Array.ST +import Data.Array.IArray((!)) +import qualified Data.Array.MArray +import Data.List(partition,sort,foldl',sortBy,groupBy) +import Data.STRef +import qualified Control.Monad.ST.Lazy as L +import qualified Control.Monad.ST.Strict as S +import Data.Sequence(Seq,ViewL(..),viewl) +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) +import qualified Text.Regex.TDFA.IntArrTrieSet as Trie +import Text.Regex.TDFA.Common hiding (indent) +import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) + +--import Debug.Trace + +-- trace :: String -> a -> a +-- trace _ a = a + +err :: String -> a +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 +(!!) = unsafeRead +{-# INLINE set #-} +set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () +set = unsafeWrite + +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} +{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-} +execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] +execMatch (Regex { regex_dfa = DFA {d_dt=dtIn} }) + offsetIn prevIn inputIn = S.runST goNext where + + test Test_BOL off _input = off == 0 + test Test_EOL _off input = case uncons input of + Nothing -> True + _ -> False + + goNext = {-# SCC "goNext" #-} do + winQ <- newSTRef Nothing + let next dt offset input = {-# SCC "goNext.next" #-} + case dt of + Testing' {dt_test=wt,dt_a=a,dt_b=b} -> + if test wt offset input + then next a offset input + else next b offset input + Simple' {dt_win=w,dt_trans=t, dt_other=o} -> do + unless (IMap.null w) $ + writeSTRef winQ (Just offset) + case uncons input of + Nothing -> finalizeWinner + Just (c,input') -> do + case CMap.findWithDefault o c t of + Transition {trans_single=DFA {d_id=did',d_dt=dt'}} + | ISet.null did' -> finalizeWinner + | otherwise -> + let offset' = succ offset + in seq offset' $ next dt' offset' input' + + finalizeWinner = do + mWinner <- readSTRef winQ + case mWinner of + Nothing -> return [] + Just winner -> mapM (makeGroup offsetIn) [winner] + + next dtIn offsetIn inputIn + +---- + +{- CONVERT WINNERS TO MATCHARRAY -} + +makeGroup :: Position -> Position -> ST s MatchArray +makeGroup start stop = do + ma <- newArray (0,0) (start,stop-start) :: ST s (STArray s Int (MatchOffset,MatchLength)) + unsafeFreeze ma diff --git a/Text/Regex/TDFA/NewDFA/Tester.hs b/Text/Regex/TDFA/NewDFA/Tester.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Tester.hs @@ -0,0 +1,126 @@ +-- | Like Engine, but merely checks to see whether any match at all is found. +-- +module Text.Regex.TDFA.NewDFA.Tester(matchTest) where + +import Control.Monad(MonadPlus(..)) +import qualified Data.IntMap.CharMap2 as CMap(findWithDefault) +import qualified Data.IntMap as IMap +import qualified Data.IntSet as ISet(null) + +import Data.Sequence(Seq,ViewL(..),viewl) +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Text.Regex.Base() +import Text.Regex.TDFA.Common hiding (indent) +import Text.Regex.TDFA.NewDFA.Uncons (Uncons(uncons)) + +{-# SPECIALIZE matchTest :: Regex -> ([] Char) -> Bool #-} +{-# SPECIALIZE matchTest :: Regex -> (Seq Char) -> Bool #-} +{-# SPECIALIZE matchTest :: Regex -> SBS.ByteString -> Bool #-} +{-# SPECIALIZE matchTest :: Regex -> LBS.ByteString -> Bool #-} +matchTest :: Uncons text => Regex -> text -> Bool +matchTest (Regex { regex_dfa = dfaIn + , regex_isFrontAnchored = ifa + , regex_compOptions = CompOption { multiline = newline } } ) + inputIn = ans where + + ans = case ifa of + True -> single0 (d_dt dfaIn) inputIn + False -> multi0 (d_dt dfaIn) inputIn + + {-# NOINLINE test0 #-} + {-# NOINLINE test #-} + !test0 = mkTest0 newline + !test = mkTest newline + + multi0 (Testing' {dt_test=wt,dt_a=a,dt_b=b}) input = + if test0 wt input + then multi0 a input + else multi0 b input + multi0 (Simple' {dt_win=w,dt_trans=t, dt_other=o}) input + | IMap.null w = + case uncons input of + Nothing -> False + Just (c,input') -> + case CMap.findWithDefault o c t of + Transition {trans_many=DFA {d_dt=dt'}} -> multi dt' c input' + | otherwise = True + + multi (Testing' {dt_test=wt,dt_a=a,dt_b=b}) prev input = + if test wt prev input + then multi a prev input + else multi b prev input + multi (Simple' {dt_win=w,dt_trans=t, dt_other=o}) _prev input + | IMap.null w = + case uncons input of + Nothing -> False + Just (c,input') -> + case CMap.findWithDefault o c t of + Transition {trans_many=DFA {d_dt=dt'}} -> multi dt' c input' + | otherwise = True + + single0 (Testing' {dt_test=wt,dt_a=a,dt_b=b}) input = + if testFA0 wt input + then single0 a input + else single0 b input + single0 (Simple' {dt_win=w,dt_trans=t, dt_other=o}) input + | IMap.null w = + case uncons input of + Nothing -> False + Just (c,input') -> + case CMap.findWithDefault o c t of + Transition {trans_single=DFA {d_id=did',d_dt=dt'}} + | ISet.null did' -> False + | otherwise -> single dt' input' + | otherwise = True + + single (Testing' {dt_test=wt,dt_a=a,dt_b=b}) input = + if testFA wt input + then single a input + else single b input + single (Simple' {dt_win=w,dt_trans=t, dt_other=o}) input + | IMap.null w = + case uncons input of + Nothing -> False + Just (c,input') -> + case CMap.findWithDefault o c t of + Transition {trans_single=DFA {d_id=did',d_dt=dt'}} + | ISet.null did' -> False + | otherwise -> single dt' input' + | otherwise = True + +testFA0,testFA :: Uncons text => WhichTest -> text -> Bool +testFA0 Test_BOL _input = True +testFA0 Test_EOL input = case uncons input of + Nothing -> True + _ -> False +testFA Test_BOL _input = False +testFA Test_EOL input = case uncons input of + Nothing -> True + _ -> False + +{-# INLINE mkTest0 #-} +mkTest0 :: Uncons text => Bool -> WhichTest -> text -> Bool +mkTest0 isMultiline = if isMultiline then test_multiline else test_singleline + where test_multiline Test_BOL _input = True + test_multiline Test_EOL input = case uncons input of + Nothing -> True + Just (next,_) -> next == '\n' + test_singleline Test_BOL _input = True + test_singleline Test_EOL input = case uncons input of + Nothing -> True + _ -> False + +{-# INLINE mkTest #-} +mkTest :: Uncons text => Bool -> WhichTest -> Char -> text -> Bool +mkTest isMultiline = if isMultiline then test_multiline else test_singleline + where test_multiline Test_BOL prev _input = prev == '\n' + test_multiline Test_EOL _prev input = case uncons input of + Nothing -> True + Just (next,_) -> next == '\n' + test_singleline Test_BOL _prev _input = False + test_singleline Test_EOL _prev input = case uncons input of + Nothing -> True + _ -> False diff --git a/Text/Regex/TDFA/NewDFA/Uncons.hs b/Text/Regex/TDFA/NewDFA/Uncons.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/TDFA/NewDFA/Uncons.hs @@ -0,0 +1,28 @@ +module Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) where + +import qualified Data.ByteString.Char8 as SBS(ByteString,uncons) +import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString,uncons) +import Data.Sequence(Seq,viewl,ViewL(EmptyL,(:<))) + +class Uncons a where + {- INLINE uncons #-} + uncons :: a -> Maybe (Char,a) + +instance Uncons ([] Char) where + {- INLINE uncons #-} + uncons [] = Nothing + uncons (x:xs) = Just (x,xs) + +instance Uncons (Seq Char) where + {- INLINE uncons #-} + uncons s = case viewl s of + EmptyL -> Nothing + x :< xs -> Just (x,xs) + +instance Uncons SBS.ByteString where + {- INLINE uncons #-} + uncons = SBS.uncons + +instance Uncons LBS.ByteString where + {- INLINE uncons #-} + uncons = LBS.uncons diff --git a/Text/Regex/TDFA/Pattern.hs b/Text/Regex/TDFA/Pattern.hs --- a/Text/Regex/TDFA/Pattern.hs +++ b/Text/Regex/TDFA/Pattern.hs @@ -161,6 +161,10 @@ unCapture' x = x -} +reGroup p@(PConcat xs) | 2 <= length xs = PGroup Nothing p +reGroup p@(POr xs) | 2 <= length xs = PGroup Nothing p +reGroup p = p + starTrans' :: Pattern -> Pattern starTrans' pIn = case pIn of -- We know that "p" has been simplified in each of these cases: @@ -170,7 +174,7 @@ so set its mayFirstBeNull flag to False -} PPlus p | canOnlyMatchNull p -> p - | otherwise -> asGroup $ PConcat [p,PStar False p] + | otherwise -> asGroup $ PConcat [reGroup p,PStar False p] {- "An ERE matching a single character repeated by an '*' , '?' , or an interval expression shall not match a null expression unless @@ -258,7 +262,7 @@ PBound 0 (Just 1) p -> quest p -- Hard cases PBound i Nothing p | canOnlyMatchNull p -> p - | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i) [p,PStar False 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 -- The first operation is quest NOT nonEmpty. This can be tested with @@ -278,9 +282,9 @@ -} {- 0.99.7 add -} PBound i (Just j) p | canOnlyMatchNull p -> p - | i == j -> asGroup . PConcat $ apply (nc'p:) (pred i) [p] + | i == j -> asGroup . PConcat $ apply (nc'p:) (pred i) [reGroup p] | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i) - [p,apply (nonEmpty' . (concat' p)) (j-i-1) (ne'p) ] + [reGroup p,apply (nonEmpty' . (concat' p)) (j-i-1) (ne'p) ] where nc'p = nonCapture' p ne'p = nonEmpty' p {- 0.99.6 @@ -308,7 +312,7 @@ where 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 [a,b] -- require a and b to have been simplified + concat' a b = simplify' $ PConcat [reGroup a,reGroup b] -- require a and b to have been simplified nonEmpty' = (\ p -> simplify' $ POr [PEmpty,p]) -- 2009-01-19 : this was PNonEmpty nonCapture' = PNonCapture apply f n x = foldr ($) x (replicate n f) -- function f applied n times to x : f^n(x) diff --git a/Text/Regex/TDFA/Sequence.hs b/Text/Regex/TDFA/Sequence.hs --- a/Text/Regex/TDFA/Sequence.hs +++ b/Text/Regex/TDFA/Sequence.hs @@ -17,17 +17,23 @@ ,regexec ) where -import Data.Array((!),elems) -import Data.Sequence as S +import qualified Data.Sequence as S +import Data.Sequence (ViewL(EmptyL,(:<))) import Text.Regex.Base(MatchArray,RegexContext(..),RegexMaker(..),RegexLike(..)) import Text.Regex.Base.Impl(polymatch,polymatchM) +import Text.Regex.TDFA.Common(common_error,Regex(..),CompOption,ExecOption(captureGroups)) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String import Text.Regex.TDFA.TDFA(patternToRegex) -import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) +import Text.Regex.TDFA.Wrap() import Text.Regex.TDFA.ReadRegex(parseRegex) import qualified Data.Foldable as F(toList) +import Data.Array.IArray((!),listArray,elems,bounds) +import Data.Maybe(listToMaybe) +import Text.Regex.TDFA.NewDFA.Engine(execMatch) +import Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest) + {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} instance RegexContext Regex (S.Seq Char) (S.Seq Char) where @@ -38,10 +44,11 @@ makeRegexOptsM c e source = either fail return $ compile c e source instance RegexLike Regex (S.Seq Char) where - matchOnce r = matchOnce r . F.toList - matchAll r = matchAll r . F.toList - matchCount r = matchCount r . F.toList - matchTest r = matchTest r . F.toList + matchOnce r s = listToMaybe (matchAll r s) + matchAll r s = execMatch r 0 '\n' s + matchCount r s = length (matchAll r' s) + where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} } + matchTest = Tester.matchTest matchOnceText regex source = fmap (\ma -> let (o,l) = ma!0 in (S.take o source diff --git a/Text/Regex/TDFA/String.hs b/Text/Regex/TDFA/String.hs --- a/Text/Regex/TDFA/String.hs +++ b/Text/Regex/TDFA/String.hs @@ -6,6 +6,7 @@ This exports instances of the high level API and the medium level API of 'compile','execute', and 'regexec'. -} +{- By Chris Kuklewicz, 2009. BSD License, see the LICENSE file. -} module Text.Regex.TDFA.String( -- ** Types Regex @@ -19,17 +20,19 @@ ,regexec ) where -import Data.Array((!),elems) +import Data.Array.IArray((!),amap) import Text.Regex.Base.Impl(polymatch,polymatchM) import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchOffset,MatchLength,MatchArray) -import Text.Regex.TDFA.Common(common_error) -import qualified Text.Regex.TDFA.NewDFA as N(matchAll,matchOnce,matchCount,matchTest) +import Text.Regex.TDFA.Common(common_error,Regex(..),CompOption,ExecOption(captureGroups)) import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.TDFA(patternToRegex) -import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) +import Text.Regex.TDFA.Wrap() -{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} +import Data.Array.IArray((!),listArray,elems,bounds) +import Data.Maybe(listToMaybe) +import Text.Regex.TDFA.NewDFA.Engine(execMatch) +import Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest) err :: String -> a err = common_error "Text.Regex.TDFA.String" @@ -54,7 +57,7 @@ execute :: Regex -- ^ Compiled regular expression -> String -- ^ String to match against -> Either String (Maybe MatchArray) -execute r s = Right (N.matchOnce r s) +execute r s = Right (matchOnce r s) regexec :: Regex -- ^ Compiled regular expression -> String -- ^ String to match against @@ -69,12 +72,20 @@ -- Minimal defintion for now instance RegexLike Regex String where - matchOnce = N.matchOnce - matchAll = N.matchAll - matchCount = N.matchCount - matchTest = N.matchTest --- matchOnceText --- matchTextAll + matchOnce r s = listToMaybe (matchAll r s) + matchAll r s = execMatch r 0 '\n' s + matchCount r s = length (matchAll r' s) + where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} } + matchTest = Tester.matchTest + -- matchOnceText + matchAllText r s = + let go i _ _ | i `seq` False = undefined + go i t [] = [] + go i t (x:xs) = let (off0,len0) = x!0 + trans pair@(off,len) = (take len (drop (off-i) t),pair) + t' = drop (off0+len0-i) t + in amap trans x : seq t' (go (i+off0+len0) t' xs) + in go 0 s (matchAll r s) instance RegexContext Regex String String where match = polymatch diff --git a/Text/Regex/TDFA/TDFA.hs b/Text/Regex/TDFA/TDFA.hs --- a/Text/Regex/TDFA/TDFA.hs +++ b/Text/Regex/TDFA/TDFA.hs @@ -3,8 +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,isDFAFrontAnchored - ,nfaToDFA,dfaMap) where + ,examineDFA,nfaToDFA,dfaMap) where --import Control.Arrow((***)) import Control.Monad.Instances() @@ -39,15 +38,8 @@ dlose = DFA { d_id = ISet.empty , d_dt = Simple' { dt_win = IMap.empty , dt_trans = Map.empty - , dt_other = Nothing } } + , dt_other = Transition dlose dlose mempty } } -{- --- Specilized utility -ungroupBy :: (a->x) -> ([a]->y) -> [[a]] -> [(x,y)] -ungroupBy f g = map helper where - helper [] = (err "empty group passed to ungroupBy",g []) - helper x@(x1:_) = (f x1,g x) --} -- dumb smart constructor for tracing construction (I wanted to monitor laziness) {-# INLINE makeDFA #-} makeDFA :: SetIndex -> DT -> DFA @@ -55,11 +47,13 @@ -- Note that no CompOption or ExecOption parameter is needed. nfaToDFA :: ((Index,Array Index QNFA),Array Tag OP,Array GroupIndex [GroupInfo]) - -> (CompOption -> ExecOption -> Regex) -nfaToDFA ((startIndex,aQNFA),aTagOp,aGroupInfo) = Regex dfa startIndex indexBounds tagBounds trie aTagOp aGroupInfo where + -> CompOption -> ExecOption + -> Regex +nfaToDFA ((startIndex,aQNFA),aTagOp,aGroupInfo) co eo = Regex dfa startIndex indexBounds tagBounds trie aTagOp aGroupInfo ifa co eo where dfa = indexesToDFA [startIndex] indexBounds = bounds aQNFA tagBounds = bounds aTagOp + ifa = (not (multiline co)) && isDFAFrontAnchored dfa indexesToDFA = {-# SCC "nfaToDFA.indexesToDFA" #-} Trie.lookupAsc trie -- Lookup in cache @@ -100,7 +94,7 @@ Simple' { dt_win = makeWinner , dt_trans = fmap qtransToDFA t -- , dt_other = if IMap.null o then Just (newTransition $ IMap.singleton startIndex mempty) else Just (qtransToDFA o)} - , dt_other = Just (qtransToDFA o)} + , dt_other = qtransToDFA o} where makeWinner :: IntMap {- Index -} Instructions -- (RunState ()) makeWinner | noWin w = IMap.empty @@ -127,9 +121,7 @@ where w = w1 `mappend` w2 t = fuseDTrans -- t1 o1 t2 o2 - o = case (o1,o2) of - (Just o1', Just o2') -> Just (mergeDTrans o1' o2') - _ -> o1 `mplus` o2 + o = mergeDTrans o1 o2 -- This is very much like mergeQTrans mergeDTrans :: Transition -> Transition -> Transition mergeDTrans (Transition {trans_how=dt1}) (Transition {trans_how=dt2}) = makeTransition dtrans @@ -140,17 +132,16 @@ where l1 = IMap.toAscList (unCharMap t1) l2 = IMap.toAscList (unCharMap t2) - merge_o1 = case o1 of Nothing -> id - Just o1' -> mergeDTrans o1' - merge_o2 = case o2 of Nothing -> id - Just o2' -> mergeDTrans o2' - fuse [] y = if isJust o1 then mapSnd merge_o1 y else y - fuse x [] = if isJust o2 then mapSnd merge_o2 x else x + fuse :: [(IMap.Key, Transition)] + -> [(IMap.Key, Transition)] + -> [(IMap.Key, Transition)] + fuse [] y = fmap (fmap (mergeDTrans o1)) y + fuse x [] = fmap (fmap (mergeDTrans o2)) x fuse x@((xc,xa):xs) y@((yc,ya):ys) = case compare xc yc of - LT -> (xc,merge_o2 xa) : fuse xs y + LT -> (xc,mergeDTrans o2 xa) : fuse xs y EQ -> (xc,mergeDTrans xa ya) : fuse xs ys - GT -> (yc,merge_o1 ya) : fuse x ys + GT -> (yc,mergeDTrans o1 ya) : fuse x ys mergeDT dt1@(Testing' wt1 dopas1 a1 b1) dt2@(Testing' wt2 dopas2 a2 b2) = case compare wt1 wt2 of LT -> nestDT dt1 dt2 @@ -177,7 +168,7 @@ -- Get all trans_many states flattenDT :: DT -> [DFA] -flattenDT (Simple' {dt_trans=(CharMap mt),dt_other=mo}) = concatMap (\d -> [trans_many d,trans_single d]) . maybe id (:) mo . IMap.elems $ mt +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 @@ -301,30 +292,32 @@ cw xx [] = foldr (\x rest -> comp (Just x) Nothing `mappend` rest) mempty xx cw [] yy = foldr (\y rest -> comp Nothing (Just y) `mappend` rest) mempty yy --- can DT never win or accept a character? -isDTLosing :: DT -> Bool -isDTLosing (Testing' {dt_a=a,dt_b=b}) = isDTLosing a && isDTLosing b -isDTLosing (Simple' {dt_win=w}) | not (IMap.null w) = False -- can win -isDTLosing (Simple' {dt_trans=CharMap mt,dt_other=mo}) = - let ts = (maybe id (:) mo) (IMap.elems mt) - in all transLoses ts - -transLoses :: Transition -> Bool -transLoses t@(Transition {trans_single=dfa}) = isSpawning t || ISet.null (d_id dfa) -isSpawning :: Transition -> Bool -isSpawning t = case IMap.elems (trans_how t) of - [m] -> case IMap.keys m of - [] -> True - _ -> False - _ -> False --- Assumes that Test_BOL is the smallest (and therefore always first) test -isDTFrontAnchored :: DT -> Bool -isDTFrontAnchored (Testing' {dt_test=wt,dt_b=b}) | wt == Test_BOL = isDTLosing b -isDTFrontAnchored _ = False - isDFAFrontAnchored :: DFA -> Bool isDFAFrontAnchored = isDTFrontAnchored . d_dt + where + isDTFrontAnchored :: DT -> Bool + isDTFrontAnchored (Simple' {}) = False + isDTFrontAnchored (Testing' {dt_test=wt,dt_a=a,dt_b=b}) | wt == Test_BOL = isDTLosing b + | otherwise = isDTFrontAnchored a && isDTFrontAnchored b + where + -- can DT never win or accept a character (when following trans_single)? + isDTLosing :: DT -> Bool + isDTLosing (Testing' {dt_a=a,dt_b=b}) = isDTLosing a && isDTLosing b + isDTLosing (Simple' {dt_win=w}) | not (IMap.null w) = False -- can win with 0 characters + isDTLosing (Simple' {dt_trans=CharMap mt,dt_other=o}) = + let ts = o : IMap.elems mt + in all transLoses ts + where + transLoses :: Transition -> Bool + transLoses (Transition {trans_single=dfa,trans_how=dtrans}) = isDTLose dfa || onlySpawns dtrans + where + isDTLose :: DFA -> Bool + isDTLose dfa = ISet.null (d_id dfa) + onlySpawns :: DTrans -> Bool + onlySpawns t = case IMap.elems t of + [m] -> IMap.null m + _ -> False {- toInstructions -} diff --git a/regex-tdfa.cabal b/regex-tdfa.cabal --- a/regex-tdfa.cabal +++ b/regex-tdfa.cabal @@ -1,5 +1,5 @@ Name: regex-tdfa -Version: 1.0.0 +Version: 1.1.0 -- 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 @@ -18,6 +18,25 @@ -- 0.99.19 try for pre-comparison of orbit-logs! -- 0.99.20 go to many vs single? -- 1.0.0 +-- 1.0.1 add NewDFATest.hs +-- 1.0.2 arg, the prof is fast and the normal slow! +-- 1.0.3 try to alter matchTest to not have the Bool args? No +-- np2 comment out all Testing code? No +-- np3 !off the multi? No +-- np4 comment out all Single0 and Single code? No +-- np5 comment out all Multi0 code? No +-- np6 comment out ans check? No +-- np7 just return True? Fast +-- np8 np6 and NOINLINE endOff? No +-- np9 INLINE endOf? No +-- np10 Peel off CharMap/IntMap and DFA/DT with pattern matching? No +-- np11 break multi to not look at o and just return True? Yes !!!! +-- np12 expand o in the case where t lookup get Nothing? Yes--this is the fix!? +-- np13 try to improve readability with the "mm" combinator? Yes! +-- 1.0.4 try repaired NewDFATest_SBS +-- 1.0.5 use "uncons" on SBS +-- 1.0.6 try NewDFATest_SBS with uncons +-- 1.0.7 make NewDFA directory and String_NC License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2007, Christopher Kuklewicz @@ -43,24 +62,29 @@ Build-Depends: base < 4.0 other-modules: Paths_regex_tdfa - Exposed-Modules: Text.Regex.TDFA.Common + Exposed-Modules: Data.IntMap.CharMap2 + Data.IntMap.EnumMap2 + Data.IntSet.EnumSet2 + Text.Regex.TDFA + Text.Regex.TDFA.ByteString + Text.Regex.TDFA.ByteString.Lazy + Text.Regex.TDFA.Common + Text.Regex.TDFA.CorePattern Text.Regex.TDFA.IntArrTrieSet - Text.Regex.TDFA.TNFA - Text.Regex.TDFA.TDFA + Text.Regex.TDFA.NewDFA.Engine + Text.Regex.TDFA.NewDFA.Engine_FA + Text.Regex.TDFA.NewDFA.Engine_NC + Text.Regex.TDFA.NewDFA.Engine_NC_FA + Text.Regex.TDFA.NewDFA.Tester + Text.Regex.TDFA.NewDFA.Uncons Text.Regex.TDFA.Pattern Text.Regex.TDFA.ReadRegex - Text.Regex.TDFA.CorePattern - Text.Regex.TDFA.NewDFA - Text.Regex.TDFA.String - Text.Regex.TDFA.ByteString - Text.Regex.TDFA.ByteString.Lazy Text.Regex.TDFA.Sequence + Text.Regex.TDFA.String + Text.Regex.TDFA.TDFA + Text.Regex.TDFA.TNFA Text.Regex.TDFA.Wrap - Text.Regex.TDFA - Data.IntSet.EnumSet2 - Data.IntMap.EnumMap2 - Data.IntMap.CharMap2 Buildable: True - Extensions: MultiParamTypeClasses, FunctionalDependencies, BangPatterns, MagicHash, RecursiveDo, NoMonoPatBinds, ForeignFunctionInterface, UnboxedTuples, TypeOperators, FlexibleContexts, ExistentialQuantification, UnliftedFFITypes, TypeSynonymInstances + Extensions: MultiParamTypeClasses, FunctionalDependencies, BangPatterns, MagicHash, RecursiveDo, NoMonoPatBinds, ForeignFunctionInterface, UnboxedTuples, TypeOperators, FlexibleContexts, ExistentialQuantification, UnliftedFFITypes, TypeSynonymInstances, FlexibleInstances GHC-Options: -Wall -O2 -funbox-strict-fields GHC-Prof-Options: -auto-all