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

-- import Debug.Trace

-- trace :: String -> a -> a
-- trace _ a = a

err :: String -> a
err :: String -> a
err String
s = String -> String -> a
forall a. String -> String -> a
common_error String
"Text.Regex.TDFA.NewDFA.Engine_NC"  String
s

{-# INLINE (!!) #-}
(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e
!! :: 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 :: 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 :: 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 -- force vals before defining valsRest
                    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 :: 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 (String -> ST s [MatchArray]
forall a. String -> a
err String
"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   -- perhaps a non-empty winner
              high :: Int
high = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vals  -- perhaps an empty winner
          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 {- check for additional empty winner -}
                                  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
               -- offset == low == minimum vals == maximum vals == high; vals == [offset]
               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)

    -- goNext then ends with the next statement
    MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
forall i (a :: * -> * -> *).
(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 :: 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

----

{- MUTABLE WINNER QUEUE -}

data MQ s = MQ { MQ s -> STRef s Int
mq_earliest :: !(STRef s Position)
               , MQ s -> STRef s [WScratch]
mq_list :: !(STRef s [WScratch])
               }

newMQ :: S.ST s (MQ s)
newMQ :: 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 :: 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 :: 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 :: 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

{- MUTABLE SCRATCH DATA STRUCTURES -}

data SScratch s = SScratch { SScratch s -> MScratch s
_s_1 :: !(MScratch s)
                           , SScratch s -> MScratch s
_s_2 :: !(MScratch 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 -> String
(Int -> WScratch -> ShowS)
-> (WScratch -> String) -> ([WScratch] -> ShowS) -> Show WScratch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WScratch] -> ShowS
$cshowList :: [WScratch] -> ShowS
show :: WScratch -> String
$cshow :: WScratch -> String
showsPrec :: Int -> WScratch -> ShowS
$cshowsPrec :: Int -> WScratch -> ShowS
Show

{- DEBUGGING HELPERS -}
{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -}

{-# INLINE newA #-}
newA :: (MArray (STUArray s) e (S.ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e)
newA :: (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 :: (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 :: (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index = (Int, Int) -> Int -> ST s (MScratch s)
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)

{- CONVERT WINNERS TO MATCHARRAY -}

wsToGroup :: WScratch -> S.ST s MatchArray
wsToGroup :: 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