-- | 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 :: forall a. [Char] -> a
err [Char]
s = 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
(!!) = 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 = 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 a. (forall s. ST s a) -> a
L.runST forall {s}. ST s [MatchArray]
runCaptureGroup where

  !test :: WhichTest -> Int -> Char -> text -> Bool
test = 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 <- forall s a. ST s a -> ST s a
L.strictToLazyST forall s. ST s (ST s [MatchArray])
constructNewEngine
    let loop :: ST s [MatchArray]
loop = do [MatchArray]
vals <- forall s a. ST s a -> ST s a
L.strictToLazyST ST s [MatchArray]
obtainNext
                  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MatchArray]
vals -- force vals before defining valsRest
                    then forall (m :: * -> *) a. Monad m => a -> m a
return []
                    else do [MatchArray]
valsRest <- ST s [MatchArray]
loop
                            forall (m :: * -> *) a. Monad m => a -> m a
return ([MatchArray]
vals 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 <- forall a s. a -> ST s (STRef s a)
newSTRef forall a. HasCallStack => a
undefined
    forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (forall {s}. STRef s (ST s [MatchArray]) -> ST s [MatchArray]
goNext STRef s (ST s [MatchArray])
storeNext)
    let obtainNext :: ST s [MatchArray]
obtainNext = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall s a. STRef s a -> ST s a
readSTRef STRef s (ST s [MatchArray])
storeNext)
    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) <- forall s. (Int, Int) -> ST s (SScratch s)
newScratch (Int, Int)
b_index
    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
    forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (forall a. [Char] -> a
err [Char]
"obtainNext called while goNext is running!")
    STRef s Bool
eliminatedStateFlag <- 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}
              | forall a. IntMap a -> Bool
IMap.null IntMap Instructions
w ->
                  case 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 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') <- 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 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 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 forall a. IntMap a -> Bool
IMap.null IntMap a
sources then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => a -> a
succ Int
offset)
                         else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (a i Int
s1 forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!!) (forall a. IntMap a -> [Int]
IMap.keys IntMap a
sources)
                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
                forall (m :: * -> *) a. Monad m => a -> m a
return Int
val
          Int
earlyStart <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {s} {a}.
(MArray a Int (ST s), MArray a Int (ST s)) =>
(Int, IntMap a) -> ST s Int
findTransTo (forall a. IntMap a -> [(Int, a)]
IMap.toList DTrans
dtrans)
          --
          Int
earlyWin <- forall s a. STRef s a -> ST s a
readSTRef (forall s. MQ s -> STRef s Int
mq_earliest MQ s
winQ)
          if Int
earlyWin forall a. Ord a => a -> a -> Bool
< Int
earlyStart
            then do
              [WScratch]
winnersR <- forall s. Int -> MQ s -> ST s [WScratch]
getMQ Int
earlyStart MQ s
winQ
              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' (forall a. Enum a => a -> a
succ Int
offset) Char
prev' text
input')
              forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. WScratch -> ST s MatchArray
wsToGroup (forall a. [a] -> [a]
reverse [WScratch]
winnersR)
            else do
              let offset' :: Int
offset' = forall a. Enum a => a -> a
succ Int
offset in seq :: forall a b. a -> b -> b
seq Int
offset' 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 forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
sourceIndex
          [Int]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {s} {b}. MArray a Int (ST s) => (Int, b) -> ST s Int
getStart (forall a. IntMap a -> [(Int, a)]
IMap.toList IntMap a
w)
          let low :: Int
low = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
vals   -- perhaps a non-empty winner
              high :: Int
high = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vals  -- perhaps an empty winner
          if Int
low forall a. Ord a => a -> a -> Bool
< Int
offset
            then do
              forall s. WScratch -> MQ s -> ST s ()
putMQ (Int -> Int -> WScratch
WScratch Int
low Int
offset) MQ s
winQ
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
highforall a. Eq a => a -> a -> Bool
==Int
offset Bool -> Bool -> Bool
|| forall a. Int -> IntMap a -> Bool
IMap.member Int
startState IntMap a
w) forall a b. (a -> b) -> a -> b
$
                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 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 forall a. Ord a => a -> a -> Bool
<= Int
low) Bool -> Bool -> Bool
|| (Int
offset forall a. Ord a => a -> a -> Bool
<= Int
startsAt)
                    if Bool
keep
                      then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                      else if Int
i1 forall a. Eq a => a -> a -> Bool
== Int
startState
                             then {- check for additional empty winner -}
                                  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 (forall a. Enum a => a -> a
succ Int
offset) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                             else forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedStateFlag Bool
True forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              [Int]
states' <- 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 <- forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
eliminatedStateFlag
              if Bool
flag
                then do
                  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'} = forall v. TrieSet v -> [Int] -> v
Trie.lookupAsc TrieSet DFA
trie [Int]
states'
                  forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did',DT
dt')
                else do
                  forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did,DT
dt)
            else do
               -- offset == low == minimum vals == maximum vals == high; vals == [offset]
               forall s. WScratch -> MQ s -> ST s ()
putMQ (Int -> Int -> WScratch
WScratch Int
offset Int
offset) MQ s
winQ
               forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did,DT
dt)

        finalizeWinners :: ST s [MatchArray]
finalizeWinners = do
          [WScratch]
winnersR <- forall s a. STRef s a -> ST s a
readSTRef (forall s. MQ s -> STRef s [WScratch]
mq_list MQ s
winQ)
          forall s. MQ s -> ST s ()
resetMQ MQ s
winQ
          forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (forall (m :: * -> *) a. Monad m => a -> m a
return [])
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. WScratch -> ST s MatchArray
wsToGroup (forall a. [a] -> [a]
reverse [WScratch]
winnersR)

    -- goNext then ends with the next statement
    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 forall text.
Uncons text =>
WhichTest -> Int -> Char -> text -> Bool
test_multiline else forall text.
Uncons text =>
WhichTest -> Int -> Char -> text -> Bool
test_singleline

----

{- MUTABLE WINNER QUEUE -}

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 <- forall a s. a -> ST s (STRef s a)
newSTRef forall a. Bounded a => a
maxBound
  STRef s [WScratch]
list <- forall a s. a -> ST s (STRef s a)
newSTRef []
  forall (m :: * -> *) a. Monad m => a -> m a
return (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
  forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest forall a. Bounded a => a
maxBound
  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 <- forall s a. STRef s a -> ST s a
readSTRef STRef s Int
earliest
  if Int
start forall a. Ord a => a -> a -> Bool
<= Int
startE
    then forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
start forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list [WScratch
ws]
    else do
      [WScratch]
old <- forall s a. STRef s a -> ST s a
readSTRef STRef s [WScratch]
list
      let !rest :: [WScratch]
rest = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ WScratch
w -> Int
start forall a. Ord a => a -> a -> Bool
<= WScratch -> Int
ws_start WScratch
w) [WScratch]
old
          !new :: [WScratch]
new = WScratch
ws forall a. a -> [a] -> [a]
: [WScratch]
rest
      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 <- forall s a. STRef s a -> ST s a
readSTRef STRef s [WScratch]
list
  case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ WScratch
w -> Int
pos forall a. Ord a => a -> a -> Bool
<= WScratch -> Int
ws_start WScratch
w) [WScratch]
old of
    ([],[WScratch]
ans) -> do
      forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest forall a. Bounded a => a
maxBound
      forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list []
      forall (m :: * -> *) a. Monad m => a -> m a
return [WScratch]
ans
    ([WScratch]
new,[WScratch]
ans) -> do
      forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest (WScratch -> Int
ws_start (forall a. [a] -> a
last [WScratch]
new))
      forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [WScratch]
list [WScratch]
new
      forall (m :: * -> *) a. Monad m => a -> m a
return [WScratch]
ans

{- MUTABLE SCRATCH DATA STRUCTURES -}

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

{- 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 :: 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 = 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 <- forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
  MScratch s
s2 <- forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
  MQ s
winQ <- forall s. ST s (MQ s)
newMQ
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 = 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 :: forall s. WScratch -> ST s MatchArray
wsToGroup (WScratch Int
start Int
stop) = do
  STArray s Int (Int, Int)
ma <- 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
stopforall a. Num a => a -> a -> a
-Int
start)  :: S.ST s (STArray s Int (MatchOffset,MatchLength))
  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