1-- | This is the code for the main engine. This captures the posix 2-- subexpressions. There is also a non-capturing engine, and a 3-- testing engine. 4-- 5-- It is polymorphic over the internal Uncons type class, and 6-- specialized to produce the needed variants. 7module Text.Regex.TDFA.NewDFA.Engine_FA(execMatch) where 8 9import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..)) 10-- #ifdef __GLASGOW_HASKELL__ 11import GHC.Arr(STArray(..)) 12import GHC.ST(ST(..)) 13import GHC.Exts(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) 14{- 15-- #else 16import Control.Monad.ST(ST) 17import Data.Array.ST(STArray) 18-- #endif 19-} 20 21import Prelude hiding ((!!)) 22import Control.Monad(when,unless,forM,forM_,liftM2,foldM) 23import Data.Array.MArray(MArray(..)) 24import Data.Array.Unsafe(unsafeFreeze) 25import Data.Array.IArray(Array,bounds,assocs,Ix(range)) 26import qualified Data.IntMap.CharMap2 as CMap(findWithDefault) 27import Data.IntMap(IntMap) 28import qualified Data.IntMap as IMap(null,toList,lookup,insert) 29import Data.Maybe(catMaybes) 30import Data.Monoid as Mon(Monoid(..)) 31import qualified Data.IntSet as ISet(toAscList,null) 32import Data.Array.IArray((!)) 33import Data.List(sortBy,groupBy) 34import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef) 35import qualified Control.Monad.ST.Strict as S(ST,runST) 36import Data.Sequence(Seq,ViewL(..),viewl) 37import qualified Data.Sequence as Seq(null) 38import qualified Data.ByteString.Char8 as SBS(ByteString) 39import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString) 40 41import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) 42import Text.Regex.TDFA.Common hiding (indent) 43import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons)) 44import Text.Regex.TDFA.NewDFA.MakeTest(test_singleline,test_multiline) 45 46--import Debug.Trace 47 48-- trace :: String -> a -> a 49-- trace _ a = a 50 51err :: String -> a 52err s = common_error "Text.Regex.TDFA.NewDFA.Engine_FA" s 53 54{-# INLINE (!!) #-} 55(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e 56(!!) = unsafeRead 57{-# INLINE set #-} 58set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () 59set = unsafeWrite 60 61noSource :: ((Index, Instructions),STUArray s Tag Position,OrbitLog) 62noSource = ((-1,err "noSource"),err "noSource",err "noSource") 63 64{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} 65{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} 66{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} 67{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-} 68execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] 69execMatch (Regex { regex_dfa = DFA {d_id=didIn,d_dt=dtIn} 70 , regex_init = startState 71 , regex_b_index = b_index 72 , regex_b_tags = b_tags_all 73 , regex_tags = aTags 74 , regex_groups = aGroups 75 , regex_compOptions = CompOption { multiline = newline } } ) 76 offsetIn prevIn inputIn = S.runST goNext where 77 78 b_tags :: (Tag,Tag) 79 !b_tags = b_tags_all 80 81 orbitTags :: [Tag] 82 !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags 83 84 !test = mkTest newline 85 86 comp :: C s 87 comp = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags 88 89 goNext :: ST s [MatchArray] 90 goNext = {-# SCC "goNext" #-} do 91 (SScratch s1In s2In (winQ,blank,which)) <- newScratch b_index b_tags 92 spawnAt b_tags blank startState s1In offsetIn 93 let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-} 94 case dt of 95 Testing' {dt_test=wt,dt_a=a,dt_b=b} -> 96 if test wt offset prev input 97 then next s1 s2 did a offset prev input 98 else next s1 s2 did b offset prev input 99 Simple' {dt_win=w,dt_trans=t,dt_other=o} -> do 100 unless (IMap.null w) $ 101 processWinner s1 w offset 102 case uncons input of 103 Nothing -> finalizeWinner 104 Just (c,input') -> 105 case CMap.findWithDefault o c t of 106 Transition {trans_single=DFA {d_id=did',d_dt=dt'},trans_how=dtrans} 107 | ISet.null did' -> finalizeWinner 108 | otherwise -> findTrans s1 s2 did did' dt' dtrans offset c input' 109 110-- compressOrbits gets all the current Tag-0 start information from 111-- the NFA states; then it loops through all the Orbit tags with 112-- compressOrbit. 113-- 114-- compressOrbit on such a Tag loops through all the NFS states' 115-- m_orbit record, discardind ones that are Nothing and discarding 116-- ones that are too new to care about (after the cutoff value). 117-- 118-- compressOrbit then groups the Orbits records by the Tag-0 start 119-- position and the basePos position. Entried in different groups 120-- will never be comparable in the future so they can be processed 121-- separately. Groups could probably be even more finely 122-- distinguished, as a futher optimization, but the justification will 123-- be tricky. 124-- 125-- Current Tag-0 values are at most offset and all newly spawned 126-- groups will have Tag-0 of at least (succ offset) so the current 127-- groups are closed to those spawned in the future. The basePos may 128-- be as large as offset and may be overwritten later with values of 129-- offset or larger (and this will also involve deleting the Orbits 130-- record). Thus there could be a future collision between a current 131-- group with basePos==offset and an updated record that acquires 132-- basePos==offset. By excluding groups with basePos before the 133-- current offset the collision between existing and future records 134-- is avoided. 135-- 136-- An entry in a group can only collide with that group's 137-- descendents. compressOrbit sends each group to the compressGroup 138-- command. 139-- 140-- compressGroup on a single record checks whether it's Seq can be 141-- cleared and if so it will clear it (and set ordinal to Nothing but 142-- this this not particularly important). 143-- 144-- compressGroup on many records sorts and groups the members and zips 145-- the groups with their new ordinal value. The comparision is based 146-- on the old ordinal value, then the inOrbit value, and then the (Seq 147-- Position) data. 148-- 149-- The old ordinals of the group will all be Nothing or all be Just, 150-- but this condition is neither checked nor violations detected. 151-- This comparision is justified because once records get different 152-- ordinals assigned they will never change places. 153-- 154-- The inOrbit Bool is only different if one of them has set the stop 155-- position to at most (succ offset). They will obly be compared if 156-- the other one leaves, an its stop position will be at least offset. 157-- The previous sentence is justified by inspectin of the "assemble" 158-- function in the TDFA module: there is no (PostUpdate 159-- LeaveOrbitTask) so the largest possible value for the stop Tag is 160-- (pred offset). Thus the record with inOrbit==False would beat (be 161-- GT than) the record with inOrbit==True. 162-- 163-- The Seq comparison is safe because the largest existing Position 164-- value is (pred offset) and the smallest future Position value is 165-- offset. The previous sentence is justified by inspectin of the 166-- "assemble" function in the TDFA module: there is no (PostUpdate 167-- EnterOrbitTags) so the largest possible value in the Seq is (pred 168-- offset). 169-- 170-- The updated Orbits get the new ordinal value and an empty (Seq 171-- Position). 172 173 compressOrbits s1 did offset = do 174 let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state 175 return (state,start) 176 cutoff = offset - 50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50 177 ss <- mapM getStart (ISet.toAscList did) 178 let compressOrbit tag = do 179 mos <- forM ss ( \ p@(state,_start) -> do 180 mo <- fmap (IMap.lookup tag) (m_orbit s1 !! state) 181 case mo of 182 Just orbits | basePos orbits < cutoff -> return (Just (p,orbits)) 183 | otherwise -> return Nothing 184 _ -> return Nothing ) 185 let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return () 186 | otherwise = 187 set (m_orbit s1) state 188 . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty})) 189 =<< m_orbit s1 !! state 190 191 compressGroup gs = do 192 let sortPos (_,b1) (_,b2) = compare (ordinal b1) (ordinal b2) `mappend` 193 compare (inOrbit b2) (inOrbit b1) `mappend` 194 comparePos (viewl (getOrbits b1)) (viewl (getOrbits b2)) 195 groupPos (_,b1) (_,b2) = ordinal b1 == ordinal b2 && getOrbits b1 == getOrbits b2 196 gs' = zip [(1::Int)..] (groupBy groupPos . sortBy sortPos $ gs) 197 forM_ gs' $ \ (!n,eqs) -> do 198 forM_ eqs $ \ ((state,_),orbit) -> 199 set (m_orbit s1) state 200 . (IMap.insert tag $! (orbit { ordinal = Just n, getOrbits = mempty })) 201 =<< m_orbit s1 !! state 202 let sorter ((_,a1),b1) ((_,a2),b2) = compare a1 a2 `mappend` compare (basePos b1) (basePos b2) 203 grouper ((_,a1),b1) ((_,a2),b2) = a1==a2 && basePos b1 == basePos b2 204 orbitGroups = groupBy grouper . sortBy sorter . catMaybes $ mos 205 mapM_ compressGroup orbitGroups 206 mapM_ compressOrbit orbitTags 207 208-- findTrans has to (part 1) decide, for each destination, "which" of 209-- zero or more source NFA states will be the chosen source. Then it 210-- has to (part 2) perform the transition or spawn. It keeps track of 211-- the starting index while doing so, and compares the earliest start 212-- with the stored winners. (part 3) If some winners are ready to be 213-- released then the future continuation of the search is placed in 214-- "storeNext". If no winners are ready to be released then the 215-- computation continues immediately. 216 217 findTrans s1 s2 did did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do 218 -- findTrans part 0 219 -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead? 220 when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did offset) 221 -- findTrans part 1 222 let findTransTo (destIndex,sources) | IMap.null sources = 223 set which destIndex noSource 224 | otherwise = do 225 let prep (sourceIndex,(_dopa,instructions)) = {-# SCC "goNext.findTrans.prep" #-} do 226 pos <- maybe (err $ "findTrans,1 : "++show (sourceIndex,destIndex,did')) return 227 =<< m_pos s1 !! sourceIndex 228 orbit <- m_orbit s1 !! sourceIndex 229 let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) 230 return ((sourceIndex,instructions),pos,orbit') 231 challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do 232 check <- comp offset x1 (newPos ins1) x2 (newPos ins2) 233 if check==LT then return x2 else return x1 234 (first:rest) <- mapM prep (IMap.toList sources) 235 set which destIndex =<< foldM challenge first rest 236 let dl = IMap.toList dtrans 237 mapM_ findTransTo dl 238 -- findTrans part 2 239 let performTransTo (destIndex,_sources) = {-# SCC "goNext.findTrans.performTransTo" #-} do 240 x@((sourceIndex,_instructions),_pos,_orbit') <- which !! destIndex 241 unless (sourceIndex == (-1)) $ 242 (updateCopy x offset s2 destIndex) 243 mapM_ performTransTo dl 244 -- findTrans part 3 245 let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input' 246 247-- The "newWinnerThenProceed" can find both a new non-empty winner and 248-- a new empty winner. A new non-empty winner can cause some of the 249-- NFA states that comprise the DFA state to be eliminated, and if the 250-- startState is eliminated then it must then be respawned. And 251-- imperative flag setting and resetting style is used. 252-- 253-- A non-empty winner from the startState might obscure a potential 254-- empty winner (form the startState at the current offset). This 255-- winEmpty possibility is also checked for. (unit test pattern ".*") 256-- (futher test "(.+|.+.)*" on "aa\n") 257 258 {-# INLINE processWinner #-} 259 processWinner s1 w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do 260 let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do 261 pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex 262 startPos <- pos !! 0 263 orbit <- m_orbit s1 !! sourceIndex 264 let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions) 265 return (startPos,(x,pos,orbit')) 266 challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do 267 check <- comp offset x1 (newPos ins1) x2 (newPos ins2) 268 if check==LT then return x2 else return x1 269 prep'd <- mapM prep (IMap.toList w) 270 case map snd prep'd of 271 [] -> return () 272 (first:rest) -> newWinner offset =<< foldM challenge first rest 273 274 newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do 275 newerPos <- newA_ b_tags 276 copySTU oldPos newerPos 277 doActions preTag newerPos (newPos winInstructions) 278 putMQ (WScratch newerPos) winQ 279 280 finalizeWinner = do 281 mWinner <- readSTRef (mq_mWin winQ) 282 case mWinner of 283 Nothing -> return [] 284 Just winner -> resetMQ winQ >> mapM (tagsToGroupsST aGroups) [winner] 285 286 -- goNext then ends with the next statement 287 next s1In s2In didIn dtIn offsetIn prevIn inputIn 288 289{-# INLINE doActions #-} 290doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s () 291doActions preTag pos ins = mapM_ doAction ins where 292 postTag = succ preTag 293 doAction (tag,SetPre) = set pos tag preTag 294 doAction (tag,SetPost) = set pos tag postTag 295 doAction (tag,SetVal v) = set pos tag v 296 297---- 298 299{-# INLINE mkTest #-} 300mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool 301mkTest isMultiline = if isMultiline then test_multiline else test_singleline 302 303---- 304 305{- MUTABLE WINNER QUEUE -} 306 307newtype MQ s = MQ { mq_mWin :: STRef s (Maybe (WScratch s)) } 308 309newMQ :: S.ST s (MQ s) 310newMQ = do 311 mWin <- newSTRef Nothing 312 return (MQ mWin) 313 314resetMQ :: MQ s -> S.ST s () 315resetMQ (MQ {mq_mWin=mWin}) = do 316 writeSTRef mWin Nothing 317 318putMQ :: WScratch s -> MQ s -> S.ST s () 319putMQ ws (MQ {mq_mWin=mWin}) = do 320 writeSTRef mWin (Just ws) 321 322{- MUTABLE SCRATCH DATA STRUCTURES -} 323 324data SScratch s = SScratch { _s_1 :: !(MScratch s) 325 , _s_2 :: !(MScratch s) 326 , _s_rest :: !( MQ s 327 , BlankScratch s 328 , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog) 329 ) 330 } 331data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position))) 332 , m_orbit :: !(STArray s Index OrbitLog) 333 } 334newtype BlankScratch s = BlankScratch { _blank_pos :: (STUArray s Tag Position) 335 } 336newtype WScratch s = WScratch { w_pos :: (STUArray s Tag Position) 337 } 338 339{- DEBUGGING HELPERS -} 340 341{- 342indent :: String -> String 343indent xs = ' ':' ':xs 344 345showMS :: MScratch s -> Index -> ST s String 346showMS s i = do 347 ma <- m_pos s !! i 348 mc <- m_orbit s !! i 349 a <- case ma of 350 Nothing -> return "No pos" 351 Just pos -> fmap show (getAssocs pos) 352 let c = show mc 353 return $ unlines [ "MScratch, index = "++show i 354 , indent a 355 , indent c] 356 357showWS :: WScratch s -> ST s String 358showWS (WScratch pos) = do 359 a <- getAssocs pos 360 return $ unlines [ "WScratch" 361 , indent (show a)] 362-} 363{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -} 364 365{-# INLINE newA #-} 366newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e) 367newA b_tags initial = newArray b_tags initial 368 369{-# INLINE newA_ #-} 370newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e) 371newA_ b_tags = newArray_ b_tags 372 373newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s) 374newScratch b_index b_tags = do 375 s1 <- newMScratch b_index 376 s2 <- newMScratch b_index 377 winQ <- newMQ 378 blank <- fmap BlankScratch (newA b_tags (-1)) 379 which <- (newArray b_index ((-1,err "newScratch which 1"),err "newScratch which 2",err "newScratch which 3")) 380 return (SScratch s1 s2 (winQ,blank,which)) 381 382newMScratch :: (Index,Index) -> S.ST s (MScratch s) 383newMScratch b_index = do 384 pos's <- newArray b_index Nothing 385 orbit's <- newArray b_index Mon.mempty 386 return (MScratch pos's orbit's) 387 388{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -} 389 390newtype F s = F ([F s] -> C s) 391type C s = Position 392 -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) 393 -> [(Int, Action)] 394 -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits) 395 -> [(Int, Action)] 396 -> ST s Ordering 397 398{-# INLINE orderOf #-} 399orderOf :: Action -> Action -> Ordering 400orderOf post1 post2 = 401 case (post1,post2) of 402 (SetPre,SetPre) -> EQ 403 (SetPost,SetPost) -> EQ 404 (SetPre,SetPost) -> LT 405 (SetPost,SetPre) -> GT 406 (SetVal v1,SetVal v2) -> compare v1 v2 407 _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2) 408 409ditzyComp'3 :: forall s. Array Tag OP -> C s 410ditzyComp'3 aTagOP = comp0 where 411 (F comp1:compsRest) = allcomps 1 412 413 comp0 :: C s 414 comp0 preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = do 415 c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize 416 case c of 417 EQ -> comp1 compsRest preTag x1 np1 x2 np2 418 answer -> return answer 419 420 allcomps :: Tag -> [F s] 421 allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)] 422 | otherwise = 423 case aTagOP ! tag of 424 Orbit -> F (challenge_Orb tag) : allcomps (succ tag) 425 Maximize -> F (challenge_Max tag) : allcomps (succ tag) 426 Ignore -> F (challenge_Ignore tag) : allcomps (succ tag) 427 Minimize -> err "allcomps Minimize" 428 where top = snd (bounds aTagOP) 429 430 challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 = 431 case np1 of 432 ((t1,_):rest1) | t1==tag -> 433 case np2 of 434 ((t2,_):rest2) | t2==tag -> next comps preTag x1 rest1 x2 rest2 435 _ -> next comps preTag x1 rest1 x2 np2 436 _ -> do 437 case np2 of 438 ((t2,_):rest2) | t2==tag -> next comps preTag x1 np1 x2 rest2 439 _ -> next comps preTag x1 np1 x2 np2 440 challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867" 441 442 challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = 443 case np1 of 444 ((t1,b1):rest1) | t1==tag -> 445 case np2 of 446 ((t2,b2):rest2) | t2==tag -> 447 if b1==b2 then next comps preTag x1 rest1 x2 rest2 448 else return (orderOf b1 b2) 449 _ -> do 450 p2 <- pos2 !! tag 451 let p1 = case b1 of SetPre -> preTag 452 SetPost -> succ preTag 453 SetVal v -> v 454 if p1==p2 then next comps preTag x1 rest1 x2 np2 455 else return (compare p1 p2) 456 _ -> do 457 p1 <- pos1 !! tag 458 case np2 of 459 ((t2,b2):rest2) | t2==tag -> do 460 let p2 = case b2 of SetPre -> preTag 461 SetPost -> succ preTag 462 SetVal v -> v 463 if p1==p2 then next comps preTag x1 np1 x2 rest2 464 else return (compare p1 p2) 465 _ -> do 466 p2 <- pos2 !! tag 467 if p1==p2 then next comps preTag x1 np1 x2 np2 468 else return (compare p1 p2) 469 challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" 470 471 challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = 472 let s1 = IMap.lookup tag orbit1' 473 s2 = IMap.lookup tag orbit2' 474 in case (s1,s2) of 475 (Nothing,Nothing) -> next comps preTag x1 np1 x2 np2 476 (Just o1,Just o2) | inOrbit o1 == inOrbit o2 -> 477 case compare (ordinal o1) (ordinal o2) `mappend` 478 comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of 479 EQ -> next comps preTag x1 np1 x2 np2 480 answer -> return answer 481 _ -> err $ unlines [ "challenge_Orb is too stupid to handle mismatched orbit data :" 482 , show(tag,preTag,np1,np2) 483 , show s1 484 , show s2 485 ] 486 challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347" 487 488comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering 489comparePos EmptyL EmptyL = EQ 490comparePos EmptyL _ = GT 491comparePos _ EmptyL = LT 492comparePos (p1 :< ps1) (p2 :< ps2) = 493 compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2) 494 495{- CONVERT WINNERS TO MATCHARRAY -} 496 497tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray 498tagsToGroupsST aGroups (WScratch {w_pos=pos})= do 499 let b_max = snd (bounds (aGroups)) 500 ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength)) 501 startPos0 <- pos !! 0 502 stopPos0 <- pos !! 1 503 set ma 0 (startPos0,stopPos0-startPos0) 504 let act _this_index [] = return () 505 act this_index ((GroupInfo _ parent start stop flagtag):gs) = do 506 flagVal <- pos !! flagtag 507 if (-1) == flagVal then act this_index gs 508 else do 509 startPos <- pos !! start 510 stopPos <- pos !! stop 511 (startParent,lengthParent) <- ma !! parent 512 let ok = (0 <= startParent && 513 0 <= lengthParent && 514 startParent <= startPos && 515 stopPos <= startPos + lengthParent) 516 if not ok then act this_index gs 517 else set ma this_index (startPos,stopPos-startPos) 518 forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i)) 519 unsafeFreeze ma 520 521{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -} 522 523{-# INLINE spawnAt #-} 524-- Reset the entry at "Index", or allocate such an entry. 525-- set tag 0 to the "Position" 526spawnAt :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s () 527spawnAt b_tags (BlankScratch blankPos) i s1 thisPos = do 528 oldPos <- m_pos s1 !! i 529 pos <- case oldPos of 530 Nothing -> do 531 pos' <- newA_ b_tags 532 set (m_pos s1) i (Just pos') 533 return pos' 534 Just pos -> return pos 535 copySTU blankPos pos 536 set (m_orbit s1) i $! mempty 537 set pos 0 thisPos 538 539{-# INLINE updateCopy #-} 540updateCopy :: ((Index, Instructions), STUArray s Tag Position, OrbitLog) 541 -> Index 542 -> MScratch s 543 -> Int 544 -> ST s () 545updateCopy ((_i1,instructions),oldPos,newOrbit) preTag s2 i2 = do 546 b_tags <- getBounds oldPos 547 newerPos <- maybe (do 548 a <- newA_ b_tags 549 set (m_pos s2) i2 (Just a) 550 return a) return =<< m_pos s2 !! i2 551 copySTU oldPos newerPos 552 doActions preTag newerPos (newPos instructions) 553 set (m_orbit s2) i2 $! newOrbit 554 555{- USING memcpy TO COPY STUARRAY DATA -} 556 557-- #ifdef __GLASGOW_HASKELL__ 558foreign import ccall unsafe "memcpy" 559 memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO () 560 561{- 562Prelude Data.Array.Base> :i STUArray 563data STUArray s i e 564 = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s) 565 -- Defined in Data.Array.Base 566-} 567-- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1 568{-# INLINE copySTU #-} 569copySTU :: (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) 570copySTU _souce@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) = 571-- do b1 <- getBounds s1 572-- b2 <- getBounds s2 573-- when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2))) 574 ST $ \s1# -> 575 case sizeofMutableByteArray# msource of { n# -> 576 case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) -> 577 (# s2#, () #) }} 578{- 579#else /* !__GLASGOW_HASKELL__ */ 580 581copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) 582copySTU source destination = do 583 b@(start,stop) <- getBounds source 584 b' <- getBounds destination 585 -- traceCopy ("> copySTArray "++show b) $ do 586 when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b')) 587 forM_ (range b) $ \index -> 588 set destination index =<< source !! index 589 return destination 590#endif /* !__GLASGOW_HASKELL__ */ 591-} 592