-- XXX design uncertainty:  should preResets be inserted into nullView?
-- if not, why not? ADDED

-- XXX design uncertainty: what does act -> actNullable ->
-- actNullableTagless not use nullQ and same for inStar, etc?
-- TODO : try rewriting whole qToNFA in terms of "act"
-- (That will require re-organizing the continuation data a bit)

-- | "Text.Regex.TDFA.TNFA" converts the CorePattern Q\/P data (and its
-- Pattern leafs) to a QNFA tagged non-deterministic finite automata.
--
-- This holds every possible way to follow one state by another, while
-- in the DFA these will be reduced by picking a single best
-- transition for each (source,destination) pair.  The transitions are
-- heavily and often redundantly annotated with tasks to perform, and
-- this redundancy is reduced when picking the best transition.  So
-- far, keeping all this information has helped fix bugs in both the
-- design and implementation.
--
-- The QNFA for a Pattern with a starTraned Q\/P form with N one
-- character accepting leaves has at most N+1 nodes.  These nodes
-- represent the future choices after accepting a leaf.  The processing
-- of Or nodes often reduces this number by sharing at the end of the
-- different paths.  Turning off capturing while compiling the pattern
-- may (future extension) reduce this further for some patterns by
-- processing Star with optimizations.  This compact design also means
-- that tags are assigned not just to be updated before taking a
-- transition (PreUpdate) but also after the transition (PostUpdate).
--
-- Uses recursive do notation.

module Text.Regex.TDFA.TNFA(patternToNFA
                            ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where

{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}

import Control.Monad(when)
import Control.Monad.State(State,runState,execState,get,put,modify)
import Data.Array.IArray(Array,array)
import Data.Char(toLower,toUpper,isAlpha,ord)
import Data.List(foldl')
import Data.IntMap (IntMap)
import qualified Data.IntMap as IMap(toAscList,null,unionWith,singleton,fromList,fromDistinctAscList)
import Data.IntMap.CharMap2(CharMap(..))
import qualified Data.IntMap.CharMap2 as Map(null,singleton,map)
import qualified Data.IntMap.EnumMap2 as EMap(null,keysSet,assocs)
import Data.IntSet.EnumSet2(EnumSet)
import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,insert)
import Data.Maybe(catMaybes,isNothing)
import Data.Monoid as Mon(Monoid(..))
import qualified Data.Set as S(Set,insert,toAscList,empty)

import Text.Regex.TDFA.Common(QT(..),QNFA(..),QTrans,TagTask(..),TagUpdate(..),DoPa(..)
                             ,CompOption(..)
                             ,Tag,TagTasks,TagList,Index,WinTags,GroupIndex,GroupInfo(..)
                             ,common_error,noWin,snd3,mapSnd)
import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView
                                  ,SetTestInfo(..),Wanted(..),TestInfo
                                  ,mustAccept,cannotAccept,patternToQ)
import Text.Regex.TDFA.Pattern(Pattern(..),PatternSet(..),unSEC,PatternSetCharacterClass(..))
--import Debug.Trace

ecart :: String -> a -> a
ecart :: String -> a -> a
ecart String
_ = a -> a
forall a. a -> a
id

err :: String -> a
err :: String -> a
err String
t = String -> String -> a
forall a. String -> String -> a
common_error String
"Text.Regex.TDFA.TNFA" String
t

debug :: (Show a) => a -> s -> s
debug :: a -> s -> s
debug a
_ s
s = s
s

qtwin,qtlose :: QT
-- qtwin is the continuation after matching the whole pattern.  It has
-- no further transitions and sets tag #1 to the current position.
qtwin :: QT
qtwin = Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple {qt_win :: WinTags
qt_win=[(Tag
1,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)],qt_trans :: CharMap QTrans
qt_trans=CharMap QTrans
forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=QTrans
forall a. Monoid a => a
mempty}
-- qtlose is the continuation to nothing, used when ^ or $ tests fail.
qtlose :: QT
qtlose = Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple {qt_win :: WinTags
qt_win=WinTags
forall a. Monoid a => a
mempty,qt_trans :: CharMap QTrans
qt_trans=CharMap QTrans
forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=QTrans
forall a. Monoid a => a
mempty}

patternToNFA :: CompOption
             -> (Pattern,(GroupIndex, DoPa))
             -> ((Index,Array Index QNFA)
                ,Array Tag OP
                ,Array GroupIndex [GroupInfo])
patternToNFA :: CompOption
-> (Pattern, (Tag, DoPa))
-> ((Tag, Array Tag QNFA), Array Tag OP, Array Tag [GroupInfo])
patternToNFA CompOption
compOpt (Pattern, (Tag, DoPa))
pattern =
  let (Q
q,Array Tag OP
tags,Array Tag [GroupInfo]
groups) = CompOption
-> (Pattern, (Tag, DoPa))
-> (Q, Array Tag OP, Array Tag [GroupInfo])
patternToQ CompOption
compOpt (Pattern, (Tag, DoPa))
pattern
      msg :: String
msg = [String] -> String
unlines [ Q -> String
forall a. Show a => a -> String
show Q
q ]
  in String
-> ((Tag, Array Tag QNFA), Array Tag OP, Array Tag [GroupInfo])
-> ((Tag, Array Tag QNFA), Array Tag OP, Array Tag [GroupInfo])
forall a s. Show a => a -> s -> s
debug String
msg (CompOption -> Q -> (Tag, Array Tag QNFA)
qToNFA CompOption
compOpt Q
q,Array Tag OP
tags,Array Tag [GroupInfo]
groups)

-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==
-- Query function on Q

nullable :: Q -> Bool
nullable :: Q -> Bool
nullable = Bool -> Bool
not (Bool -> Bool) -> (Q -> Bool) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(SetTestInfo, WinTags)] -> Bool)
-> (Q -> [(SetTestInfo, WinTags)]) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(SetTestInfo, WinTags)]
nullQ

notNullable :: Q -> Bool
notNullable :: Q -> Bool
notNullable = [(SetTestInfo, WinTags)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(SetTestInfo, WinTags)] -> Bool)
-> (Q -> [(SetTestInfo, WinTags)]) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(SetTestInfo, WinTags)]
nullQ

-- This asks if the preferred (i.e. first) NullView has no tests.
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty (Q {nullQ :: Q -> [(SetTestInfo, WinTags)]
nullQ = ((SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags):[(SetTestInfo, WinTags)]
_)}) = if EnumMap WhichTest (EnumSet DoPa) -> Bool
forall key a. Enum key => EnumMap key a -> Bool
EMap.null EnumMap WhichTest (EnumSet DoPa)
sti then WinTags -> Maybe WinTags
forall a. a -> Maybe a
Just WinTags
tags else Maybe WinTags
forall a. Maybe a
Nothing
maybeOnlyEmpty Q
_ = Maybe WinTags
forall a. Maybe a
Nothing

usesQNFA :: Q -> Bool
usesQNFA :: Q -> Bool
usesQNFA (Q {wants :: Q -> Wanted
wants=Wanted
WantsBoth}) = Bool
True
usesQNFA (Q {wants :: Q -> Wanted
wants=Wanted
WantsQNFA}) = Bool
True
usesQNFA Q
_ = Bool
False

-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==
-- Functions related to QT

-- dumb smart constructor used by qToQNFA
-- Possible: Go through the qt and keep only the best tagged transition(s) to each state to make simple NFA?
mkQNFA :: Index -> QT -> QNFA
mkQNFA :: Tag -> QT -> QNFA
mkQNFA Tag
i QT
qt = String -> QNFA -> QNFA
forall a s. Show a => a -> s -> s
debug (String
"\n>QNFA id="String -> String -> String
forall a. [a] -> [a] -> [a]
++Tag -> String
forall a. Show a => a -> String
show Tag
i) (QNFA -> QNFA) -> QNFA -> QNFA
forall a b. (a -> b) -> a -> b
$
  Tag -> QT -> QNFA
QNFA Tag
i (String -> QT -> QT
forall a s. Show a => a -> s -> s
debug (String
"\ngetting QT for "String -> String -> String
forall a. [a] -> [a] -> [a]
++Tag -> String
forall a. Show a => a -> String
show Tag
i) QT
qt)

-- This uses the Eq QT instance above
-- ZZZ
mkTesting :: QT -> QT
mkTesting :: QT -> QT
mkTesting t :: QT
t@(Testing {qt_a :: QT -> QT
qt_a=QT
a,qt_b :: QT -> QT
qt_b=QT
b}) = if QT
aQT -> QT -> Bool
forall a. Eq a => a -> a -> Bool
==QT
b then QT
a else QT
t -- Move to nfsToDFA XXX
mkTesting QT
t = QT
t

nullQT :: QT -> Bool
nullQT :: QT -> Bool
nullQT (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) = WinTags -> Bool
noWin WinTags
w Bool -> Bool -> Bool
&& CharMap QTrans -> Bool
forall a. CharMap a -> Bool
Map.null CharMap QTrans
t Bool -> Bool -> Bool
&& QTrans -> Bool
forall a. IntMap a -> Bool
IMap.null QTrans
o
nullQT QT
_ = Bool
False

-- This reconstructs the set of tests checked in processing QT, adding
-- them to the passed set.
listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
qt EnumSet WhichTest
s = State (EnumSet WhichTest) ()
-> EnumSet WhichTest -> EnumSet WhichTest
forall s a. State s a -> s -> s
execState (QT -> State (EnumSet WhichTest) ()
forall (m :: * -> *).
MonadState (EnumSet WhichTest) m =>
QT -> m ()
helper QT
qt) EnumSet WhichTest
s
  where helper :: QT -> m ()
helper (Simple {}) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        helper (Testing {qt_test :: QT -> WhichTest
qt_test = WhichTest
wt, qt_a :: QT -> QT
qt_a = QT
a, qt_b :: QT -> QT
qt_b = QT
b}) = do
          (EnumSet WhichTest -> EnumSet WhichTest) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (WhichTest -> EnumSet WhichTest -> EnumSet WhichTest
forall e. Enum e => e -> EnumSet e -> EnumSet e
Set.insert WhichTest
wt)
          QT -> m ()
helper QT
a
          QT -> m ()
helper QT
b

-- This is used to view "win" only through NullView, and is used in
-- processing Or.
applyNullViews :: NullView -> QT -> QT
applyNullViews :: [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews [] QT
win = QT
win
applyNullViews [(SetTestInfo, WinTags)]
nvs QT
win = (QT -> (SetTestInfo, WinTags) -> QT)
-> QT -> [(SetTestInfo, WinTags)] -> QT
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
qtlose ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)])
-> [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
cleanNullView [(SetTestInfo, WinTags)]
nvs) where

-- This is used to prefer to view "win" through NullView.  Losing is
-- replaced by the plain win.  This is employed by Star patterns to
-- express that the first iteration is allowed to match null, but
-- skipping the NullView occurs if the match fails.
preferNullViews :: NullView -> QT -> QT
preferNullViews :: [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews [] QT
win = QT
win
preferNullViews [(SetTestInfo, WinTags)]
nvs QT
win = (QT -> (SetTestInfo, WinTags) -> QT)
-> QT -> [(SetTestInfo, WinTags)] -> QT
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
win ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)])
-> [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
cleanNullView [(SetTestInfo, WinTags)]
nvs) where

{-
dominate is common to applyNullViews and preferNullViews above.

Even I no longer understand it without study.

Oversimplified: The last argument has a new set of tests "sti" that
must be satisfied to then apply the new "tags" and reach the "win" QT.
Failing any of this set of tests leads to the "lose" QT.

Closer: The "win" may already have some other set of tests leading to
various branches, this set is cached in winTests.  And the "lose" may
already have some other set of tests leading to various branches.  The
combination of "win" and "lose" and "sti" must check the union of
these tests, which is "allTests".

Detail: The merging is done by useTest, where the tests in sti divert
losing to a branch of "lose" and winning to a branch of "win".  Tests
not in sti are unchanged (but the losing DoPa index might be added).
-}
dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT
dominate :: QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win QT
lose x :: (SetTestInfo, WinTags)
x@(SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags) = String -> QT -> QT
forall a s. Show a => a -> s -> s
debug (String
"dominate "String -> String -> String
forall a. [a] -> [a] -> [a]
++(SetTestInfo, WinTags) -> String
forall a. Show a => a -> String
show (SetTestInfo, WinTags)
x) (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
  let -- The winning states are reached through the SetTag
      win' :: QT
win' = WinTags -> QT -> QT
prependTags' WinTags
tags QT
win
      -- get the SetTestInfo
      winTests :: EnumSet WhichTest
winTests = QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
win (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
forall a. Monoid a => a
mempty
      allTests :: EnumSet WhichTest
allTests = (QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
lose (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
winTests) EnumSet WhichTest -> EnumSet WhichTest -> EnumSet WhichTest
forall a. Monoid a => a -> a -> a
`mappend` (EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest
forall key a. Enum key => EnumMap key a -> EnumSet key
EMap.keysSet EnumMap WhichTest (EnumSet DoPa)
sti)
      -- The first and second arguments of useTest are sorted
      -- At all times the second argument of useTest is a subset of the first
      useTest :: [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
_ [] QT
w QT
_ = QT
w -- no more dominating tests to fail to choose lose, so just choose win
      useTest (WhichTest
aTest:[WhichTest]
tests) allD :: [(WhichTest, EnumSet DoPa)]
allD@((WhichTest
dTest,EnumSet DoPa
dopas):[(WhichTest, EnumSet DoPa)]
ds) QT
w QT
l =
        let (QT
wA,QT
wB,EnumSet DoPa
wD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
w
            (QT
lA,QT
lB,EnumSet DoPa
lD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
l
            branches :: QT -> (QT, QT, EnumSet DoPa)
branches qt :: QT
qt@(Testing {}) | WhichTest
aTestWhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
==QT -> WhichTest
qt_test QT
qt = (QT -> QT
qt_a QT
qt,QT -> QT
qt_b QT
qt,QT -> EnumSet DoPa
qt_dopas QT
qt)
            branches QT
qt = (QT
qt,QT
qt,EnumSet DoPa
forall a. Monoid a => a
mempty)
        in if WhichTest
aTest WhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
== WhichTest
dTest
             then Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = (EnumSet DoPa
dopas EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
wD) EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
                          ,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
ds QT
wA QT
lA
                          ,qt_b :: QT
qt_b = QT
lB}
             else Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa
wD EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
                          ,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wA QT
lA
                          ,qt_b :: QT
qt_b = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wB QT
lB}
      useTest [] [(WhichTest, EnumSet DoPa)]
_ QT
_  QT
_ = String -> QT
forall a. String -> a
err String
"This case in dominate.useText cannot happen: second argument would have to have been null and that is checked before this case"
  in [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest (EnumSet WhichTest -> [WhichTest]
forall e. Enum e => EnumSet e -> [e]
Set.toList EnumSet WhichTest
allTests) (EnumMap WhichTest (EnumSet DoPa) -> [(WhichTest, EnumSet DoPa)]
forall key a. Enum key => EnumMap key a -> [(key, a)]
EMap.assocs EnumMap WhichTest (EnumSet DoPa)
sti) QT
win' QT
lose

-- 'applyTest' is only used by addTest
-- 2009: maybe need to keep track of whether a change is actually made
-- (beyond DoPa tracking) to the QT.
applyTest :: TestInfo -> QT -> QT
applyTest :: TestInfo -> QT -> QT
applyTest (WhichTest
wt,DoPa
dopa) QT
qt | QT -> Bool
nullQT QT
qt = QT
qt
                       | Bool
otherwise = QT -> QT
applyTest' QT
qt where
  applyTest' :: QT -> QT
  applyTest' :: QT -> QT
applyTest' q :: QT
q@(Simple {}) =
    QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$ Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
                        ,qt_dopas :: EnumSet DoPa
qt_dopas = DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e
Set.singleton DoPa
dopa
                        ,qt_a :: QT
qt_a = QT
q
                        ,qt_b :: QT
qt_b = QT
qtlose}
  applyTest' q :: QT
q@(Testing {qt_test :: QT -> WhichTest
qt_test=WhichTest
wt'}) =
    case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt WhichTest
wt' of
      Ordering
LT -> Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
                    ,qt_dopas :: EnumSet DoPa
qt_dopas = DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e
Set.singleton DoPa
dopa
                    ,qt_a :: QT
qt_a = QT
q
                    ,qt_b :: QT
qt_b = QT
qtlose}
      Ordering
EQ -> QT
q {qt_dopas :: EnumSet DoPa
qt_dopas = DoPa -> EnumSet DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e -> EnumSet e
Set.insert DoPa
dopa (QT -> EnumSet DoPa
qt_dopas QT
q)
              ,qt_b :: QT
qt_b = QT
qtlose}
      Ordering
GT -> QT
q {qt_a :: QT
qt_a = QT -> QT
applyTest' (QT -> QT
qt_a QT
q)
              ,qt_b :: QT
qt_b = QT -> QT
applyTest' (QT -> QT
qt_b QT
q)}

-- Three ways to merge a pair of QT's varying how winning transitions
-- are handled.
--
-- mergeQT_2nd is used by the NonEmpty case and always discards the
-- first argument's win and uses the second argument's win.
--
-- mergeAltQT is used by the Or cases and is biased to the first
-- argument's winning transition, if present.
--
-- mergeQT is used by Star and mergeE and combines the winning
-- transitions (concatenating the instructions).
mergeQT_2nd,mergeAltQT,mergeQT :: QT -> QT -> QT
mergeQT_2nd :: QT -> QT -> QT
mergeQT_2nd QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
                  | Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith (\WinTags
_ WinTags
w2 -> WinTags
w2) QT
q1 QT
q2

mergeAltQT :: QT -> QT -> QT
mergeAltQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2  -- prefer winning with w1 then with w2
                 | Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith (\WinTags
w1 WinTags
w2 -> if WinTags -> Bool
noWin WinTags
w1 then WinTags
w2 else WinTags
w1) QT
q1 QT
q2
mergeQT :: QT -> QT -> QT
mergeQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2  -- union wins
              | QT -> Bool
nullQT QT
q2 = QT
q1  -- union wins
              | Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
mappend QT
q1 QT
q2 -- no preference, win with combined SetTag XXX is the wrong thing! "(.?)*"

-- This takes a function which implements a policy on merging
-- winning transitions and then merges all the transitions.  It opens
-- the CharMap newtype for more efficient operation, then rewraps it.
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith WinTags -> WinTags -> WinTags
mergeWins = QT -> QT -> QT
merge where
  merge :: QT -> QT -> QT
  merge :: QT -> QT -> QT
merge (Simple WinTags
w1 CharMap QTrans
t1 QTrans
o1) (Simple WinTags
w2 CharMap QTrans
t2 QTrans
o2) =
    let w' :: WinTags
w' = WinTags -> WinTags -> WinTags
mergeWins WinTags
w1 WinTags
w2
        t' :: CharMap QTrans
t' = CharMap QTrans
-> QTrans -> CharMap QTrans -> QTrans -> CharMap QTrans
fuseQTrans CharMap QTrans
t1 QTrans
o1 CharMap QTrans
t2 QTrans
o2
        o' :: QTrans
o' = QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1 QTrans
o2
    in WinTags -> CharMap QTrans -> QTrans -> QT
Simple WinTags
w' CharMap QTrans
t' QTrans
o'
  merge t1 :: QT
t1@(Testing WhichTest
_ EnumSet DoPa
_ QT
a1 QT
b1) s2 :: QT
s2@(Simple {}) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    QT
t1 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
a1 QT
s2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
b1 QT
s2)}
  merge s1 :: QT
s1@(Simple {}) t2 :: QT
t2@(Testing WhichTest
_ EnumSet DoPa
_ QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    QT
t2 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
s1 QT
a2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
s1 QT
b2)}
  merge t1 :: QT
t1@(Testing WhichTest
wt1 EnumSet DoPa
ds1 QT
a1 QT
b1) t2 :: QT
t2@(Testing WhichTest
wt2 EnumSet DoPa
ds2 QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt1 WhichTest
wt2 of
      Ordering
LT -> QT
t1 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
a1 QT
t2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
b1 QT
t2)}
      Ordering
EQ -> Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
wt1 -- same as wt2
                    ,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
mappend EnumSet DoPa
ds1 EnumSet DoPa
ds2
                    ,qt_a :: QT
qt_a = QT -> QT -> QT
merge QT
a1 QT
a2
                    ,qt_b :: QT
qt_b = QT -> QT -> QT
merge QT
b1 QT
b2}
      Ordering
GT -> QT
t2 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
t1 QT
a2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
t1 QT
b2)}

  fuseQTrans :: (CharMap QTrans) -> QTrans
             -> (CharMap QTrans) -> QTrans
             -> CharMap QTrans
  fuseQTrans :: CharMap QTrans
-> QTrans -> CharMap QTrans -> QTrans -> CharMap QTrans
fuseQTrans (CharMap IntMap QTrans
t1) QTrans
o1 (CharMap IntMap QTrans
t2) QTrans
o2 = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap ([(Tag, QTrans)] -> IntMap QTrans
forall a. [(Tag, a)] -> IntMap a
IMap.fromDistinctAscList ([(Tag, QTrans)] -> [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a. Ord a => [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(Tag, QTrans)]
l1 [(Tag, QTrans)]
l2)) where
    l1 :: [(Tag, QTrans)]
l1 = IntMap QTrans -> [(Tag, QTrans)]
forall a. IntMap a -> [(Tag, a)]
IMap.toAscList IntMap QTrans
t1
    l2 :: [(Tag, QTrans)]
l2 = IntMap QTrans -> [(Tag, QTrans)]
forall a. IntMap a -> [(Tag, a)]
IMap.toAscList IntMap QTrans
t2
    fuse :: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [] [(a, QTrans)]
y  = (QTrans -> QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1) [(a, QTrans)]
y
    fuse [(a, QTrans)]
x  [] = (QTrans -> QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o2) [(a, QTrans)]
x
    fuse x :: [(a, QTrans)]
x@((a
xc,QTrans
xa):[(a, QTrans)]
xs) y :: [(a, QTrans)]
y@((a
yc,QTrans
ya):[(a, QTrans)]
ys) =
      case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
xc a
yc of
        Ordering
LT -> (a
xc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
xa QTrans
o2) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
xs [(a, QTrans)]
y
        Ordering
EQ -> (a
xc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
xa QTrans
ya) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
xs [(a, QTrans)]
ys
        Ordering
GT -> (a
yc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1 QTrans
ya) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
x  [(a, QTrans)]
ys

  mergeQTrans :: QTrans -> QTrans -> QTrans
  mergeQTrans :: QTrans -> QTrans -> QTrans
mergeQTrans = ([TagCommand] -> [TagCommand] -> [TagCommand])
-> QTrans -> QTrans -> QTrans
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IMap.unionWith [TagCommand] -> [TagCommand] -> [TagCommand]
forall a. Monoid a => a -> a -> a
mappend

-- Note: There are no append* operations. There are only these
-- prepend* operations because things are only prepended to the future
-- continuation.  And the ordering is significant.

-- This is only used in inStar/nullable
prependPreTag :: Maybe Tag -> QT -> QT
prependPreTag :: Maybe Tag -> QT -> QT
prependPreTag Maybe Tag
Nothing QT
qt = QT
qt
prependPreTag (Just Tag
tag) QT
qt = WinTags -> QT -> QT
prependTags' [(Tag
tag,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)] QT
qt

prependGroupResets :: [Tag] -> QT -> QT
prependGroupResets :: [Tag] -> QT -> QT
prependGroupResets [] QT
qt = QT
qt
prependGroupResets [Tag]
tags QT
qt = WinTags -> QT -> QT
prependTags' [(Tag
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetGroupStopTask)|Tag
tag<-[Tag]
tags] QT
qt

prependTags' :: TagList -> QT -> QT
prependTags' :: WinTags -> QT -> QT
prependTags' []  QT
qt = QT
qt
prependTags' WinTags
tcs' qt :: QT
qt@(Testing {}) = QT
qt { qt_a :: QT
qt_a = WinTags -> QT -> QT
prependTags' WinTags
tcs' (QT -> QT
qt_a QT
qt)
                                       , qt_b :: QT
qt_b = WinTags -> QT -> QT
prependTags' WinTags
tcs' (QT -> QT
qt_b QT
qt) }
prependTags' WinTags
tcs' (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) =
  Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = if WinTags -> Bool
noWin WinTags
w then WinTags
w else WinTags
tcs' WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
`mappend` WinTags
w
         , qt_trans :: CharMap QTrans
qt_trans = (QTrans -> QTrans) -> CharMap QTrans -> CharMap QTrans
forall a b. (a -> b) -> CharMap a -> CharMap b
Map.map QTrans -> QTrans
forall a. IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans CharMap QTrans
t
         , qt_other :: QTrans
qt_other = QTrans -> QTrans
forall a. IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans QTrans
o }
  where prependQTrans :: IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans = ([(a, WinTags)] -> [(a, WinTags)])
-> IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, WinTags) -> (a, WinTags)) -> [(a, WinTags)] -> [(a, WinTags)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
d,WinTags
tcs) -> (a
d,WinTags
tcs' WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
`mappend` WinTags
tcs)))

-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==
-- define type S which is a State monad, this allows the creation of the uniq QNFA ids and storing the QNFA
-- in an ascending order difference list for later placement in an array.

-- Type of State monad used inside qToNFA
type S = State (Index                             -- Next available QNFA index
               ,[(Index,QNFA)]->[(Index,QNFA)])    -- DList of previous QNFAs

-- Type of continuation of the NFA, not much more complicated
type E = (TagTasks            -- Things to do before the Either QNFA QT
                              -- with OneChar these become PostUpdate otherwise they become PreUpdate
         ,Either QNFA QT)     -- The future, packaged in the best way

-- See documentation below before the 'act' function.  This is for use inside a Star pattern.
type ActCont = ( E                      -- The eLoop is the dangerous recursive reference to continuation
                                        -- future that loops while accepting zero more characters
               , Maybe E                -- This holds the safe non-zero-character accepting continuation
               , Maybe (TagTasks,QNFA)) -- optimized merger of the above, used only inside act, to avoid orphan QNFA id values

-- newQNFA is the only operation that actually uses the monad get and put operations
newQNFA :: String -> QT -> S QNFA
newQNFA :: String -> QT -> S QNFA
newQNFA String
s QT
qt = do
  (Tag
thisI,[(Tag, QNFA)] -> [(Tag, QNFA)]
oldQs) <- StateT
  (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
  Identity
  (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
forall s (m :: * -> *). MonadState s m => m s
get
  let futureI :: Tag
futureI = Tag -> Tag
forall a. Enum a => a -> a
succ Tag
thisI in Tag -> S QNFA -> S QNFA
seq Tag
futureI (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ String -> S QNFA -> S QNFA
forall a s. Show a => a -> s -> s
debug (String
">newQNFA< "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" : "String -> String -> String
forall a. [a] -> [a] -> [a]
++Tag -> String
forall a. Show a => a -> String
show Tag
thisI) (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ do
  let qnfa :: QNFA
qnfa = Tag -> QT -> QNFA
mkQNFA Tag
thisI QT
qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ
  (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
 -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ())
-> (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$! (Tag
futureI, [(Tag, QNFA)] -> [(Tag, QNFA)]
oldQs ([(Tag, QNFA)] -> [(Tag, QNFA)])
-> ([(Tag, QNFA)] -> [(Tag, QNFA)])
-> [(Tag, QNFA)]
-> [(Tag, QNFA)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Tag
thisI,QNFA
qnfa)(Tag, QNFA) -> [(Tag, QNFA)] -> [(Tag, QNFA)]
forall a. a -> [a] -> [a]
:))
  QNFA -> S QNFA
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa

-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==
-- E related functions

fromQNFA :: QNFA -> E
fromQNFA :: QNFA -> E
fromQNFA QNFA
qnfa = ([(Tag, TagTask)]
forall a. Monoid a => a
mempty,QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)

fromQT :: QT -> E
fromQT :: QT -> E
fromQT QT
qt = ([(Tag, TagTask)]
forall a. Monoid a => a
mempty,QT -> Either QNFA QT
forall a b. b -> Either a b
Right QT
qt)

-- Promises the output will match (_,Left _), used by Or cases when any branch wants a QNFA continuation
asQNFA :: String -> E -> S E
asQNFA :: String -> E -> S E
asQNFA String
_ x :: E
x@([(Tag, TagTask)]
_,Left QNFA
_) = E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
x
asQNFA String
s ([(Tag, TagTask)]
tags,Right QT
qt) = do QNFA
qnfa <- String -> QT -> S QNFA
newQNFA String
s QT
qt      -- YYY Policy choice: leave the tags
                              E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Tag, TagTask)]
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)

-- Convert continuation E into a QNFA, only done at "top level" by qToNFA to get unique start state
getQNFA :: String -> E -> S QNFA
getQNFA :: String -> E -> S QNFA
getQNFA String
_ ([],Left QNFA
qnfa) = QNFA -> S QNFA
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa
getQNFA String
s ([(Tag, TagTask)]
tags,Left QNFA
qnfa) = String -> QT -> S QNFA
newQNFA String
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(Tag, TagTask)]
tags) (QNFA -> QT
q_qt QNFA
qnfa))
getQNFA String
s ([(Tag, TagTask)]
tags,Right QT
qt) = String -> QT -> S QNFA
newQNFA String
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(Tag, TagTask)]
tags) QT
qt)

-- Extract the QT from the E
getQT :: E -> QT
getQT :: E -> QT
getQT ([(Tag, TagTask)]
tags,Either QNFA QT
cont) = WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(Tag, TagTask)]
tags) ((QNFA -> QT) -> (QT -> QT) -> Either QNFA QT -> QT
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_qt QT -> QT
forall a. a -> a
id Either QNFA QT
cont)

-- 2009: This looks realllly dodgy, since it can convert a QNFA/Testing to a QT/Testing
-- without actually achieving anything except adding a DoPa to the Testing.  A diagnostic
-- series of runs might be needed to decide if this ever creates orphan id numbers.
-- Then applyTest might need to keep track of whether it actually changes anything.
addTest :: TestInfo -> E -> E
addTest :: TestInfo -> E -> E
addTest TestInfo
ti ([(Tag, TagTask)]
tags,Either QNFA QT
cont) = ([(Tag, TagTask)]
tags, QT -> Either QNFA QT
forall a b. b -> Either a b
Right (QT -> Either QNFA QT)
-> (Either QNFA QT -> QT) -> Either QNFA QT -> Either QNFA QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> QT -> QT
applyTest TestInfo
ti (QT -> QT) -> (Either QNFA QT -> QT) -> Either QNFA QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QNFA -> QT) -> (QT -> QT) -> Either QNFA QT -> QT
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_qt QT -> QT
forall a. a -> a
id (Either QNFA QT -> Either QNFA QT)
-> Either QNFA QT -> Either QNFA QT
forall a b. (a -> b) -> a -> b
$ Either QNFA QT
cont)

-- This is used only with PreUpdate and PostUpdate as the first argument.
promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList
promoteTasks :: (TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
promote [(Tag, TagTask)]
tags = ((Tag, TagTask) -> (Tag, TagUpdate)) -> [(Tag, TagTask)] -> WinTags
forall a b. (a -> b) -> [a] -> [b]
map (\(Tag
tag,TagTask
task) -> (Tag
tag,TagTask -> TagUpdate
promote TagTask
task)) [(Tag, TagTask)]
tags

-- only used in addWinTags
demoteTags :: TagList -> TagTasks
demoteTags :: WinTags -> [(Tag, TagTask)]
demoteTags = ((Tag, TagUpdate) -> (Tag, TagTask)) -> WinTags -> [(Tag, TagTask)]
forall a b. (a -> b) -> [a] -> [b]
map (Tag, TagUpdate) -> (Tag, TagTask)
forall a. (a, TagUpdate) -> (a, TagTask)
helper
  where helper :: (a, TagUpdate) -> (a, TagTask)
helper (a
tag,PreUpdate TagTask
tt) = (a
tag,TagTask
tt)
        helper (a
tag,PostUpdate TagTask
tt) = (a
tag,TagTask
tt)

-- This is polymorphic so addWinTags can be cute below
{-# INLINE addWinTags #-}
addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a)
addWinTags :: WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags ([(Tag, TagTask)]
tags,a
cont) = (WinTags -> [(Tag, TagTask)]
demoteTags WinTags
wtags [(Tag, TagTask)] -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall a. Monoid a => a -> a -> a
`mappend` [(Tag, TagTask)]
tags
                               ,a
cont)

{-# INLINE addTag' #-}
-- This is polymorphic so addTagAC can be cute below
addTag' :: Tag -> (TagTasks,a) -> (TagTasks,a)
addTag' :: Tag -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addTag' Tag
tag ([(Tag, TagTask)]
tags,a
cont) = ((Tag
tag,TagTask
TagTask)(Tag, TagTask) -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall a. a -> [a] -> [a]
:[(Tag, TagTask)]
tags
                          ,a
cont)

-- a Maybe version of addTag' above, specializing 'a' to Either QNFA QT
addTag :: Maybe Tag -> E -> E
addTag :: Maybe Tag -> E -> E
addTag Maybe Tag
Nothing E
e = E
e
addTag (Just Tag
tag) E
e = Tag -> E -> E
forall a. Tag -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addTag' Tag
tag E
e

{-# INLINE addGroupResets #-}
-- This is polymorphic so addGroupResetsAC can be cute below
addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)
addGroupResets :: [Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [] ([(Tag, TagTask)], a)
x = ([(Tag, TagTask)], a)
x
addGroupResets [Tag]
tags ([(Tag, TagTask)]
tags',a
cont) = (((Tag, TagTask) -> [(Tag, TagTask)] -> [(Tag, TagTask)])
-> [(Tag, TagTask)] -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [(Tag, TagTask)]
tags' ([(Tag, TagTask)] -> [(Tag, TagTask)])
-> ([Tag] -> [(Tag, TagTask)]) -> [Tag] -> [(Tag, TagTask)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> (Tag, TagTask)) -> [Tag] -> [(Tag, TagTask)]
forall a b. (a -> b) -> [a] -> [b]
map (\Tag
tag -> (Tag
tag,TagTask
ResetGroupStopTask)) ([Tag] -> [(Tag, TagTask)]) -> [Tag] -> [(Tag, TagTask)]
forall a b. (a -> b) -> a -> b
$ [Tag]
tags
                                   ,a
cont)

addGroupSets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)
addGroupSets :: [Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [] ([(Tag, TagTask)], a)
x = ([(Tag, TagTask)], a)
x
addGroupSets [Tag]
tags ([(Tag, TagTask)]
tags',a
cont) = (((Tag, TagTask) -> [(Tag, TagTask)] -> [(Tag, TagTask)])
-> [(Tag, TagTask)] -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [(Tag, TagTask)]
tags' ([(Tag, TagTask)] -> [(Tag, TagTask)])
-> ([Tag] -> [(Tag, TagTask)]) -> [Tag] -> [(Tag, TagTask)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> (Tag, TagTask)) -> [Tag] -> [(Tag, TagTask)]
forall a b. (a -> b) -> [a] -> [b]
map (\Tag
tag -> (Tag
tag,TagTask
SetGroupStopTask)) ([Tag] -> [(Tag, TagTask)]) -> [Tag] -> [(Tag, TagTask)]
forall a b. (a -> b) -> a -> b
$ [Tag]
tags
                                 ,a
cont)

-- Consume an ActCont.  Uses the mergeQT form to combine non-accepting
-- and accepting view of the continuation.
getE :: ActCont -> E
getE :: ActCont -> E
getE (E
_,Maybe E
_,Just ([(Tag, TagTask)]
tags,QNFA
qnfa)) = ([(Tag, TagTask)]
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)  -- consume optimized mQNFA value returned by Star
getE (E
eLoop,Just E
accepting,Maybe ([(Tag, TagTask)], QNFA)
_) = QT -> E
fromQT (QT -> QT -> QT
mergeQT (E -> QT
getQT E
eLoop) (E -> QT
getQT E
accepting))
getE (E
eLoop,Maybe E
Nothing,Maybe ([(Tag, TagTask)], QNFA)
_) = E
eLoop

-- 2009: See comment for addTest.  Here is a case where the third component might be a (Just qnfa) and it
-- is being lost even though the added test might be redundant.
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti (E
e,Maybe E
mE,Maybe ([(Tag, TagTask)], QNFA)
_) = (TestInfo -> E -> E
addTest TestInfo
ti E
e
                        ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestInfo -> E -> E
addTest TestInfo
ti) Maybe E
mE
                        ,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)

-- These are AC versions of the add functions on E

addTagAC :: Maybe Tag -> ActCont -> ActCont
addTagAC :: Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
Nothing ActCont
ac = ActCont
ac
addTagAC (Just Tag
tag) (E
e,Maybe E
mE,Maybe ([(Tag, TagTask)], QNFA)
mQNFA) = (Tag -> E -> E
forall a. Tag -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addTag' Tag
tag E
e
                                   ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tag -> E -> E
forall a. Tag -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addTag' Tag
tag) Maybe E
mE
                                   ,(([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA))
-> Maybe ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tag -> ([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA)
forall a. Tag -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addTag' Tag
tag) Maybe ([(Tag, TagTask)], QNFA)
mQNFA)

addGroupResetsAC :: [Tag] -> ActCont -> ActCont
addGroupResetsAC :: [Tag] -> ActCont -> ActCont
addGroupResetsAC [] ActCont
ac = ActCont
ac
addGroupResetsAC [Tag]
tags (E
e,Maybe E
mE,Maybe ([(Tag, TagTask)], QNFA)
mQNFA) = ([Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
tags E
e
                                     ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
tags) Maybe E
mE
                                     ,(([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA))
-> Maybe ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tag] -> ([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA)
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
tags) Maybe ([(Tag, TagTask)], QNFA)
mQNFA)

addGroupSetsAC :: [Tag] -> ActCont -> ActCont
addGroupSetsAC :: [Tag] -> ActCont -> ActCont
addGroupSetsAC [] ActCont
ac = ActCont
ac
addGroupSetsAC [Tag]
tags (E
e,Maybe E
mE,Maybe ([(Tag, TagTask)], QNFA)
mQNFA) = ([Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
tags E
e
                                   ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
tags) Maybe E
mE
                                   ,(([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA))
-> Maybe ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tag] -> ([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA)
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
tags) Maybe ([(Tag, TagTask)], QNFA)
mQNFA)

addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags (E
e,Maybe E
mE,Maybe ([(Tag, TagTask)], QNFA)
mQNFA) = (WinTags -> E -> E
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags E
e
                                  ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> E -> E
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags) Maybe E
mE
                                  ,(([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA))
-> Maybe ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> ([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA)
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags) Maybe ([(Tag, TagTask)], QNFA)
mQNFA)
-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==

-- Initial preTag of 0th tag is implied. No other general pre-tags would be expected.
-- The qtwin contains the preTag of the 1st tag and is only set when a match is completed.
-- The fst Index is the index of the unique starting QNFA state.
-- The snd (Array Index QNFA) is all the QNFA states.
--
-- In the cases below, Empty is handled much like a Test with no TestInfo.
qToNFA :: CompOption -> Q -> (Index,Array Index QNFA)
qToNFA :: CompOption -> Q -> (Tag, Array Tag QNFA)
qToNFA CompOption
compOpt Q
qTop = (QNFA -> Tag
q_id QNFA
startingQNFA
                      ,(Tag, Tag) -> [(Tag, QNFA)] -> Array Tag QNFA
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Tag
0,Tag -> Tag
forall a. Enum a => a -> a
pred Tag
lastIndex) ([(Tag, QNFA)] -> [(Tag, QNFA)]
table [])) where
  -- Result startingQNFA is the top level's index
  -- State pair: fst 0 is the next state number (not yet used) going in, and lastIndex coming out (succ of last used)
  --             snd id is the difference list of states going in, and the finished list coming out
  (QNFA
startingQNFA,(Tag
lastIndex,[(Tag, QNFA)] -> [(Tag, QNFA)]
table)) =
    S QNFA
-> (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
-> (QNFA, (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]))
forall s a. State s a -> s -> (a, s)
runState (Q -> E -> S E
getTrans Q
qTop (QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ QT
qtwin) S E -> (E -> S QNFA) -> S QNFA
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> E -> S QNFA
getQNFA String
"top level") (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)])
forall a. (Tag, a -> a)
startState
  startState :: (Tag, a -> a)
startState = (Tag
0,a -> a
forall a. a -> a
id)

  getTrans,getTransTagless :: Q -> E -> S E
  getTrans :: Q -> E -> S E
getTrans qIn :: Q
qIn@(Q {preReset :: Q -> [Tag]
preReset=[Tag]
resets,postSet :: Q -> [Tag]
postSet=[Tag]
sets,preTag :: Q -> Maybe Tag
preTag=Maybe Tag
pre,postTag :: Q -> Maybe Tag
postTag=Maybe Tag
post,unQ :: Q -> P
unQ=P
pIn}) E
e = String -> S E -> S E
forall a s. Show a => a -> s -> s
debug (String
">< getTrans "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
    case P
pIn of
      -- The case below is the ultimate consumer of every single OneChar in the input and the only caller of
      -- newTrans/acceptTrans which is the sole source of QT/Simple nodes.
      OneChar Pattern
pat -> String -> [Tag] -> Maybe Tag -> Pattern -> E -> S E
newTrans String
"getTrans/OneChar" [Tag]
resets Maybe Tag
pre Pattern
pat (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      P
Empty -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      Test TestInfo
ti -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> E -> E
addTest TestInfo
ti (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      P
_ -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupResets [Tag]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
addTag Maybe Tag
pre (E -> S E) -> S E -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTransTagless Q
qIn (Maybe Tag -> E -> E
addTag Maybe Tag
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e)

  getTransTagless :: Q -> E -> S E
getTransTagless Q
qIn E
e = String -> S E -> S E
forall a s. Show a => a -> s -> s
debug (String
">< getTransTagless "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
    case Q -> P
unQ Q
qIn of
      Seq Q
q1 Q
q2 -> Q -> E -> S E
getTrans Q
q1 (E -> S E) -> S E -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q2 E
e
      Or [] -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
e
      Or [Q
q] -> Q -> E -> S E
getTrans Q
q E
e
      Or [Q]
qs -> do
        [E]
eqts <- if Q -> Bool
usesQNFA Q
qIn
                  then do
                    E
eQNFA <- String -> E -> S E
asQNFA String
"getTransTagless/Or/usesQNFA" E
e
                    [S E] -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q -> E -> S E
getTrans Q
q E
eQNFA | Q
q <- [Q]
qs ]
                  else [S E] -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q -> E -> S E
getTrans Q
q E
e | Q
q <- [Q]
qs ]
        let qts :: [QT]
qts = (E -> QT) -> [E] -> [QT]
forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT [E]
eqts
        E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT ((QT -> QT -> QT) -> [QT] -> QT
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts))

      Star Maybe Tag
mOrbit [Tag]
resetTheseOrbits Bool
mayFirstBeNull Q
q ->
        -- mOrbit of Just implies varies q and childGroups q
        let (E
e',Bool
clear) = -- debug ("\n>"++show e++"\n"++show q++"\n<") $
              if Q -> Bool
notNullable Q
q then (E
e,Bool
True)  -- subpattern cannot be null
                else if [Tag] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tag]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Tag -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Tag
mOrbit
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
                              Just [] -> (E
e,Bool
True)    -- True because null of subpattern is same as skipping subpattern
                              Just WinTags
tagList -> (WinTags -> E -> E
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
tagList E
e,Bool
False) -- null of subpattern NOT same as skipping
                              Maybe WinTags
_ -> (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)  -- is NOT same as skipping
                       else (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> QT -> QT
resetOrbitsQT [Tag]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> QT -> QT
enterOrbitQT Maybe Tag
mOrbit -- resetOrbitsQT and enterOrbitQT commute
                             (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
leaveOrbit Maybe Tag
mOrbit (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)  -- perform resets when accepting 0 characters
        in if Q -> Bool
cannotAccept Q
q then E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
e' else mdo
        Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
this
        (E
this,E
ans) <- case Maybe QT
mqt of
                        Maybe QT
Nothing -> String
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (E, E)
forall a. String -> a
err (String
"Weird pattern in getTransTagless/Star: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))
                        Just QT
qt -> do
                          let qt' :: QT
qt' = [Tag] -> QT -> QT
resetOrbitsQT [Tag]
resetTheseOrbits (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> QT -> QT
enterOrbitQT Maybe Tag
mOrbit (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$ QT
qt -- resetOrbitsQT and enterOrbitQT commute
                              thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
qt' (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
leaveOrbit Maybe Tag
mOrbit (E -> QT) -> E -> QT
forall a b. (a -> b) -> a -> b
$ E
e -- capture of subpattern or leave via next pattern (avoid null of subpattern on way out)
                              ansE :: E
ansE = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
qt' (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e' -- capture of subpattern or leave via null of subpattern
                          E
thisE <- if Q -> Bool
usesQNFA Q
q
                                  then E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QNFA -> E) -> QNFA -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QNFA -> E
fromQNFA (QNFA -> S E) -> S QNFA -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> QT -> S QNFA
newQNFA String
"getTransTagless/Star" QT
thisQT
                                  else E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QT -> E) -> QT -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> S E) -> QT -> S E
forall a b. (a -> b) -> a -> b
$ QT
thisQT
                          (E, E)
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (E, E)
forall (m :: * -> *) a. Monad m => a -> m a
return (E
thisE,E
ansE)
        E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
mayFirstBeNull then (if Bool
clear then E
this  -- optimization to possibly preserve QNFA
                                                 else E
ans)
                  else E
this)

      {- NonEmpty is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -}
      NonEmpty Q
q -> String -> S E -> S E
forall a. String -> a -> a
ecart (String
"\n> getTransTagless/NonEmpty"String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qIn)  (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$ do
        -- Assertion to check than Pattern.starTrans did its job right:
        Bool
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (String -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a. String -> a
err (String
 -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ())
-> String
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))
        Bool
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (String -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a. String -> a
err (String
 -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ())
-> String
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))
        let e' :: E
e' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                   Just [] -> E
e
                   Just WinTags
_wtags -> E
e -- addWinTags wtags e  XXX was duplicating tags
                   Maybe WinTags
Nothing -> String -> E
forall a. String -> a
err (String -> E) -> String -> E
forall a b. (a -> b) -> a -> b
$ String
"getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qIn
        Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
e
        E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ case Maybe QT
mqt of
                   Maybe QT
Nothing -> String -> E
forall a. String -> a
err (String
"Weird pattern in getTransTagless/NonEmpty: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))
                   Just QT
qt -> QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT_2nd QT
qt (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e' -- ...and then this sets qt_win to exactly that of e'
      P
_ -> String -> S E
forall a. String -> a
err (String
"This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))

  inStar,inStarNullableTagless :: Q -> E -> S (Maybe QT)
  inStar :: Q -> E -> S (Maybe QT)
inStar qIn :: Q
qIn@(Q {preReset :: Q -> [Tag]
preReset=[Tag]
resets,postSet :: Q -> [Tag]
postSet=[Tag]
sets,preTag :: Q -> Maybe Tag
preTag=Maybe Tag
pre,postTag :: Q -> Maybe Tag
postTag=Maybe Tag
post}) E
eLoop | Q -> Bool
notNullable Q
qIn =
    String -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug (String
">< inStar/1 "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
    Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QT -> S (Maybe QT)) -> (E -> Maybe QT) -> E -> S (Maybe QT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> Maybe QT
forall a. a -> Maybe a
Just (QT -> Maybe QT) -> (E -> QT) -> E -> Maybe QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> S (Maybe QT)) -> S E -> S (Maybe QT)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn E
eLoop
                                                                 | Bool
otherwise =
    String -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug (String
">< inStar/2 "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
    Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QT -> S (Maybe QT))
-> (Maybe QT -> Maybe QT) -> Maybe QT -> S (Maybe QT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QT -> QT) -> Maybe QT -> Maybe QT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tag] -> QT -> QT
prependGroupResets [Tag]
resets (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> QT -> QT
prependPreTag Maybe Tag
pre) (Maybe QT -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn (Maybe Tag -> E -> E
addTag Maybe Tag
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> E -> E
forall a.
Show a =>
[Tag] -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addGroupSets [Tag]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
eLoop)

  inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn E
eLoop = String -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug (String
">< inStarNullableTagless "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      P
Empty -> Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing -- with Or this discards () branch in "(^|foo|())*"
      Or [] -> Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing
      Or [Q
q] -> Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop
      Or [Q]
qs -> do
        [Maybe QT]
mqts <- if Q -> Bool
usesQNFA Q
qIn
                  then do E
eQNFA <- String -> E -> S E
asQNFA String
"inStarNullableTagless/Or/usesQNFA" E
eLoop
                          [S (Maybe QT)]
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [Maybe QT]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q -> E -> S (Maybe QT)
inStar Q
q E
eQNFA | Q
q <- [Q]
qs ]
                  else [S (Maybe QT)]
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [Maybe QT]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop | Q
q <- [Q]
qs ]
        let qts :: [QT]
qts = [Maybe QT] -> [QT]
forall a. [Maybe a] -> [a]
catMaybes [Maybe QT]
mqts
            mqt :: Maybe QT
mqt = if [QT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts then Maybe QT
forall a. Maybe a
Nothing else QT -> Maybe QT
forall a. a -> Maybe a
Just ((QT -> QT -> QT) -> [QT] -> QT
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
        Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
mqt
      -- Calls to act are inlined by hand to actNullable.  This returns only cases where q1 or q2 or both
      -- accepted characters.  The zero-character case is handled by the tag wrapping by inStar.
      -- 2009: Does this look dodgy and repetitios of tags?  Seq by policy has no preTag or postTag.
      -- though it can have prependGroupResets, but those are not repeated in children so it is okay.
      Seq Q
q1 Q
q2 -> do (E
_,Maybe E
meAcceptingOut,Maybe ([(Tag, TagTask)], QNFA)
_) <- Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
                      Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      -- Calls to act are inlined by hand and are we losing the tags?
      Star {} -> do (E
_,Maybe E
meAcceptingOut,Maybe ([(Tag, TagTask)], QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
                    Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      NonEmpty {} -> String -> S (Maybe QT) -> S (Maybe QT)
forall a. String -> a -> a
ecart (String
"\n> inStarNullableTagless/NonEmpty"String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qIn) (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
                     do (E
_,Maybe E
meAcceptingOut,Maybe ([(Tag, TagTask)], QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
                        Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      Test {} -> Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing -- with Or this discards ^ branch in "(^|foo|())*"
      OneChar {} -> String -> S (Maybe QT)
forall a. String -> a
err (String
"OneChar cannot have nullable True")

  {- act* functions

  These have a very complicated state that they receive and return as
  "the continuation".

   (E, Maybe E,Maybe (SetTag,QNFA))

  The first E is the source of the danger that must be avoided.  It
  starts out a reference to the QNFA/QT state that will be created by
  the most recent parent Star node.  Thus it is a recursive reference
  from the MonadFix machinery.  In particular, this value cannot be
  returned to the parent Star to be included in itself or we get a "let
  x = y; y=x" style infinite loop.

  As act* progresses the first E is actually modified to be the parent
  QNFA/QT as "seen" when all the elements to the right have accepted 0
  characters.  Thus it acquires tags and tests+tags (the NullView data
  is used for this purpose).

  The second item in the 3-tuple is a Maybe E.  This will be used as the
  source of the QT for this contents of the Star QNFA/QT.  It will be
  merged with the Star's own continuation data.  It starts out Nothing
  and stays that way as long as there are no accepting transitions in
  the Star's pattern.  This is value (via getQT) returned by inStar.

  The third item is a special optimization I added to remove a source
  of orphaned QNFAs.  A Star within Act will often have to create a
  QNFA node.  This cannot go into the second Maybe E item as Just
  (SetTag,Left QNFA) because this QNFA can have pulled values from the
  recursive parent Star's QNFA/QT in the first E value.  Thus pulling
  with getQT from the QNFA and using that as the Maybe E would likely
  cause an infinite loop.  This extra QNFA is stored in the thd3
  location for use by getE. To improve it further it can accumulate
  Tag information after being formed.

  When a non nullable Q is handled by act it checks to see if the
  third value is there, in which case it uses that QNFA as the total
  continuation (subsumed in getE).  Otherwise it merges the first E
  with any (Just E) in the second value to form the continuation.

  -}

  act :: Q -> ActCont -> S (Maybe E)
  act :: Q -> ActCont -> S (Maybe E)
act Q
qIn ActCont
c | Q -> Bool
nullable Q
qIn = (ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
qIn ActCont
c
            | Bool
otherwise = String -> S (Maybe E) -> S (Maybe E)
forall a s. Show a => a -> s -> s
debug (String
">< act "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S (Maybe E) -> S (Maybe E)) -> S (Maybe E) -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ do
    Maybe E
mqt <- Maybe E -> S (Maybe E)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe E -> S (Maybe E)) -> (E -> Maybe E) -> E -> S (Maybe E)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> Maybe E
forall a. a -> Maybe a
Just (E -> S (Maybe E)) -> S E -> S (Maybe E)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn ( ActCont -> E
getE (ActCont -> E) -> ActCont -> E
forall a b. (a -> b) -> a -> b
$ ActCont
c )
    Maybe E -> S (Maybe E)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe E
mqt  -- or "return (fromQT qtlose,mqt,Nothing)"

  actNullable,actNullableTagless :: Q -> ActCont -> S ActCont
  actNullable :: Q -> ActCont -> S ActCont
actNullable qIn :: Q
qIn@(Q {preReset :: Q -> [Tag]
preReset=[Tag]
resets,postSet :: Q -> [Tag]
postSet=[Tag]
sets,preTag :: Q -> Maybe Tag
preTag=Maybe Tag
pre,postTag :: Q -> Maybe Tag
postTag=Maybe Tag
post,unQ :: Q -> P
unQ=P
pIn}) ActCont
ac =
    String -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug (String
">< actNullable "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qInString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case P
pIn of
      P
Empty -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupResetsAC [Tag]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupSetsAC [Tag]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
      Test TestInfo
ti -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupResetsAC [Tag]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupSetsAC [Tag]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
      OneChar {} -> String -> S ActCont
forall a. String -> a
err (String
"OneChar cannot have nullable True ")
      P
_ -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupResetsAC [Tag]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
pre (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullableTagless Q
qIn ( Maybe Tag -> ActCont -> ActCont
addTagAC Maybe Tag
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> ActCont -> ActCont
addGroupSetsAC [Tag]
sets (ActCont -> ActCont) -> ActCont -> ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac )

  actNullableTagless :: Q -> ActCont -> S ActCont
actNullableTagless Q
qIn ac :: ActCont
ac@(E
eLoop,Maybe E
mAccepting,Maybe ([(Tag, TagTask)], QNFA)
mQNFA) = String -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug (String
">< actNullableTagless "String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show (Q
qIn)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      Seq Q
q1 Q
q2 -> Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 ActCont
ac   -- We know q1 and q2 are nullable

      Or [] -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac
      Or [Q
q] -> Q -> ActCont -> S ActCont
actNullableTagless Q
q ActCont
ac
      Or [Q]
qs -> do
        [Maybe E]
cqts <- do
          if (Q -> Bool) -> [Q] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Q -> Bool
nullable [Q]
qs
            then [S (Maybe E)]
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [Maybe E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac | Q
q <- [Q]
qs]
            else do
              E
e' <- String -> E -> S E
asQNFA String
"qToNFA/actNullableTagless/Or" (E -> S E) -> (ActCont -> E) -> ActCont -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> S E) -> ActCont -> S E
forall a b. (a -> b) -> a -> b
$ ActCont
ac
              let act' :: Q -> S (Maybe E)
                  act' :: Q -> S (Maybe E)
act' Q
q = Maybe E -> S (Maybe E)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe E -> S (Maybe E)) -> (E -> Maybe E) -> E -> S (Maybe E)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> Maybe E
forall a. a -> Maybe a
Just (E -> S (Maybe E)) -> S E -> S (Maybe E)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q E
e'
              [S (Maybe E)]
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity [Maybe E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ if Q -> Bool
nullable Q
q then (ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac else Q -> S (Maybe E)
act' Q
q | Q
q <- [Q]
qs ]
        let qts :: [QT]
qts = (E -> QT) -> [E] -> [QT]
forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT ([Maybe E] -> [E]
forall a. [Maybe a] -> [a]
catMaybes [Maybe E]
cqts)
            eLoop' :: E
eLoop' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                       Just WinTags
wtags -> WinTags -> E -> E
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags E
eLoop -- nullable without tests; avoid getQT
                       Maybe WinTags
Nothing -> QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
qIn) (E -> QT
getQT E
eLoop) -- suspect this of duplicating some tags with nullQ qIn
            mAccepting' :: Maybe E
mAccepting' = if [QT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
                            then (E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
qIn) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT) Maybe E
mAccepting -- suspect this of duplicating some tags with nullQ qIn
                            else E -> Maybe E
forall a. a -> Maybe a
Just (QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ (QT -> QT -> QT) -> [QT] -> QT
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
            mQNFA' :: Maybe ([(Tag, TagTask)], QNFA)
mQNFA' = if [QT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                              Just WinTags
wtags -> (([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA))
-> Maybe ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> ([(Tag, TagTask)], QNFA) -> ([(Tag, TagTask)], QNFA)
forall a. WinTags -> ([(Tag, TagTask)], a) -> ([(Tag, TagTask)], a)
addWinTags WinTags
wtags) Maybe ([(Tag, TagTask)], QNFA)
mQNFA
                              Maybe WinTags
Nothing -> Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing
                       else Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing
        ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (E
eLoop',Maybe E
mAccepting',Maybe ([(Tag, TagTask)], QNFA)
mQNFA')

      Star Maybe Tag
mOrbit [Tag]
resetTheseOrbits Bool
mayFirstBeNull Q
q -> do
        let (ac0 :: ActCont
ac0@(E
_,Maybe E
mAccepting0,Maybe ([(Tag, TagTask)], QNFA)
_),Bool
clear) =
              if Q -> Bool
notNullable Q
q
                then (ActCont
ac,Bool
True)
                else if [Tag] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tag]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Tag -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Tag
mOrbit
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
                              Just [] -> (ActCont
ac,Bool
True)
                              Just WinTags
wtags -> (WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags ActCont
ac,Bool
False)
                              Maybe WinTags
_ -> let nQ :: E -> E
nQ = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT
                                   in ((E -> E
nQ E
eLoop,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing),Bool
False)
                       else let nQ :: E -> E
nQ = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag] -> QT -> QT
resetOrbitsQT [Tag]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> QT -> QT
enterOrbitQT Maybe Tag
mOrbit
                                     (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
leaveOrbit Maybe Tag
mOrbit
                            in ((E -> E
nQ E
eLoop,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing),Bool
False)
        if Q -> Bool
cannotAccept Q
q then ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac0 else mdo
          Maybe E
mChildAccepting <- Q -> ActCont -> S (Maybe E)
act Q
q (E
this,Maybe E
forall a. Maybe a
Nothing,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
          (thisAC :: ActCont
thisAC@(E
this,Maybe E
_,Maybe ([(Tag, TagTask)], QNFA)
_),ActCont
ansAC) <-
            case Maybe E
mChildAccepting of
              Maybe E
Nothing -> String
-> StateT
     (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (ActCont, ActCont)
forall a. String -> a
err (String
 -> StateT
      (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (ActCont, ActCont))
-> String
-> StateT
     (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (ActCont, ActCont)
forall a b. (a -> b) -> a -> b
$ String
"Weird pattern in getTransTagless/Star: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn)
              Just E
childAccepting -> do
                let childQT :: QT
childQT = [Tag] -> QT -> QT
resetOrbitsQT [Tag]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> QT -> QT
enterOrbitQT Maybe Tag
mOrbit (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> E -> QT
forall a b. (a -> b) -> a -> b
$ E
childAccepting
                    thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (ActCont -> QT) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (ActCont -> E) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Tag -> E -> E
leaveOrbit Maybe Tag
mOrbit (E -> E) -> (ActCont -> E) -> ActCont -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac
                    thisAccepting :: Maybe E
thisAccepting =
                      case Maybe E
mAccepting of
                        Just E
futureAccepting -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting
                        Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
                ActCont
thisAll <- if Q -> Bool
usesQNFA Q
q
                             then do QNFA
thisQNFA <- String -> QT -> S QNFA
newQNFA String
"actNullableTagless/Star" QT
thisQT
                                     ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> E
fromQNFA QNFA
thisQNFA, Maybe E
thisAccepting, ([(Tag, TagTask)], QNFA) -> Maybe ([(Tag, TagTask)], QNFA)
forall a. a -> Maybe a
Just ([(Tag, TagTask)]
forall a. Monoid a => a
mempty,QNFA
thisQNFA))
                             else ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT QT
thisQT, Maybe E
thisAccepting, Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
                let skipQT :: QT
skipQT = QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (ActCont -> QT) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (ActCont -> E) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac0  -- for first iteration the continuation uses NullView
                    skipAccepting :: Maybe E
skipAccepting =
                      case Maybe E
mAccepting0 of
                        Just E
futureAccepting0 -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting0
                        Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
                    ansAll :: (E, Maybe E, Maybe a)
ansAll = (QT -> E
fromQT QT
skipQT, Maybe E
skipAccepting, Maybe a
forall a. Maybe a
Nothing)
                (ActCont, ActCont)
-> StateT
     (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity (ActCont, ActCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont
thisAll,ActCont
forall a. (E, Maybe E, Maybe a)
ansAll)
          ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
mayFirstBeNull then (if Bool
clear then ActCont
thisAC else ActCont
ansAC)
                    else ActCont
thisAC)
      NonEmpty Q
q -> String -> S ActCont -> S ActCont
forall a. String -> a -> a
ecart (String
"\n> actNullableTagless/NonEmpty"String -> String -> String
forall a. [a] -> [a] -> [a]
++Q -> String
forall a. Show a => a -> String
show Q
qIn) (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
        -- We *know* that q is nullable from Pattern and CorePattern checks, but assert here anyway
        Bool
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (String -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a. String -> a
err (String
 -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ())
-> String
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))
        Bool
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (String -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a. String -> a
err (String
 -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ())
-> String
-> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn))

        {- This is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -}
        let (E
clearE,Maybe E
_,Maybe ([(Tag, TagTask)], QNFA)
_) = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                             Just [] -> ActCont
ac
                             Just WinTags
_wtags -> ActCont
ac -- addWinTagsAC wtags ac XXX was duplicating tags
                             Maybe WinTags
Nothing -> String -> ActCont
forall a. String -> a
err (String -> ActCont) -> String -> ActCont
forall a b. (a -> b) -> a -> b
$ String
"actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn)
        (E
_,Maybe E
mChildAccepting,Maybe ([(Tag, TagTask)], QNFA)
_) <- Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac
        case Maybe E
mChildAccepting of
          Maybe E
Nothing -> String -> S ActCont
forall a. String -> a
err  (String -> S ActCont) -> String -> S ActCont
forall a b. (a -> b) -> a -> b
$ String
"Weird pattern in actNullableTagless/NonEmpty: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn)
            -- cannotAccept q checked for and excluded the above condition (and starTrans!)
          Just E
childAccepting -> do
            let childQT :: QT
childQT = E -> QT
getQT E
childAccepting
                thisAccepting :: Maybe E
thisAccepting = case Maybe E
mAccepting of
                                  Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
                                  Just E
futureAcceptingE -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAcceptingE
                                  -- I _think_ there is no need for mergeQT_2nd in the above.
            ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (E
clearE,Maybe E
thisAccepting,Maybe ([(Tag, TagTask)], QNFA)
forall a. Maybe a
Nothing)
      P
_ -> String -> S ActCont
forall a. String -> a
err (String -> S ActCont) -> String -> S ActCont
forall a b. (a -> b) -> a -> b
$ String
"This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Q) -> String
forall a. Show a => a -> String
show (Q
qTop,Q
qIn)

  -- This is applied directly to any qt immediately before passing to mergeQT
  resetOrbitsQT :: [Tag] -> QT -> QT
  resetOrbitsQT :: [Tag] -> QT -> QT
resetOrbitsQT | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (QT -> QT) -> [Tag] -> QT -> QT
forall a b. a -> b -> a
const QT -> QT
forall a. a -> a
id
                | Bool
otherwise = (\[Tag]
tags -> WinTags -> QT -> QT
prependTags' [(Tag
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetOrbitTask)|Tag
tag<-[Tag]
tags])

  enterOrbitQT :: Maybe Tag -> QT -> QT
  enterOrbitQT :: Maybe Tag -> QT -> QT
enterOrbitQT | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (QT -> QT) -> Maybe Tag -> QT -> QT
forall a b. a -> b -> a
const QT -> QT
forall a. a -> a
id
               | Bool
otherwise = (QT -> QT) -> (Tag -> QT -> QT) -> Maybe Tag -> QT -> QT
forall b a. b -> (a -> b) -> Maybe a -> b
maybe QT -> QT
forall a. a -> a
id (\Tag
tag->WinTags -> QT -> QT
prependTags' [(Tag
tag,TagTask -> TagUpdate
PreUpdate TagTask
EnterOrbitTask)])

  leaveOrbit :: Maybe Tag -> E -> E
  leaveOrbit :: Maybe Tag -> E -> E
leaveOrbit | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (E -> E) -> Maybe Tag -> E -> E
forall a b. a -> b -> a
const E -> E
forall a. a -> a
id
             | Bool
otherwise = (E -> E) -> (Tag -> E -> E) -> Maybe Tag -> E -> E
forall b a. b -> (a -> b) -> Maybe a -> b
maybe E -> E
forall a. a -> a
id (\Tag
tag->(\([(Tag, TagTask)]
tags,Either QNFA QT
cont)->((Tag
tag,TagTask
LeaveOrbitTask)(Tag, TagTask) -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall a. a -> [a] -> [a]
:[(Tag, TagTask)]
tags,Either QNFA QT
cont)))

  -- 'newTrans' is the only place where PostUpdate is used and is only called from getTrans/OneChar
  --  and is the only caller of 'acceptTrans' to make QT/Simple nodes.
  newTrans :: String    -- debugging string for when a newQNFA is allocated
           -> [Tag]     -- which tags get ResetGroupStopTask in this transition (PreUpdate)
           -> Maybe Tag -- maybe one TagTask to update before incrementing the offset (PreUpdate)
           -> Pattern   -- the one character accepting Pattern of this transition
           -> E         -- the continuation state, reified to a QNFA, of after this Pattern
                       -- The fst part of the E is consumed here as a TagTask (PostUpdate)
           -> S E       -- the continuation state, as a QT, of before this Pattern
  newTrans :: String -> [Tag] -> Maybe Tag -> Pattern -> E -> S E
newTrans String
s [Tag]
resets Maybe Tag
mPre Pattern
pat ([(Tag, TagTask)]
tags,Either QNFA QT
cont) = do
    Tag
i <- case Either QNFA QT
cont of
           Left QNFA
qnfa -> Tag -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity Tag
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Tag
q_id QNFA
qnfa)     -- strictQNFA ZZZ no help
           Right QT
qt -> do QNFA
qnfa <- String -> QT -> S QNFA
newQNFA String
s QT
qt -- strictQT ZZZ no help
                          Tag -> StateT (Tag, [(Tag, QNFA)] -> [(Tag, QNFA)]) Identity Tag
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Tag
q_id QNFA
qnfa)
    let post :: WinTags
post = (TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PostUpdate [(Tag, TagTask)]
tags
        pre :: WinTags
pre  = (TagTask -> TagUpdate) -> [(Tag, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate ([(Tag
tag,TagTask
ResetGroupStopTask) | Tag
tag<-[Tag]
resets] [(Tag, TagTask)] -> [(Tag, TagTask)] -> [(Tag, TagTask)]
forall a. [a] -> [a] -> [a]
++ [(Tag, TagTask)]
-> (Tag -> [(Tag, TagTask)]) -> Maybe Tag -> [(Tag, TagTask)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Tag
tag -> [(Tag
tag,TagTask
TagTask)]) Maybe Tag
mPre)
    E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QT -> E) -> QT -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> S E) -> QT -> S E
forall a b. (a -> b) -> a -> b
$ WinTags -> Pattern -> WinTags -> Tag -> QT
acceptTrans WinTags
pre Pattern
pat WinTags
post Tag
i -- fromQT $ strictQT no help

  -- 'acceptTrans' is the sole creator of QT/Simple and is only called by getTrans/OneChar/newTrans
  acceptTrans :: TagList -> Pattern -> TagList -> Index -> QT
  acceptTrans :: WinTags -> Pattern -> WinTags -> Tag -> QT
acceptTrans WinTags
pre Pattern
pIn WinTags
post Tag
i =
    let target :: QTrans
target = Tag -> [TagCommand] -> QTrans
forall a. Tag -> a -> IntMap a
IMap.singleton Tag
i [(Pattern -> DoPa
getDoPa Pattern
pIn,WinTags
preWinTags -> WinTags -> WinTags
forall a. [a] -> [a] -> [a]
++WinTags
post)]
    in case Pattern
pIn of
         PChar DoPa
_ Char
char ->
           let trans :: CharMap QTrans
trans = QTrans -> String -> CharMap QTrans
toMap QTrans
target [Char
char]
           in Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PEscape DoPa
_ Char
char ->
           let trans :: CharMap QTrans
trans = QTrans -> String -> CharMap QTrans
toMap QTrans
target [Char
char]
           in Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PDot DoPa
_ -> Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
dotTrans, qt_other :: QTrans
qt_other = QTrans
target }
         PAny DoPa
_ PatternSet
ps ->
           let trans :: CharMap QTrans
trans = QTrans -> String -> CharMap QTrans
toMap QTrans
target (String -> CharMap QTrans)
-> (PatternSet -> String) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> String
forall a. Set a -> [a]
S.toAscList (Set Char -> String)
-> (PatternSet -> Set Char) -> PatternSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet (PatternSet -> CharMap QTrans) -> PatternSet -> CharMap QTrans
forall a b. (a -> b) -> a -> b
$ PatternSet
ps
           in Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PAnyNot DoPa
_ PatternSet
ps ->
           let trans :: CharMap QTrans
trans = QTrans -> String -> CharMap QTrans
toMap QTrans
forall a. Monoid a => a
mempty (String -> CharMap QTrans)
-> (PatternSet -> String) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> String
forall a. Set a -> [a]
S.toAscList (Set Char -> String)
-> (PatternSet -> Set Char) -> PatternSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> Set Char
addNewline (Set Char -> Set Char)
-> (PatternSet -> Set Char) -> PatternSet -> Set Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet (PatternSet -> CharMap QTrans) -> PatternSet -> CharMap QTrans
forall a b. (a -> b) -> a -> b
$ PatternSet
ps
           in Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
target }
         Pattern
_ -> String -> QT
forall a. String -> a
err (String
"Cannot acceptTrans pattern "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Q, Pattern) -> String
forall a. Show a => a -> String
show (Q
qTop,Pattern
pIn))
    where  -- Take a common destination and a sorted list of unique characters
           -- and create a map from those characters to the common destination
      toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]
            -> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])])
      toMap :: QTrans -> String -> CharMap QTrans
toMap QTrans
dest | CompOption -> Bool
caseSensitive CompOption
compOpt = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> (String -> IntMap QTrans) -> String -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Tag, QTrans)] -> IntMap QTrans
forall a. [(Tag, a)] -> IntMap a
IMap.fromDistinctAscList ([(Tag, QTrans)] -> IntMap QTrans)
-> (String -> [(Tag, QTrans)]) -> String -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Tag, QTrans)) -> String -> [(Tag, QTrans)]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Char -> Tag
ord Char
c,QTrans
dest))
                 | Bool
otherwise = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> (String -> IntMap QTrans) -> String -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Tag, QTrans)] -> IntMap QTrans
forall a. [(Tag, a)] -> IntMap a
IMap.fromList ([(Tag, QTrans)] -> IntMap QTrans)
-> (String -> [(Tag, QTrans)]) -> String -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(Tag, QTrans)] -> [(Tag, QTrans)])
-> [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a b. (a -> b) -> a -> b
$ [])
                               (([(Tag, QTrans)] -> [(Tag, QTrans)]) -> [(Tag, QTrans)])
-> (String -> [(Tag, QTrans)] -> [(Tag, QTrans)])
-> String
-> [(Tag, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
 -> ([(Tag, QTrans)] -> [(Tag, QTrans)])
 -> [(Tag, QTrans)]
 -> [(Tag, QTrans)])
-> ([(Tag, QTrans)] -> [(Tag, QTrans)])
-> String
-> [(Tag, QTrans)]
-> [(Tag, QTrans)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c [(Tag, QTrans)] -> [(Tag, QTrans)]
dl -> if Char -> Bool
isAlpha Char
c
                                                   then ([(Tag, QTrans)] -> [(Tag, QTrans)]
dl([(Tag, QTrans)] -> [(Tag, QTrans)])
-> ([(Tag, QTrans)] -> [(Tag, QTrans)])
-> [(Tag, QTrans)]
-> [(Tag, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Tag
ord (Char -> Char
toUpper Char
c),QTrans
dest)(Tag, QTrans) -> [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                           ([(Tag, QTrans)] -> [(Tag, QTrans)])
-> ([(Tag, QTrans)] -> [(Tag, QTrans)])
-> [(Tag, QTrans)]
-> [(Tag, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Tag
ord (Char -> Char
toLower Char
c),QTrans
dest)(Tag, QTrans) -> [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                        )
                                                   else ([(Tag, QTrans)] -> [(Tag, QTrans)]
dl([(Tag, QTrans)] -> [(Tag, QTrans)])
-> ([(Tag, QTrans)] -> [(Tag, QTrans)])
-> [(Tag, QTrans)]
-> [(Tag, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Tag
ord Char
c,QTrans
dest)(Tag, QTrans) -> [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a. a -> [a] -> [a]
:))
                                       ) [(Tag, QTrans)] -> [(Tag, QTrans)]
forall a. a -> a
id
      addNewline :: Set Char -> Set Char
addNewline | CompOption -> Bool
multiline CompOption
compOpt = Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
S.insert Char
'\n'
                 | Bool
otherwise = Set Char -> Set Char
forall a. a -> a
id
      dotTrans :: CharMap QTrans
dotTrans | CompOption -> Bool
multiline CompOption
compOpt = Char -> QTrans -> CharMap QTrans
forall a. Char -> a -> CharMap a
Map.singleton Char
'\n' QTrans
forall a. Monoid a => a
mempty
               | Bool
otherwise = CharMap QTrans
forall a. Monoid a => a
Mon.mempty

{-

prepend architecture becomes
prependTags :: TagTask -> [Tag] -> QT -> QT
which always uses PreUpdate and the same task for all the tags

qt_win seems to only allow PreUpdate so why keep the same type?


ADD ORPHAN ID check and make this a fatal error while testing

-}

-- | decodePatternSet cannot handle collating element and treats
-- equivalence classes as just their definition and nothing more.
decodePatternSet :: PatternSet -> S.Set Char
decodePatternSet :: PatternSet -> Set Char
decodePatternSet (PatternSet Maybe (Set Char)
msc Maybe (Set PatternSetCharacterClass)
mscc Maybe (Set PatternSetCollatingElement)
_ Maybe (Set PatternSetEquivalenceClass)
msec) =
  let baseMSC :: Set Char
baseMSC = Set Char -> (Set Char -> Set Char) -> Maybe (Set Char) -> Set Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Char
forall a. Set a
S.empty Set Char -> Set Char
forall a. a -> a
id Maybe (Set Char)
msc
      withMSCC :: Set Char
withMSCC = (Set Char -> Char -> Set Char) -> Set Char -> String -> Set Char
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Char -> Set Char -> Set Char) -> Set Char -> Char -> Set Char
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
S.insert) Set Char
baseMSC  (String
-> (Set PatternSetCharacterClass -> String)
-> Maybe (Set PatternSetCharacterClass)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((PatternSetCharacterClass -> String)
-> [PatternSetCharacterClass] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatternSetCharacterClass -> String
decodeCharacterClass ([PatternSetCharacterClass] -> String)
-> (Set PatternSetCharacterClass -> [PatternSetCharacterClass])
-> Set PatternSetCharacterClass
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PatternSetCharacterClass -> [PatternSetCharacterClass]
forall a. Set a -> [a]
S.toAscList) Maybe (Set PatternSetCharacterClass)
mscc)
      withMSEC :: Set Char
withMSEC = (Set Char -> Char -> Set Char) -> Set Char -> String -> Set Char
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Char -> Set Char -> Set Char) -> Set Char -> Char -> Set Char
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
S.insert) Set Char
withMSCC (String
-> (Set PatternSetEquivalenceClass -> String)
-> Maybe (Set PatternSetEquivalenceClass)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((PatternSetEquivalenceClass -> String)
-> [PatternSetEquivalenceClass] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatternSetEquivalenceClass -> String
unSEC ([PatternSetEquivalenceClass] -> String)
-> (Set PatternSetEquivalenceClass -> [PatternSetEquivalenceClass])
-> Set PatternSetEquivalenceClass
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PatternSetEquivalenceClass -> [PatternSetEquivalenceClass]
forall a. Set a -> [a]
S.toAscList) Maybe (Set PatternSetEquivalenceClass)
msec)
  in Set Char
withMSEC

-- | This returns the distinct ascending list of characters
-- represented by [: :] values in legalCharacterClasses; unrecognized
-- class names return an empty string
decodeCharacterClass :: PatternSetCharacterClass -> String
decodeCharacterClass :: PatternSetCharacterClass -> String
decodeCharacterClass (PatternSetCharacterClass String
s) =
  case String
s of
    String
"alnum" -> [Char
'0'..Char
'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z']
    String
"digit" -> [Char
'0'..Char
'9']
    String
"punct" -> [Char
'\33'..Char
'\47']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'\58'..Char
'\64']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'\91'..Char
'\95']String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\96"String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'\123'..Char
'\126']
    String
"alpha" -> [Char
'a'..Char
'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z']
    String
"graph" -> [Char
'\41'..Char
'\126']
    String
"space" -> String
"\t\n\v\f\r "
    String
"blank" -> String
"\t "
    String
"lower" -> [Char
'a'..Char
'z']
    String
"upper" -> [Char
'A'..Char
'Z']
    String
"cntrl" -> [Char
'\0'..Char
'\31']String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\127" -- with NUL
    String
"print" -> [Char
'\32'..Char
'\126']
    String
"xdigit" -> [Char
'0'..Char
'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'f']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'F']
    String
"word" -> [Char
'0'..Char
'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z']String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"
    String
_ -> []

{-
-- | This is the list of recognized [: :] character classes, others
-- are decoded as empty.
legalCharacterClasses :: [String]
legalCharacterClasses = ["alnum","digit","punct","alpha","graph"
  ,"space","blank","lower","upper","cntrl","print","xdigit","word"]

-}