regex-tdfa 1.0.0 → 1.1.0

raw patch · 15 files changed

+2135/−985 lines, 15 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/Regex/TDFA/ByteString.hs +11/−6
• Text/Regex/TDFA/ByteString/Lazy.hs +20/−8
• Text/Regex/TDFA/Common.hs +3/−3
• Text/Regex/TDFA/NewDFA.hs +0/−884
• Text/Regex/TDFA/NewDFA/Engine.hs +774/−0
• Text/Regex/TDFA/NewDFA/Engine_FA.hs +652/−0
• Text/Regex/TDFA/NewDFA/Engine_NC.hs +288/−0
• Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs +110/−0
• Text/Regex/TDFA/NewDFA/Tester.hs +126/−0
• Text/Regex/TDFA/NewDFA/Uncons.hs +28/−0
• Text/Regex/TDFA/Pattern.hs +9/−5
• Text/Regex/TDFA/Sequence.hs +14/−7
• Text/Regex/TDFA/String.hs +23/−12
• Text/Regex/TDFA/TDFA.hs +39/−46
• regex-tdfa.cabal +38/−14

@@ -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

@@ -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 

@@ -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 "

@@ -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__ */--}

@@ -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__ */+-}

@@ -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__ */+-}

@@ -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+

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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 -} 

@@ -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