module Text.Regex.TDFA.NewDFA.Engine_NC(execMatch) where
import Control.Monad(when,join,filterM)
import Data.Array.Base(unsafeRead,unsafeWrite)
import Prelude hiding ((!!))
import Data.Array.MArray(MArray(..))
import Data.Array.Unsafe(unsafeFreeze)
import Data.Array.IArray(Ix)
import Data.Array.ST(STArray,STUArray)
import qualified Data.IntMap.CharMap2 as CMap(findWithDefault)
import qualified Data.IntMap as IMap(null,toList,keys,member)
import qualified Data.IntSet as ISet(toAscList)
import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef)
import qualified Control.Monad.ST.Lazy as L(runST,strictToLazyST)
import qualified Control.Monad.ST.Strict as S(ST)
import Data.Sequence(Seq)
import qualified Data.ByteString.Char8 as SBS(ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)
import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)
import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc)
import Text.Regex.TDFA.Common hiding (indent)
import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons))
import Text.Regex.TDFA.NewDFA.MakeTest(test_singleline,test_multiline)
err :: String -> a
err :: forall a. [Char] -> a
err [Char]
s = [Char] -> [Char] -> a
forall a. [Char] -> [Char] -> a
common_error [Char]
"Text.Regex.TDFA.NewDFA.Engine_NC" [Char]
s
{-# INLINE (!!) #-}
(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e
!! :: forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
(!!) = a i e -> Int -> ST s e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead
{-# INLINE set #-}
set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s ()
set :: forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set = a i e -> Int -> e -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
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 :: forall text.
Uncons text =>
Regex -> Int -> Char -> text -> [MatchArray]
execMatch (Regex { regex_dfa :: Regex -> DFA
regex_dfa = (DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
didIn,d_dt :: DFA -> DT
d_dt=DT
dtIn})
, regex_init :: Regex -> Int
regex_init = Int
startState
, regex_b_index :: Regex -> (Int, Int)
regex_b_index = (Int, Int)
b_index
, regex_trie :: Regex -> TrieSet DFA
regex_trie = TrieSet DFA
trie
, regex_compOptions :: Regex -> CompOption
regex_compOptions = CompOption { multiline :: CompOption -> Bool
multiline = Bool
newline } } )
Int
offsetIn Char
prevIn text
inputIn = (forall s. ST s [MatchArray]) -> [MatchArray]
forall a. (forall s. ST s a) -> a
L.runST forall s. ST s [MatchArray]
runCaptureGroup where
!test :: WhichTest -> Int -> Char -> text -> Bool
test = Bool -> WhichTest -> Int -> Char -> text -> Bool
forall text.
Uncons text =>
Bool -> WhichTest -> Int -> Char -> text -> Bool
mkTest Bool
newline
runCaptureGroup :: ST s [MatchArray]
runCaptureGroup = {-# SCC "runCaptureGroup" #-} do
ST s [MatchArray]
obtainNext <- ST s (ST s [MatchArray]) -> ST s (ST s [MatchArray])
forall s a. ST s a -> ST s a
L.strictToLazyST ST s (ST s [MatchArray])
forall s. ST s (ST s [MatchArray])
constructNewEngine
let loop :: ST s [MatchArray]
loop = do [MatchArray]
vals <- ST s [MatchArray] -> ST s [MatchArray]
forall s a. ST s a -> ST s a
L.strictToLazyST ST s [MatchArray]
obtainNext
if [MatchArray] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MatchArray]
vals
then [MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do [MatchArray]
valsRest <- ST s [MatchArray]
loop
[MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MatchArray]
vals [MatchArray] -> [MatchArray] -> [MatchArray]
forall a. [a] -> [a] -> [a]
++ [MatchArray]
valsRest)
ST s [MatchArray]
loop
constructNewEngine :: S.ST s (S.ST s [MatchArray])
constructNewEngine :: forall s. ST s (ST s [MatchArray])
constructNewEngine = {-# SCC "constructNewEngine" #-} do
STRef s (ST s [MatchArray])
storeNext <- ST s [MatchArray] -> ST s (STRef s (ST s [MatchArray]))
forall a s. a -> ST s (STRef s a)
newSTRef ST s [MatchArray]
forall a. HasCallStack => a
undefined
STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (STRef s (ST s [MatchArray]) -> ST s [MatchArray]
forall {s}. STRef s (ST s [MatchArray]) -> ST s [MatchArray]
goNext STRef s (ST s [MatchArray])
storeNext)
let obtainNext :: ST s [MatchArray]
obtainNext = ST s (ST s [MatchArray]) -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (STRef s (ST s [MatchArray]) -> ST s (ST s [MatchArray])
forall s a. STRef s a -> ST s a
readSTRef STRef s (ST s [MatchArray])
storeNext)
ST s [MatchArray] -> ST s (ST s [MatchArray])
forall (m :: * -> *) a. Monad m => a -> m a
return ST s [MatchArray]
obtainNext
goNext :: STRef s (ST s [MatchArray]) -> ST s [MatchArray]
goNext STRef s (ST s [MatchArray])
storeNext = {-# SCC "goNext" #-} do
(SScratch MScratch s
s1In MScratch s
s2In MQ s
winQ) <- (Int, Int) -> ST s (SScratch s)
forall s. (Int, Int) -> ST s (SScratch s)
newScratch (Int, Int)
b_index
MScratch s -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set MScratch s
s1In Int
startState Int
offsetIn
STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext ([Char] -> ST s [MatchArray]
forall a. [Char] -> a
err [Char]
"obtainNext called while goNext is running!")
STRef s Bool
eliminatedStateFlag <- Bool -> ST s (STRef s Bool)
forall a s. a -> ST s (STRef s a)
newSTRef Bool
False
let next :: a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next a i Int
s1 a i Int
s2 SetIndex
did DT
dt Int
offset Char
prev text
input = {-# SCC "goNext.next" #-}
case DT
dt of
Testing' {dt_test :: DT -> WhichTest
dt_test=WhichTest
wt,dt_a :: DT -> DT
dt_a=DT
a,dt_b :: DT -> DT
dt_b=DT
b} ->
if WhichTest -> Int -> Char -> text -> Bool
test WhichTest
wt Int
offset Char
prev text
input
then a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next a i Int
s1 a i Int
s2 SetIndex
did DT
a Int
offset Char
prev text
input
else a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next a i Int
s1 a i Int
s2 SetIndex
did DT
b Int
offset Char
prev text
input
Simple' {dt_win :: DT -> IntMap Instructions
dt_win=IntMap Instructions
w,dt_trans :: DT -> CharMap Transition
dt_trans=CharMap Transition
t, dt_other :: DT -> Transition
dt_other=Transition
o}
| IntMap Instructions -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap Instructions
w ->
case text -> Maybe (Char, text)
forall a. Uncons a => a -> Maybe (Char, a)
uncons text
input of
Maybe (Char, text)
Nothing -> ST s [MatchArray]
finalizeWinners
Just (Char
c,text
input') -> do
case Transition -> Char -> CharMap Transition -> Transition
forall a. a -> Char -> CharMap a -> a
CMap.findWithDefault Transition
o Char
c CharMap Transition
t of
Transition {trans_many :: Transition -> DFA
trans_many=DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'},trans_how :: Transition -> DTrans
trans_how=DTrans
dtrans} ->
a i Int
-> a i Int
-> SetIndex
-> DT
-> DTrans
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans a i Int
s1 a i Int
s2 SetIndex
did' DT
dt' DTrans
dtrans Int
offset Char
c text
input'
| Bool
otherwise -> do
(SetIndex
did',DT
dt') <- a i Int
-> SetIndex
-> DT
-> IntMap Instructions
-> Int
-> ST s (SetIndex, DT)
forall {a :: * -> * -> *} {i} {a}.
(MArray a Int (ST s), Ix i) =>
a i Int -> SetIndex -> DT -> IntMap a -> Int -> ST s (SetIndex, DT)
processWinner a i Int
s1 SetIndex
did DT
dt IntMap Instructions
w Int
offset
a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' a i Int
s1 a i Int
s2 SetIndex
did' DT
dt' Int
offset Char
prev text
input
next' :: a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' a i Int
s1 a i Int
s2 SetIndex
did DT
dt Int
offset Char
prev text
input = {-# SCC "goNext'.next" #-}
case DT
dt of
Testing' {dt_test :: DT -> WhichTest
dt_test=WhichTest
wt,dt_a :: DT -> DT
dt_a=DT
a,dt_b :: DT -> DT
dt_b=DT
b} ->
if WhichTest -> Int -> Char -> text -> Bool
test WhichTest
wt Int
offset Char
prev text
input
then a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' a i Int
s1 a i Int
s2 SetIndex
did DT
a Int
offset Char
prev text
input
else a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' a i Int
s1 a i Int
s2 SetIndex
did DT
b Int
offset Char
prev text
input
Simple' {dt_trans :: DT -> CharMap Transition
dt_trans=CharMap Transition
t, dt_other :: DT -> Transition
dt_other=Transition
o} ->
case text -> Maybe (Char, text)
forall a. Uncons a => a -> Maybe (Char, a)
uncons text
input of
Maybe (Char, text)
Nothing -> ST s [MatchArray]
finalizeWinners
Just (Char
c,text
input') -> do
case Transition -> Char -> CharMap Transition -> Transition
forall a. a -> Char -> CharMap a -> a
CMap.findWithDefault Transition
o Char
c CharMap Transition
t of
Transition {trans_many :: Transition -> DFA
trans_many=DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'},trans_how :: Transition -> DTrans
trans_how=DTrans
dtrans} ->
a i Int
-> a i Int
-> SetIndex
-> DT
-> DTrans
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans a i Int
s1 a i Int
s2 SetIndex
did' DT
dt' DTrans
dtrans Int
offset Char
c text
input'
findTrans :: a i Int
-> a i Int
-> SetIndex
-> DT
-> DTrans
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans a i Int
s1 a i Int
s2 SetIndex
did' DT
dt' DTrans
dtrans Int
offset Char
prev' text
input' = {-# SCC "goNext.findTrans" #-} do
let findTransTo :: (Int, IntMap a) -> ST s Int
findTransTo (Int
destIndex,IntMap a
sources) = do
Int
val <- if IntMap a -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap a
sources then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int
forall a. Enum a => a -> a
succ Int
offset)
else Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> ([Int] -> Int) -> [Int] -> ST s Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> ST s Int) -> ST s [Int] -> ST s Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int -> ST s Int) -> [Int] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (a i Int
s1 a i Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!!) (IntMap a -> [Int]
forall a. IntMap a -> [Int]
IMap.keys IntMap a
sources)
a i Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set a i Int
s2 Int
destIndex Int
val
Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
val
Int
earlyStart <- ([Int] -> Int) -> ST s [Int] -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (ST s [Int] -> ST s Int) -> ST s [Int] -> ST s Int
forall a b. (a -> b) -> a -> b
$ ((Int, IntMap (DoPa, Instructions)) -> ST s Int)
-> [(Int, IntMap (DoPa, Instructions))] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, IntMap (DoPa, Instructions)) -> ST s Int
forall {s} {a}.
(MArray a Int (ST s), MArray a Int (ST s)) =>
(Int, IntMap a) -> ST s Int
findTransTo (DTrans -> [(Int, IntMap (DoPa, Instructions))]
forall a. IntMap a -> [(Int, a)]
IMap.toList DTrans
dtrans)
Int
earlyWin <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (MQ s -> STRef s Int
forall s. MQ s -> STRef s Int
mq_earliest MQ s
winQ)
if Int
earlyWin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
earlyStart
then do
[WScratch]
winnersR <- Int -> MQ s -> ST s [WScratch]
forall s. Int -> MQ s -> ST s [WScratch]
getMQ Int
earlyStart MQ s
winQ
STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next a i Int
s2 a i Int
s1 SetIndex
did' DT
dt' (Int -> Int
forall a. Enum a => a -> a
succ Int
offset) Char
prev' text
input')
(WScratch -> ST s MatchArray) -> [WScratch] -> ST s [MatchArray]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WScratch -> ST s MatchArray
forall s. WScratch -> ST s MatchArray
wsToGroup ([WScratch] -> [WScratch]
forall a. [a] -> [a]
reverse [WScratch]
winnersR)
else do
let offset' :: Int
offset' = Int -> Int
forall a. Enum a => a -> a
succ Int
offset in Int -> ST s [MatchArray] -> ST s [MatchArray]
seq Int
offset' (ST s [MatchArray] -> ST s [MatchArray])
-> ST s [MatchArray] -> ST s [MatchArray]
forall a b. (a -> b) -> a -> b
$ a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next a i Int
s2 a i Int
s1 SetIndex
did' DT
dt' Int
offset' Char
prev' text
input'
processWinner :: a i Int -> SetIndex -> DT -> IntMap a -> Int -> ST s (SetIndex, DT)
processWinner a i Int
s1 SetIndex
did DT
dt IntMap a
w Int
offset = {-# SCC "goNext.newWinnerThenProceed" #-} do
let getStart :: (Int, b) -> ST s Int
getStart (Int
sourceIndex,b
_) = a i Int
s1 a i Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
sourceIndex
[Int]
vals <- ((Int, a) -> ST s Int) -> [(Int, a)] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> ST s Int
forall {s} {b}. MArray a Int (ST s) => (Int, b) -> ST s Int
getStart (IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IMap.toList IntMap a
w)
let low :: Int
low = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
vals
high :: Int
high = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vals
if Int
low Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
offset
then do
WScratch -> MQ s -> ST s ()
forall s. WScratch -> MQ s -> ST s ()
putMQ (Int -> Int -> WScratch
WScratch Int
low Int
offset) MQ s
winQ
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
highInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
offset Bool -> Bool -> Bool
|| Int -> IntMap a -> Bool
forall a. Int -> IntMap a -> Bool
IMap.member Int
startState IntMap a
w) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
WScratch -> MQ s -> ST s ()
forall s. WScratch -> MQ s -> ST s ()
putMQ (Int -> Int -> WScratch
WScratch Int
offset Int
offset) MQ s
winQ
let keepState :: Int -> ST s Bool
keepState Int
i1 = do
Int
startsAt <- a i Int
s1 a i Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
i1
let keep :: Bool
keep = (Int
startsAt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
low) Bool -> Bool -> Bool
|| (Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startsAt)
if Bool
keep
then Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else if Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startState
then
a i Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set a i Int
s1 Int
i1 (Int -> Int
forall a. Enum a => a -> a
succ Int
offset) ST s () -> ST s Bool -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedStateFlag Bool
True ST s () -> ST s Bool -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[Int]
states' <- (Int -> ST s Bool) -> [Int] -> ST s [Int]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Int -> ST s Bool
keepState (SetIndex -> [Int]
ISet.toAscList SetIndex
did)
Bool
flag <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
eliminatedStateFlag
if Bool
flag
then do
STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedStateFlag Bool
False
let DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'} = TrieSet DFA -> [Int] -> DFA
forall v. TrieSet v -> [Int] -> v
Trie.lookupAsc TrieSet DFA
trie [Int]
states'
(SetIndex, DT) -> ST s (SetIndex, DT)
forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did',DT
dt')
else do
(SetIndex, DT) -> ST s (SetIndex, DT)
forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did,DT
dt)
else do
WScratch -> MQ s -> ST s ()
forall s. WScratch -> MQ s -> ST s ()
putMQ (Int -> Int -> WScratch
WScratch Int
offset Int
offset) MQ s
winQ
(SetIndex, DT) -> ST s (SetIndex, DT)
forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did,DT
dt)
finalizeWinners :: ST s [MatchArray]
finalizeWinners = do
[WScratch]
winnersR <- STRef s [WScratch] -> ST s [WScratch]
forall s a. STRef s a -> ST s a
readSTRef (MQ s -> STRef s [WScratch]
forall s. MQ s -> STRef s [WScratch]
mq_list MQ s
winQ)
MQ s -> ST s ()
forall s. MQ s -> ST s ()
resetMQ MQ s
winQ
STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext ([MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
(WScratch -> ST s MatchArray) -> [WScratch] -> ST s [MatchArray]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WScratch -> ST s MatchArray
forall s. WScratch -> ST s MatchArray
wsToGroup ([WScratch] -> [WScratch]
forall a. [a] -> [a]
reverse [WScratch]
winnersR)
MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
forall {a :: * -> * -> *} {i}.
(MArray a Int (ST s), Ix i) =>
a i Int
-> a i Int
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1In MScratch s
s2In SetIndex
didIn DT
dtIn Int
offsetIn Char
prevIn text
inputIn
{-# INLINE mkTest #-}
mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool
mkTest :: forall text.
Uncons text =>
Bool -> WhichTest -> Int -> Char -> text -> Bool
mkTest Bool
isMultiline = if Bool
isMultiline then WhichTest -> Int -> Char -> text -> Bool
forall text.
Uncons text =>
WhichTest -> Int -> Char -> text -> Bool
test_multiline else WhichTest -> Int -> Char -> text -> Bool
forall text.
Uncons text =>
WhichTest -> Int -> Char -> text -> Bool
test_singleline
data MQ s = MQ { forall s. MQ s -> STRef s Int
mq_earliest :: !(STRef s Position)
, forall s. MQ s -> STRef s [WScratch]
mq_list :: !(STRef s [WScratch])
}
newMQ :: S.ST s (MQ s)
newMQ :: forall s. ST s (MQ s)
newMQ = do
STRef s Int
earliest <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
forall a. Bounded a => a
maxBound
STRef s [WScratch]
list <- [WScratch] -> ST s (STRef s [WScratch])
forall a s. a -> ST s (STRef s a)
newSTRef []
MQ s -> ST s (MQ s)
forall (m :: * -> *) a. Monad m => a -> m a
return (STRef s Int -> STRef s [WScratch] -> MQ s
forall s. STRef s Int -> STRef s [WScratch] -> MQ s
MQ STRef s Int
earliest STRef s [WScratch]
list)
resetMQ :: MQ s -> S.ST s ()
resetMQ :: forall s. MQ s -> ST s ()
resetMQ (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
earliest,mq_list :: forall s. MQ s -> STRef s [WScratch]
mq_list=STRef s [WScratch]
list}) = do
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
forall a. Bounded a => a
maxBound
STRef s [WScratch] -> [WScratch] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list []
putMQ :: WScratch -> MQ s -> S.ST s ()
putMQ :: forall s. WScratch -> MQ s -> ST s ()
putMQ ws :: WScratch
ws@(WScratch {ws_start :: WScratch -> Int
ws_start=Int
start}) (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
earliest,mq_list :: forall s. MQ s -> STRef s [WScratch]
mq_list=STRef s [WScratch]
list}) = do
Int
startE <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
earliest
if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startE
then STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
start ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STRef s [WScratch] -> [WScratch] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list [WScratch
ws]
else do
[WScratch]
old <- STRef s [WScratch] -> ST s [WScratch]
forall s a. STRef s a -> ST s a
readSTRef STRef s [WScratch]
list
let !rest :: [WScratch]
rest = (WScratch -> Bool) -> [WScratch] -> [WScratch]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ WScratch
w -> Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= WScratch -> Int
ws_start WScratch
w) [WScratch]
old
!new :: [WScratch]
new = WScratch
ws WScratch -> [WScratch] -> [WScratch]
forall a. a -> [a] -> [a]
: [WScratch]
rest
STRef s [WScratch] -> [WScratch] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list [WScratch]
new
getMQ :: Position -> MQ s -> S.ST s [WScratch]
getMQ :: forall s. Int -> MQ s -> ST s [WScratch]
getMQ Int
pos (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
earliest,mq_list :: forall s. MQ s -> STRef s [WScratch]
mq_list=STRef s [WScratch]
list}) = do
[WScratch]
old <- STRef s [WScratch] -> ST s [WScratch]
forall s a. STRef s a -> ST s a
readSTRef STRef s [WScratch]
list
case (WScratch -> Bool) -> [WScratch] -> ([WScratch], [WScratch])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ WScratch
w -> Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= WScratch -> Int
ws_start WScratch
w) [WScratch]
old of
([],[WScratch]
ans) -> do
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
forall a. Bounded a => a
maxBound
STRef s [WScratch] -> [WScratch] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list []
[WScratch] -> ST s [WScratch]
forall (m :: * -> *) a. Monad m => a -> m a
return [WScratch]
ans
([WScratch]
new,[WScratch]
ans) -> do
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest (WScratch -> Int
ws_start ([WScratch] -> WScratch
forall a. [a] -> a
last [WScratch]
new))
STRef s [WScratch] -> [WScratch] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list [WScratch]
new
[WScratch] -> ST s [WScratch]
forall (m :: * -> *) a. Monad m => a -> m a
return [WScratch]
ans
data SScratch s = SScratch { forall s. SScratch s -> MScratch s
_s_1 :: !(MScratch s)
, forall s. SScratch s -> MScratch s
_s_2 :: !(MScratch s)
, forall s. SScratch s -> MQ s
_s_mq :: !(MQ s)
}
type MScratch s = STUArray s Index Position
data WScratch = WScratch {WScratch -> Int
ws_start,WScratch -> Int
_ws_stop :: !Position}
deriving Int -> WScratch -> ShowS
[WScratch] -> ShowS
WScratch -> [Char]
(Int -> WScratch -> ShowS)
-> (WScratch -> [Char]) -> ([WScratch] -> ShowS) -> Show WScratch
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WScratch] -> ShowS
$cshowList :: [WScratch] -> ShowS
show :: WScratch -> [Char]
$cshow :: WScratch -> [Char]
showsPrec :: Int -> WScratch -> ShowS
$cshowsPrec :: Int -> WScratch -> ShowS
Show
{-# INLINE newA #-}
newA :: (MArray (STUArray s) e (S.ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e)
newA :: forall s e.
MArray (STUArray s) e (ST s) =>
(Int, Int) -> e -> ST s (STUArray s Int e)
newA (Int, Int)
b_tags e
initial = (Int, Int) -> e -> ST s (STUArray s Int e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int, Int)
b_tags e
initial
newScratch :: (Index,Index) -> S.ST s (SScratch s)
newScratch :: forall s. (Int, Int) -> ST s (SScratch s)
newScratch (Int, Int)
b_index = do
MScratch s
s1 <- (Int, Int) -> ST s (MScratch s)
forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
MScratch s
s2 <- (Int, Int) -> ST s (MScratch s)
forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
MQ s
winQ <- ST s (MQ s)
forall s. ST s (MQ s)
newMQ
SScratch s -> ST s (SScratch s)
forall (m :: * -> *) a. Monad m => a -> m a
return (MScratch s -> MScratch s -> MQ s -> SScratch s
forall s. MScratch s -> MScratch s -> MQ s -> SScratch s
SScratch MScratch s
s1 MScratch s
s2 MQ s
winQ)
newMScratch :: (Index,Index) -> S.ST s (MScratch s)
newMScratch :: forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index = (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall s e.
MArray (STUArray s) e (ST s) =>
(Int, Int) -> e -> ST s (STUArray s Int e)
newA (Int, Int)
b_index (-Int
1)
wsToGroup :: WScratch -> S.ST s MatchArray
wsToGroup :: forall s. WScratch -> ST s MatchArray
wsToGroup (WScratch Int
start Int
stop) = do
STArray s Int (Int, Int)
ma <- (Int, Int) -> (Int, Int) -> ST s (STArray s Int (Int, Int))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
0) (Int
start,Int
stopInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
start) :: S.ST s (STArray s Int (MatchOffset,MatchLength))
STArray s Int (Int, Int) -> ST s MatchArray
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze STArray s Int (Int, Int)
ma