module Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine,newTagEngine2
,newScratch,tagsToGroupsST
,toInstructions,compareWith,resetScratch
,SScratch(..),MScratch,WScratch) where
import Control.Monad(forM_,liftM,liftM2,liftM3,foldM)
import Control.Monad.State(MonadState(..),execState)
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(when)
import Control.Monad.ST(ST)
import Data.Array.ST(STArray)
#endif
import Data.Array.MArray(MArray(..),newListArray,unsafeFreeze)
import Data.Array.IArray(Array,(!),bounds,assocs)
import Data.IntMap(IntMap)
import qualified Data.IntMap as IMap(null,toList,insert,insertWith,insertWithKey,delete,lookup,keys)
import Data.Ix(Ix(..))
import Data.Monoid(Monoid(..))
import Data.Sequence as S((|>),viewl,ViewL(..))
import Data.STRef(newSTRef,readSTRef,writeSTRef,STRef)
import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)
import Text.Regex.TDFA.Common
err :: String -> a
err s = common_error "Text.Regex.TDFA.RunMutState" s
data TagEngine s t p = TagEngine
!(MScratch s -> Position -> IntMap (IntMap (t,Instructions)) -> ST s ())
!(MScratch s -> p -> Maybe (WScratch s,p) -> IntMap Instructions -> ST s (Maybe (WScratch s,p)))
!(MScratch s -> MScratch s -> Position -> IntMap (IntMap (DoPa,Instructions)) -> ST s ())
newTagEngine :: Regex -> ST s (TagEngine s t (Position,Char,xxx))
newTagEngine regexIn = do
(which,count) <- newBoard regexIn
let comp = makeTagComparer (regex_tags regexIn)
let findTrans s1 off trans = (mapM_ findTrans' (IMap.toList trans)) where
findTrans' (destIndex,sources) | IMap.null sources =
unsafeWrite which destIndex ((1,undefined),undefined,undefined)
| otherwise = do
let (first:rest) = IMap.toList sources
prep (sourceIndex,(_,instructions)) = do
p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex
o <- unsafeRead (m_orbit s1) sourceIndex
let o' = maybe o (\x -> x off o) (newOrbits instructions)
return ((sourceIndex,instructions),p,o')
challenge x1 y1 = do
x2 <- prep y1
check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)
if check==LT then return x2 else return x1
x1 <- prep first
x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest
unsafeWrite which destIndex x
unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ
let
updateWinner s1 (off,prev,input) winning sources | IMap.null sources = return winning
| otherwise = do
let (first:rest) = IMap.toList sources
prep x@(sourceIndex,instructions) = do
p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex
o <- unsafeRead (m_orbit s1) sourceIndex
let o' = maybe o (\f -> f off o) (newOrbits instructions)
return (x,p,o')
challenge x1 y1 = do
x2 <- prep y1
check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)
x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)
if check==LT then return x2 else return x1
x1 <- prep first
((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest
n <- unsafeRead count sourceIndex'
w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)
return (Just (w,(off,prev,input)))
let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()
| otherwise = do
mapM_ performTrans' (IMap.keys dtrans)
where performTrans' destIndex = do
i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex
if sourceIndex == (1) then return () else do
n <- unsafeRead count sourceIndex
unsafeWrite count sourceIndex (pred n)
if n==1 then updateSwap s1 i1 off s2 destIndex
else updateCopy s1 i1 off s2 destIndex
return (TagEngine findTrans updateWinner performTrans)
newTagEngine2 :: Regex -> ST s (TagEngine s t Position)
newTagEngine2 regexIn = do
(which,count) <- newBoard regexIn
let comp = makeTagComparer (regex_tags regexIn)
let findTrans s1 off trans = (mapM_ findTrans' (IMap.toList trans)) where
findTrans' (destIndex,sources) | IMap.null sources =
unsafeWrite which destIndex ((1,undefined),undefined,undefined)
| otherwise = do
let (first:rest) = IMap.toList sources
prep (sourceIndex,(_,instructions)) = do
p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex
o <- unsafeRead (m_orbit s1) sourceIndex
let o' = maybe o (\x -> x off o) (newOrbits instructions)
return ((sourceIndex,instructions),p,o')
challenge x1 y1 = do
x2 <- prep y1
check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)
if check==LT then return x2 else return x1
x1 <- prep first
x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest
unsafeWrite which destIndex x
unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ
let
updateWinner s1 off winning sources | IMap.null sources = return winning
| otherwise = do
let (first:rest) = IMap.toList sources
prep x@(sourceIndex,instructions) = do
p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex
o <- unsafeRead (m_orbit s1) sourceIndex
let o' = maybe o (\f -> f off o) (newOrbits instructions)
return (x,p,o')
challenge x1 y1 = do
x2 <- prep y1
check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)
x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)
if check==LT then return x2 else return x1
x1 <- prep first
((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest
n <- unsafeRead count sourceIndex'
w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)
return (Just (w,off))
let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()
| otherwise = do
mapM_ performTrans' (IMap.keys dtrans)
where performTrans' destIndex = do
i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex
if sourceIndex == (1) then return () else do
n <- unsafeRead count sourceIndex
unsafeWrite count sourceIndex (pred n)
if n==1 then updateSwap s1 i1 off s2 destIndex
else updateCopy s1 i1 off s2 destIndex
return (TagEngine findTrans updateWinner performTrans)
newBoard :: Regex -> ST s (STArray s Index ((Index,Instructions),a,OrbitLog)
,STUArray s Index Int)
newBoard regexIn = do
let bWhich = (0,regex_init regexIn)
bCount = (0,regex_init regexIn)
liftM2 (,) (newListArray bWhich (replicate (rangeSize bWhich) ((1,undefined),undefined,undefined)))
(newArray bCount 0)
newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> ST s (STUArray s Tag e)
newA b_tags initial =
newArray b_tags initial
newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> ST s (STUArray s Tag e)
newA_ b_tags =
newArray_ b_tags
data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))
, m_flag :: !(STArray s Index (Maybe (STUArray s Tag Bool)))
, m_orbit :: !(STArray s Index OrbitLog)
}
data SScratch s= SScratch { s_1 :: !(MScratch s)
, s_2 :: !(MScratch s)
, w_blank :: !(WScratch s)
}
data WScratch s = WScratch { w_pos :: !(STRef s (STUArray s Tag Position))
, w_flag :: !(STRef s (STUArray s Tag Bool))
, w_orbit :: !(STRef s OrbitLog)
}
newWScratch :: (Tag,Tag) -> ST s (WScratch s)
newWScratch b_tags = liftM3 WScratch (newSTRef =<< newA b_tags (1))
(newSTRef =<< newA b_tags False)
(newSTRef mempty)
newWScratch_ :: (Tag,Tag) -> ST s (WScratch s)
newWScratch_ b_tags = liftM3 WScratch (newSTRef =<< newA_ b_tags)
(newSTRef =<< newA_ b_tags)
(newSTRef mempty)
resetScratch :: Regex -> Position -> MScratch s -> WScratch s -> ST s ()
resetScratch regexIn startPos s1 w0 = do
let i = regex_init regexIn
b_tags = bounds (regex_tags regexIn)
oldPos <- unsafeRead (m_pos s1) i
initialPos <- case oldPos of
Nothing -> newA b_tags (1)
Just pos -> do blank <- readSTRef (w_pos w0)
copySTU blank pos
return pos
unsafeWrite initialPos 0 startPos
unsafeWrite (m_pos s1) i (Just initialPos)
oldFlags <- unsafeRead (m_flag s1) i
initFlags <- case oldFlags of
Nothing -> newA b_tags False
Just flags -> do
blank <- readSTRef (w_flag w0)
copySTU blank flags
return flags
unsafeWrite initFlags 0 True
unsafeWrite (m_flag s1) i (Just initFlags)
unsafeWrite (m_orbit s1) i mempty
newScratch :: Regex -> Position -> ST s (SScratch s)
newScratch regexIn startPos = do
let i = regex_init regexIn
b_index = (0,i)
b_tags = bounds (regex_tags regexIn)
s@(SScratch {s_1=s1,w_blank=w0}) <- newSScratch b_index b_tags
resetScratch regexIn startPos s1 w0
return s
newSScratch :: (Index, Index) -> (Tag, Tag) -> ST s (SScratch s)
newSScratch b_index b_tags = do
s1 <- newMScratch b_index
s2 <- newMScratch b_index
w0 <- newWScratch b_tags
return (SScratch s1 s2 w0)
newMScratch :: (Index,Index) -> ST s (MScratch s)
newMScratch b_index = do
let n = rangeSize b_index
pos <- newListArray b_index (replicate n Nothing)
flag <- newListArray b_index (replicate n Nothing)
orbit <- newListArray b_index (replicate n mempty)
return (MScratch pos flag orbit)
copyUpdateTags :: (MArray (STUArray s) Position (ST s))
=> STUArray s Tag Position
-> [(Tag,Bool)]
-> Position -> Position
-> STUArray s Tag Position
-> (ST s) ()
copyUpdateTags a1 changes pFalse pTrue a2 = do
copySTU a1 a2
mapM_ (\(tag,v) -> if v then unsafeWrite a2 tag pTrue
else unsafeWrite a2 tag pFalse) changes
copyUpdateFlags :: (MArray (STUArray s) Bool (ST s))
=> STUArray s Tag Bool
-> [(Tag,Bool)]
-> STUArray s Tag Bool
-> (ST s) ()
copyUpdateFlags a1 changes a2 = do
copySTU a1 a2
mapM_ (\(tag,v) -> unsafeWrite a2 tag v) changes
updateWinning :: MScratch s
-> ( Index,Instructions,OrbitLog)
-> Position
-> Int
-> Maybe (WScratch s)
-> ST s (WScratch s)
updateWinning s1 (i1,ins,o) preTag n mw = do
(Just pos1) <- unsafeRead (m_pos s1) i1
(Just flag1) <- unsafeRead (m_flag s1) i1
let val x = if x then postTag else preTag
postTag = succ preTag
if n==0
then do
mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)
mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)
case mw of
Nothing -> liftM3 WScratch (newSTRef pos1) (newSTRef flag1) (newSTRef o)
Just w -> do writeSTRef (w_pos w) pos1
writeSTRef (w_flag w) flag1
writeSTRef (w_orbit w) o
return w
else do
w <- case mw of
Nothing -> getBounds pos1 >>= newWScratch_
Just w -> return w
pos2 <- readSTRef (w_pos w)
flag2 <- readSTRef (w_flag w)
copyUpdateTags pos1 (newPos ins) preTag postTag pos2
copyUpdateFlags flag1 (newFlags ins) flag2
writeSTRef (w_orbit w) o
return w
updateSwap :: MScratch s
-> (( Index,Instructions),STUArray s Tag Position,OrbitLog)
-> Position
-> MScratch s -> Index
-> ST s ()
updateSwap s1 ((i1,ins),_,o) preTag s2 i2 = do
pos1'@(Just pos1) <- unsafeRead (m_pos s1) i1
flag1'@(Just flag1) <- unsafeRead (m_flag s1) i1
unsafeWrite (m_pos s1) i1 =<< unsafeRead (m_pos s2) i2
unsafeWrite (m_flag s1) i1 =<< unsafeRead (m_flag s2) i2
unsafeWrite (m_pos s2) i2 pos1'
unsafeWrite (m_flag s2) i2 flag1'
unsafeWrite (m_orbit s2) i2 o
let val x = if x then postTag else preTag where postTag = succ preTag
mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)
mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)
updateCopy :: MScratch s
-> (( Index,Instructions),STUArray s Tag Position,OrbitLog)
-> Position
-> MScratch s -> Index
-> ST s ()
updateCopy s1 ((i1,ins),_,o) preTag s2 i2 = do
pos1 <- maybe (err $ "forceUpdate : m_pos s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_pos s1) i1
flag1 <- maybe (err $ "forceUpdate : m_flag s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_flag s1) i1
b_tags <- getBounds pos1
pos2 <- maybe (do a <- newA_ b_tags
unsafeWrite (m_pos s2) i2 (Just a)
return a) return =<< unsafeRead (m_pos s2) i2
flag2 <- maybe (do a <- newA_ b_tags
unsafeWrite (m_flag s2) i2 (Just a)
return a) return =<< unsafeRead (m_flag s2) i2
copyUpdateTags pos1 (newPos ins) preTag (succ preTag) pos2
copyUpdateFlags flag1 (newFlags ins) flag2
unsafeWrite (m_orbit s2) i2 o
makeTagComparer :: Array Tag OP
-> Position
-> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
-> [(Int, Bool)]
-> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
-> [(Int, Bool)]
-> ST s Ordering
makeTagComparer aTagOP = foldr ($) end (map chooseBranch
(dropWhile ((1>=).fst)
(assocs aTagOP)))
where chooseBranch (tag,Maximize) = challenge_Max tag
chooseBranch (tag,Minimize) = challenge_Min tag
chooseBranch (tag,Orbit) = challenge_Orb tag
end _ _ _ _ _ = return EQ
challenge_Orb tag next preTag x1@(_state1,_,orbit1') np1 x2@(_state2,_,orbit2') np2 =
let s1 = IMap.lookup tag orbit1'
s2 = IMap.lookup tag orbit2'
in case (s1,s2) of
(Nothing,Nothing) -> next preTag x1 np1 x2 np2
(Just o1,Just o2) | inOrbit o1 == inOrbit o2 ->
case comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of
EQ -> next preTag x1 np1 x2 np2
answer -> return answer
_ -> err $ "challenge_Orb is too stupid to handle mismatched orbit data :"
++ show(tag,preTag,np1,np2)
where 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)
challenge_Max tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do
(np1',p1) <- case np1 of
((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
_ -> liftM ((,) np1) (unsafeRead pos1 tag)
(np2',p2) <- case np2 of
((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
_ -> liftM ((,) np2) (unsafeRead pos2 tag)
case (p1,p2) of
(1,1) -> next preTag x1 np1' x2 np2'
(_ ,1) -> return GT
(1, _) -> return LT
_ -> let answer = compare p1 p2
in if answer == EQ then next preTag x1 np1' x2 np2'
else return answer
challenge_Min tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do
(np1',p1) <- case np1 of
((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
_ -> liftM ((,) np1) (unsafeRead pos1 tag)
(np2',p2) <- case np2 of
((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
_ -> liftM ((,) np2) (unsafeRead pos2 tag)
case (p1,p2) of
(1,1) -> next preTag x1 np1' x2 np2'
(_ ,1) -> return LT
(1, _) -> return GT
_ -> let answer = compare p2 p1
in if answer == EQ then next preTag x1 np1' x2 np2'
else return answer
compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a
compareWith comp = cw where
cw [] [] = comp Nothing Nothing
cw xx@(x:xs) yy@(y:ys) =
case compare (fst x) (fst y) of
GT -> comp Nothing (Just y) `mappend` cw xx ys
EQ -> comp (Just x) (Just y) `mappend` cw xs ys
LT -> comp (Just x) Nothing `mappend` cw xs yy
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
modifyPos :: Bool -> Tag -> CompileInstructions ()
modifyPos todo tag = do
(a,b,c) <- get
let a' = IMap.insert tag todo a
b' = IMap.insert tag True b
put (a',b',c)
setPreTag :: Tag -> CompileInstructions ()
setPreTag = modifyPos False
setPostTag :: Tag -> CompileInstructions ()
setPostTag = modifyPos True
resetTag :: Tag -> CompileInstructions ()
resetTag tag = do
(a,b,c) <- get
let b' = IMap.insert tag False b
put (a,b',c)
modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyOrbit f = do
(a,b,c) <- get
let c' = f c
put (a,b,c')
modifyFlagOrbit :: Tag -> Bool -> (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyFlagOrbit tag flag f = do
(a,b,c) <- get
let b' = IMap.insert tag flag b
c' = f c
put (a,b',c')
resetOrbit :: Tag -> CompileInstructions ()
resetOrbit tag = modifyFlagOrbit tag False (IMap.insert tag AlterReset)
leaveOrbit :: Tag -> CompileInstructions ()
leaveOrbit tag = modifyOrbit escapeOrbit where
escapeOrbit = IMap.insertWith setInOrbitFalse tag AlterLeave where
setInOrbitFalse _ x@(AlterModify {}) = x {newInOrbit = False}
setInOrbitFalse _ x = x
enterOrbit :: Tag -> CompileInstructions ()
enterOrbit tag = modifyFlagOrbit tag True changeOrbit where
changeOrbit = IMap.insertWith overwriteOrbit tag appendNewOrbit
appendNewOrbit = AlterModify {newInOrbit = True, freshOrbit = False}
startNewOrbit = AlterModify {newInOrbit = True, freshOrbit = True}
overwriteOrbit _ AlterReset = startNewOrbit
overwriteOrbit _ AlterLeave = startNewOrbit
overwriteOrbit _ (AlterModify {newInOrbit = False}) = startNewOrbit
overwriteOrbit _ (AlterModify {newInOrbit = True}) =
err $ "enterOrbit: Cannot enterOrbit twice in a row: " ++ show tag
alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)
alterOrbits x = let items = map alterOrbit x
in (\pos m -> foldl (flip ($)) m (map ($ pos) items))
alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)
alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = True}) =
(\_ m -> IMap.insert tag (Orbits {inOrbit = inOrbit', getOrbits = mempty}) m)
alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = False}) =
(\pos m -> IMap.insertWithKey (updateOrbit pos) tag newOrbit m) where
newOrbit = Orbits {inOrbit = inOrbit', getOrbits = mempty}
updateOrbit pos _tag new old =
let answer = case old of
Orbits True prev -> Orbits {inOrbit = inOrbit', getOrbits = prev |> pos }
Orbits False _ -> new
in answer
alterOrbit (tag,AlterReset) = (\_ m -> IMap.delete tag m)
alterOrbit (tag,AlterLeave) = (\_ m ->
let old = IMap.lookup tag m
answer = case old of
Nothing -> m
Just x -> IMap.insert tag (escapeOrbit x) m
in answer)
where escapeOrbit x = x {inOrbit = False}
assemble :: TagList -> CompileInstructions ()
assemble spec = sequence_ . map helper $ spec where
helper (tag,command) =
case command of
PreUpdate TagTask -> setPreTag tag
PreUpdate ResetGroupStopTask -> resetTag tag
PreUpdate ResetOrbitTask -> resetOrbit tag
PreUpdate EnterOrbitTask -> enterOrbit tag
PreUpdate LeaveOrbitTask -> leaveOrbit tag
PostUpdate TagTask -> setPostTag tag
PostUpdate ResetGroupStopTask -> resetTag tag
_ -> err ("assemble : Weird orbit command: "++show (tag,spec))
toInstructions :: TagList -> Instructions
toInstructions spec =
let todo = assemble spec
initalState = (mempty,mempty,mempty)
(a,b,c) = execState todo initalState
in Instructions {newPos = IMap.toList a
,newFlags = IMap.toList b
,newOrbits = if IMap.null c then Nothing else Just $ alterOrbits (IMap.toList c)}
tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST aGroups (WScratch {w_pos=pRef,w_flag=fRef})= do
let b_max = snd (bounds (aGroups))
ma <- newArray (0,b_max) (1,0) :: ST s (STArray s Int (MatchOffset,MatchLength))
p <- readSTRef pRef
f <- readSTRef fRef
startPos0 <- unsafeRead p 0
stopPos0 <- unsafeRead p 1
unsafeWrite ma 0 (startPos0,stopPos0startPos0)
let act _this_index [] = return ()
act this_index ((GroupInfo _ parent start stop):gs) = do
flagVal <- unsafeRead f stop
if not flagVal then act this_index gs
else do
startPos <- unsafeRead p start
stopPos <- unsafeRead p stop
(startParent,lengthParent) <- unsafeRead ma parent
let ok = (0 <= startParent &&
0 <= lengthParent &&
startParent <= startPos &&
stopPos <= startPos + lengthParent)
if not ok then act this_index gs
else unsafeWrite ma this_index (startPos,stopPosstartPos)
forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i))
unsafeFreeze ma
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "memcpy"
memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()
copySTU :: (Show i,Ix i,MArray (STUArray s) e (ST s)) => STUArray s i e -> STUArray s i e -> ST s ()
copySTU (STUArray _ _ _ msource) (STUArray _ _ _ mdest) =
ST $ \s1# ->
case sizeofMutableByteArray# msource of { n# ->
case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->
(# s2#, () #) }}
#else /* !__GLASGOW_HASKELL__ */
copySTU :: (MArray (STUArray s) e (ST s))=> STUArray s Tag e -> STUArray s Tag e -> ST s ()
copySTU source destination = do
b@(start,stop) <- getBounds source
b' <- getBounds destination
when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b'))
forM_ (range b) $ \index ->
unsafeRead source index >>= unsafeWrite destination index
#endif /* !__GLASGOW_HASKELL__ */