-- 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 (soure,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
-- repesent 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 _ = a -> a
forall a. a -> a
id

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

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

qtwin,qtlose :: QT
-- qtwin is the continuation after matching the whole pattern.  It has
-- no futher transitions and sets tag #1 to the current position.
qtwin :: QT
qtwin = Simple :: WinTags -> CharMap QTrans -> QTrans -> QT
Simple {qt_win :: WinTags
qt_win=[(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, (GroupIndex, DoPa))
-> ((GroupIndex, Array GroupIndex QNFA), Array GroupIndex OP,
    Array GroupIndex [GroupInfo])
patternToNFA compOpt :: CompOption
compOpt pattern :: (Pattern, (GroupIndex, DoPa))
pattern =
  let (q :: Q
q,tags :: Array GroupIndex OP
tags,groups :: Array GroupIndex [GroupInfo]
groups) = CompOption
-> (Pattern, (GroupIndex, DoPa))
-> (Q, Array GroupIndex OP, Array GroupIndex [GroupInfo])
patternToQ CompOption
compOpt (Pattern, (GroupIndex, DoPa))
pattern
      msg :: String
msg = [String] -> String
unlines [ Q -> String
forall a. Show a => a -> String
show Q
q ]
  in String
-> ((GroupIndex, Array GroupIndex QNFA), Array GroupIndex OP,
    Array GroupIndex [GroupInfo])
-> ((GroupIndex, Array GroupIndex QNFA), Array GroupIndex OP,
    Array GroupIndex [GroupInfo])
forall a s. Show a => a -> s -> s
debug String
msg (CompOption -> Q -> (GroupIndex, Array GroupIndex QNFA)
qToNFA CompOption
compOpt Q
q,Array GroupIndex OP
tags,Array GroupIndex [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 sti :: EnumMap WhichTest (EnumSet DoPa)
sti,tags :: WinTags
tags):_)}) = 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 _ = 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 _ = 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 :: GroupIndex -> QT -> QNFA
mkQNFA i :: GroupIndex
i qt :: QT
qt = String -> QNFA -> QNFA
forall a s. Show a => a -> s -> s
debug ("\n>QNFA id="String -> String -> String
forall a. [a] -> [a] -> [a]
++GroupIndex -> String
forall a. Show a => a -> String
show GroupIndex
i) (QNFA -> QNFA) -> QNFA -> QNFA
forall a b. (a -> b) -> a -> b
$
  GroupIndex -> QT -> QNFA
QNFA GroupIndex
i (String -> QT -> QT
forall a s. Show a => a -> s -> s
debug ("\ngetting QT for "String -> String -> String
forall a. [a] -> [a] -> [a]
++GroupIndex -> String
forall a. Show a => a -> String
show GroupIndex
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 t :: 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 _ = 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
qt s :: 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 [] win :: QT
win = QT
win
applyNullViews nvs :: [(SetTestInfo, WinTags)]
nvs win :: 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 [] win :: QT
win = QT
win
preferNullViews nvs :: [(SetTestInfo, WinTags)]
nvs win :: 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 win :: QT
win lose :: QT
lose x :: (SetTestInfo, WinTags)
x@(SetTestInfo sti :: EnumMap WhichTest (EnumSet DoPa)
sti,tags :: WinTags
tags) = String -> QT -> QT
forall a s. Show a => a -> s -> s
debug ("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 _ [] w :: QT
w _ = QT
w -- no more dominating tests to fail to choose lose, so just choose win
      useTest (aTest :: WhichTest
aTest:tests :: [WhichTest]
tests) allD :: [(WhichTest, EnumSet DoPa)]
allD@((dTest :: WhichTest
dTest,dopas :: EnumSet DoPa
dopas):ds :: [(WhichTest, EnumSet DoPa)]
ds) w :: QT
w l :: QT
l =
        let (wA :: QT
wA,wB :: QT
wB,wD :: EnumSet DoPa
wD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
w
            (lA :: QT
lA,lB :: QT
lB,lD :: 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
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 [] _ _  _ = String -> QT
forall a. String -> a
err "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 (wt :: WhichTest
wt,dopa :: DoPa
dopa) qt :: 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
      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}
      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}
      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 argment'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 q1 :: QT
q1 q2 :: QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
                  | Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith (\_ w2 :: WinTags
w2 -> WinTags
w2) QT
q1 QT
q2

mergeAltQT :: QT -> QT -> QT
mergeAltQT q1 :: QT
q1 q2 :: 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 (\w1 :: WinTags
w1 w2 :: WinTags
w2 -> if WinTags -> Bool
noWin WinTags
w1 then WinTags
w2 else WinTags
w1) QT
q1 QT
q2
mergeQT :: QT -> QT -> QT
mergeQT q1 :: QT
q1 q2 :: 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 mergining
-- 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 mergeWins :: WinTags -> WinTags -> WinTags
mergeWins = QT -> QT -> QT
merge where
  merge :: QT -> QT -> QT
  merge :: QT -> QT -> QT
merge (Simple w1 :: WinTags
w1 t1 :: CharMap QTrans
t1 o1 :: QTrans
o1) (Simple w2 :: WinTags
w2 t2 :: CharMap QTrans
t2 o2 :: 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 _ _ a1 :: QT
a1 b1 :: 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 _ _ a2 :: QT
a2 b2 :: 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 wt1 :: WhichTest
wt1 ds1 :: EnumSet DoPa
ds1 a1 :: QT
a1 b1 :: QT
b1) t2 :: QT
t2@(Testing wt2 :: WhichTest
wt2 ds2 :: EnumSet DoPa
ds2 a2 :: QT
a2 b2 :: 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
      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)}
      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}
      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 t1 :: IntMap QTrans
t1) o1 :: QTrans
o1 (CharMap t2 :: IntMap QTrans
t2) o2 :: QTrans
o2 = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap ([(GroupIndex, QTrans)] -> IntMap QTrans
forall a. [(GroupIndex, a)] -> IntMap a
IMap.fromDistinctAscList ([(GroupIndex, QTrans)]
-> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
forall a. Ord a => [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(GroupIndex, QTrans)]
l1 [(GroupIndex, QTrans)]
l2)) where
    l1 :: [(GroupIndex, QTrans)]
l1 = IntMap QTrans -> [(GroupIndex, QTrans)]
forall a. IntMap a -> [(GroupIndex, a)]
IMap.toAscList IntMap QTrans
t1
    l2 :: [(GroupIndex, QTrans)]
l2 = IntMap QTrans -> [(GroupIndex, QTrans)]
forall a. IntMap a -> [(GroupIndex, a)]
IMap.toAscList IntMap QTrans
t2
    fuse :: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [] y :: [(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 x :: [(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@((xc :: a
xc,xa :: QTrans
xa):xs :: [(a, QTrans)]
xs) y :: [(a, QTrans)]
y@((yc :: a
yc,ya :: QTrans
ya):ys :: [(a, QTrans)]
ys) =
      case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
xc a
yc of
        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
        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
        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 GroupIndex -> QT -> QT
prependPreTag Nothing qt :: QT
qt = QT
qt
prependPreTag (Just tag :: GroupIndex
tag) qt :: QT
qt = WinTags -> QT -> QT
prependTags' [(GroupIndex
tag,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)] QT
qt

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

prependTags' :: TagList -> QT -> QT
prependTags' :: WinTags -> QT -> QT
prependTags' []  qt :: QT
qt = QT
qt
prependTags' tcs' :: 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' tcs' :: 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 (\(d :: a
d,tcs :: 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 s :: String
s qt :: QT
qt = do
  (thisI :: GroupIndex
thisI,oldQs :: [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)]
oldQs) <- StateT
  (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
  Identity
  (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
forall s (m :: * -> *). MonadState s m => m s
get
  let futureI :: GroupIndex
futureI = GroupIndex -> GroupIndex
forall a. Enum a => a -> a
succ GroupIndex
thisI in GroupIndex -> S QNFA -> S QNFA
forall a b. a -> b -> b
seq GroupIndex
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 (">newQNFA< "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++" : "String -> String -> String
forall a. [a] -> [a] -> [a]
++GroupIndex -> String
forall a. Show a => a -> String
show GroupIndex
thisI) (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ do
  let qnfa :: QNFA
qnfa = GroupIndex -> QT -> QNFA
mkQNFA GroupIndex
thisI QT
qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ
  (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      ())
-> (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a b. (a -> b) -> a -> b
$! (GroupIndex
futureI, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)]
oldQs ([(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
-> ([(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
-> [(GroupIndex, QNFA)]
-> [(GroupIndex, QNFA)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GroupIndex
thisI,QNFA
qnfa)(GroupIndex, QNFA) -> [(GroupIndex, QNFA)] -> [(GroupIndex, 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
qnfa = ([(GroupIndex, 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
qt = ([(GroupIndex, 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 _ x :: E
x@(_,Left _) = E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
x
asQNFA s :: String
s (tags :: [(GroupIndex, TagTask)]
tags,Right qt :: 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 ([(GroupIndex, 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 _ ([],Left qnfa :: QNFA
qnfa) = QNFA -> S QNFA
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa
getQNFA s :: String
s (tags :: [(GroupIndex, TagTask)]
tags,Left qnfa :: QNFA
qnfa) = String -> QT -> S QNFA
newQNFA String
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(GroupIndex, TagTask)]
tags) (QNFA -> QT
q_qt QNFA
qnfa))
getQNFA s :: String
s (tags :: [(GroupIndex, TagTask)]
tags,Right qt :: QT
qt) = String -> QT -> S QNFA
newQNFA String
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(GroupIndex, TagTask)]
tags) QT
qt)

-- Extract the QT from the E
getQT :: E -> QT
getQT :: E -> QT
getQT (tags :: [(GroupIndex, TagTask)]
tags,cont :: Either QNFA QT
cont) = WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate [(GroupIndex, 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 ti :: TestInfo
ti (tags :: [(GroupIndex, TagTask)]
tags,cont :: Either QNFA QT
cont) = ([(GroupIndex, 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) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks promote :: TagTask -> TagUpdate
promote tags :: [(GroupIndex, TagTask)]
tags = ((GroupIndex, TagTask) -> (GroupIndex, TagUpdate))
-> [(GroupIndex, TagTask)] -> WinTags
forall a b. (a -> b) -> [a] -> [b]
map (\(tag :: GroupIndex
tag,task :: TagTask
task) -> (GroupIndex
tag,TagTask -> TagUpdate
promote TagTask
task)) [(GroupIndex, TagTask)]
tags

-- only used in addWinTags
demoteTags :: TagList -> TagTasks
demoteTags :: WinTags -> [(GroupIndex, TagTask)]
demoteTags = ((GroupIndex, TagUpdate) -> (GroupIndex, TagTask))
-> WinTags -> [(GroupIndex, TagTask)]
forall a b. (a -> b) -> [a] -> [b]
map (GroupIndex, TagUpdate) -> (GroupIndex, TagTask)
forall a. (a, TagUpdate) -> (a, TagTask)
helper
  where helper :: (a, TagUpdate) -> (a, TagTask)
helper (tag :: a
tag,PreUpdate tt :: TagTask
tt) = (a
tag,TagTask
tt)
        helper (tag :: a
tag,PostUpdate tt :: 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
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags wtags :: WinTags
wtags (tags :: [(GroupIndex, TagTask)]
tags,cont :: a
cont) = (WinTags -> [(GroupIndex, TagTask)]
demoteTags WinTags
wtags [(GroupIndex, TagTask)]
-> [(GroupIndex, TagTask)] -> [(GroupIndex, TagTask)]
forall a. Monoid a => a -> a -> a
`mappend` [(GroupIndex, TagTask)]
tags
                               ,a
cont)

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

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

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

addGroupSets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)
addGroupSets :: [GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [] x :: ([(GroupIndex, TagTask)], a)
x = ([(GroupIndex, TagTask)], a)
x
addGroupSets tags :: [GroupIndex]
tags (tags' :: [(GroupIndex, TagTask)]
tags',cont :: a
cont) = (((GroupIndex, TagTask)
 -> [(GroupIndex, TagTask)] -> [(GroupIndex, TagTask)])
-> [(GroupIndex, TagTask)]
-> [(GroupIndex, TagTask)]
-> [(GroupIndex, TagTask)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [(GroupIndex, TagTask)]
tags' ([(GroupIndex, TagTask)] -> [(GroupIndex, TagTask)])
-> ([GroupIndex] -> [(GroupIndex, TagTask)])
-> [GroupIndex]
-> [(GroupIndex, TagTask)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupIndex -> (GroupIndex, TagTask))
-> [GroupIndex] -> [(GroupIndex, TagTask)]
forall a b. (a -> b) -> [a] -> [b]
map (\tag :: GroupIndex
tag -> (GroupIndex
tag,TagTask
SetGroupStopTask)) ([GroupIndex] -> [(GroupIndex, TagTask)])
-> [GroupIndex] -> [(GroupIndex, TagTask)]
forall a b. (a -> b) -> a -> b
$ [GroupIndex]
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 (_,_,Just (tags :: [(GroupIndex, TagTask)]
tags,qnfa :: QNFA
qnfa)) = ([(GroupIndex, TagTask)]
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)  -- consume optimized mQNFA value returned by Star
getE (eLoop :: E
eLoop,Just accepting :: E
accepting,_) = QT -> E
fromQT (QT -> QT -> QT
mergeQT (E -> QT
getQT E
eLoop) (E -> QT
getQT E
accepting))
getE (eLoop :: E
eLoop,Nothing,_) = E
eLoop

-- 2009: See coment 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 ti :: TestInfo
ti (e :: E
e,mE :: Maybe E
mE,_) = (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 ([(GroupIndex, TagTask)], QNFA)
forall a. Maybe a
Nothing)

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

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

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

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

addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC wtags :: WinTags
wtags (e :: E
e,mE :: Maybe E
mE,mQNFA :: Maybe ([(GroupIndex, TagTask)], QNFA)
mQNFA) = (WinTags -> E -> E
forall a.
WinTags
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, 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
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags WinTags
wtags) Maybe E
mE
                                  ,(([(GroupIndex, TagTask)], QNFA)
 -> ([(GroupIndex, TagTask)], QNFA))
-> Maybe ([(GroupIndex, TagTask)], QNFA)
-> Maybe ([(GroupIndex, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags
-> ([(GroupIndex, TagTask)], QNFA)
-> ([(GroupIndex, TagTask)], QNFA)
forall a.
WinTags
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags WinTags
wtags) Maybe ([(GroupIndex, 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 -> (GroupIndex, Array GroupIndex QNFA)
qToNFA compOpt :: CompOption
compOpt qTop :: Q
qTop = (QNFA -> GroupIndex
q_id QNFA
startingQNFA
                      ,(GroupIndex, GroupIndex)
-> [(GroupIndex, QNFA)] -> Array GroupIndex QNFA
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (0,GroupIndex -> GroupIndex
forall a. Enum a => a -> a
pred GroupIndex
lastIndex) ([(GroupIndex, QNFA)] -> [(GroupIndex, 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
  (startingQNFA :: QNFA
startingQNFA,(lastIndex :: GroupIndex
lastIndex,table :: [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)]
table)) =
    S QNFA
-> (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
-> (QNFA,
    (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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 "top level") (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
forall a. (GroupIndex, a -> a)
startState
  startState :: (GroupIndex, a -> a)
startState = (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 -> [GroupIndex]
preReset=[GroupIndex]
resets,postSet :: Q -> [GroupIndex]
postSet=[GroupIndex]
sets,preTag :: Q -> Maybe GroupIndex
preTag=Maybe GroupIndex
pre,postTag :: Q -> Maybe GroupIndex
postTag=Maybe GroupIndex
post,unQ :: Q -> P
unQ=P
pIn}) e :: E
e = String -> S E -> S E
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (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 pat :: Pattern
pat -> String -> [GroupIndex] -> Maybe GroupIndex -> Pattern -> E -> S E
newTrans "getTrans/OneChar" [GroupIndex]
resets Maybe GroupIndex
pre Pattern
pat (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> E -> E
addTag Maybe GroupIndex
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [GroupIndex]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      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
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupResets [GroupIndex]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> E -> E
addTag Maybe GroupIndex
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> E -> E
addTag Maybe GroupIndex
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [GroupIndex]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      Test ti :: 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
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupResets [GroupIndex]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> E -> E
addTag Maybe GroupIndex
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 GroupIndex -> E -> E
addTag Maybe GroupIndex
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [GroupIndex]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      _ -> 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
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupResets [GroupIndex]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> E -> E
addTag Maybe GroupIndex
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 GroupIndex -> E -> E
addTag Maybe GroupIndex
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [GroupIndex]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e)

  getTransTagless :: Q -> E -> S E
getTransTagless qIn :: Q
qIn e :: E
e = String -> S E -> S E
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
    case Q -> P
unQ Q
qIn of
      Seq q1 :: Q
q1 q2 :: 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] -> Q -> E -> S E
getTrans Q
q E
e
      Or qs :: [Q]
qs -> do
        [E]
eqts <- if Q -> Bool
usesQNFA Q
qIn
                  then do
                    E
eQNFA <- String -> E -> S E
asQNFA "getTransTagless/Or/usesQNFA" E
e
                    [S E]
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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 mOrbit :: Maybe GroupIndex
mOrbit resetTheseOrbits :: [GroupIndex]
resetTheseOrbits mayFirstBeNull :: Bool
mayFirstBeNull q :: Q
q ->
        -- mOrbit of Just implies varies q and childGroups q
        let (e' :: E
e',clear :: 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 [GroupIndex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupIndex]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe GroupIndex -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupIndex
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 tagList :: WinTags
tagList -> (WinTags -> E -> E
forall a.
WinTags
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags WinTags
tagList E
e,Bool
False) -- null of subpattern NOT same as skipping
                              _ -> (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
. [GroupIndex] -> QT -> QT
resetOrbitsQT [GroupIndex]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> QT -> QT
enterOrbitQT Maybe GroupIndex
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 GroupIndex -> E -> E
leaveOrbit Maybe GroupIndex
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
        (this :: E
this,ans :: E
ans) <- case Maybe QT
mqt of
                        Nothing -> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     (E, E)
forall a. String -> a
err ("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
qt -> do
                          let qt' :: QT
qt' = [GroupIndex] -> QT -> QT
resetOrbitsQT [GroupIndex]
resetTheseOrbits (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> QT -> QT
enterOrbitQT Maybe GroupIndex
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 GroupIndex -> E -> E
leaveOrbit Maybe GroupIndex
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 "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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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
q -> String -> S E -> S E
forall a. String -> a -> a
ecart ("\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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a. String -> a
err (String
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      ())
-> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a b. (a -> b) -> a -> b
$ "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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a. String -> a
err (String
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      ())
-> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a b. (a -> b) -> a -> b
$ "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 _wtags :: WinTags
_wtags -> E
e -- addWinTags wtags e  XXX was duplicating tags
                   Nothing -> String -> E
forall a. String -> a
err (String -> E) -> String -> E
forall a b. (a -> b) -> a -> b
$ "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
                   Nothing -> String -> E
forall a. String -> a
err ("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 -> 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'
      _ -> String -> S E
forall a. String -> a
err ("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 -> [GroupIndex]
preReset=[GroupIndex]
resets,postSet :: Q -> [GroupIndex]
postSet=[GroupIndex]
sets,preTag :: Q -> Maybe GroupIndex
preTag=Maybe GroupIndex
pre,postTag :: Q -> Maybe GroupIndex
postTag=Maybe GroupIndex
post}) eLoop :: E
eLoop | Q -> Bool
notNullable Q
qIn =
    String -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (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 (">< 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]
++" <>") (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 ([GroupIndex] -> QT -> QT
prependGroupResets [GroupIndex]
resets (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> QT -> QT
prependPreTag Maybe GroupIndex
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 GroupIndex -> E -> E
addTag Maybe GroupIndex
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> E -> E
forall a.
Show a =>
[GroupIndex]
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addGroupSets [GroupIndex]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
eLoop)
    
  inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStarNullableTagless qIn :: Q
qIn eLoop :: E
eLoop = String -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (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
      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] -> Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop
      Or qs :: [Q]
qs -> do
        [Maybe QT]
mqts <- if Q -> Bool
usesQNFA Q
qIn
                  then do E
eQNFA <- String -> E -> S E
asQNFA "inStarNullableTagless/Or/usesQNFA" E
eLoop
                          [S (Maybe QT)]
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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 q1 :: Q
q1 q2 :: Q
q2 -> do (_,meAcceptingOut :: Maybe E
meAcceptingOut,_) <- 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 ([(GroupIndex, 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 (_,meAcceptingOut :: Maybe E
meAcceptingOut,_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe ([(GroupIndex, 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 ("\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 (_,meAcceptingOut :: Maybe E
meAcceptingOut,_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe ([(GroupIndex, 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 ("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 qIn :: Q
qIn c :: 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 (">< 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]
++" <>") (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 -> [GroupIndex]
preReset=[GroupIndex]
resets,postSet :: Q -> [GroupIndex]
postSet=[GroupIndex]
sets,preTag :: Q -> Maybe GroupIndex
preTag=Maybe GroupIndex
pre,postTag :: Q -> Maybe GroupIndex
postTag=Maybe GroupIndex
post,unQ :: Q -> P
unQ=P
pIn}) ac :: ActCont
ac =
    String -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case P
pIn of
      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
. [GroupIndex] -> ActCont -> ActCont
addGroupResetsAC [GroupIndex]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> ActCont -> ActCont
addGroupSetsAC [GroupIndex]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
      Test ti :: 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
. [GroupIndex] -> ActCont -> ActCont
addGroupResetsAC [GroupIndex]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
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 GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> ActCont -> ActCont
addGroupSetsAC [GroupIndex]
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 ("OneChar cannot have nullable True ")
      _ -> 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
. [GroupIndex] -> ActCont -> ActCont
addGroupResetsAC [GroupIndex]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
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 GroupIndex -> ActCont -> ActCont
addTagAC Maybe GroupIndex
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> ActCont -> ActCont
addGroupSetsAC [GroupIndex]
sets (ActCont -> ActCont) -> ActCont -> ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac )

  actNullableTagless :: Q -> ActCont -> S ActCont
actNullableTagless qIn :: Q
qIn ac :: ActCont
ac@(eLoop :: E
eLoop,mAccepting :: Maybe E
mAccepting,mQNFA :: Maybe ([(GroupIndex, TagTask)], QNFA)
mQNFA) = String -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug (">< 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]
++" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      Seq q1 :: Q
q1 q2 :: 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] -> Q -> ActCont -> S ActCont
actNullableTagless Q
q ActCont
ac
      Or qs :: [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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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 "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
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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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 wtags :: WinTags
wtags -> WinTags -> E -> E
forall a.
WinTags
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags WinTags
wtags E
eLoop -- nullable without tests; avoid getQT
                       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 ([(GroupIndex, 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 wtags :: WinTags
wtags -> (([(GroupIndex, TagTask)], QNFA)
 -> ([(GroupIndex, TagTask)], QNFA))
-> Maybe ([(GroupIndex, TagTask)], QNFA)
-> Maybe ([(GroupIndex, TagTask)], QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags
-> ([(GroupIndex, TagTask)], QNFA)
-> ([(GroupIndex, TagTask)], QNFA)
forall a.
WinTags
-> ([(GroupIndex, TagTask)], a) -> ([(GroupIndex, TagTask)], a)
addWinTags WinTags
wtags) Maybe ([(GroupIndex, TagTask)], QNFA)
mQNFA
                              Nothing -> Maybe ([(GroupIndex, TagTask)], QNFA)
forall a. Maybe a
Nothing
                       else Maybe ([(GroupIndex, 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 ([(GroupIndex, TagTask)], QNFA)
mQNFA')

      Star mOrbit :: Maybe GroupIndex
mOrbit resetTheseOrbits :: [GroupIndex]
resetTheseOrbits mayFirstBeNull :: Bool
mayFirstBeNull q :: Q
q -> do
        let (ac0 :: ActCont
ac0@(_,mAccepting0 :: Maybe E
mAccepting0,_),clear :: Bool
clear) =
              if Q -> Bool
notNullable Q
q
                then (ActCont
ac,Bool
True)
                else if [GroupIndex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupIndex]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe GroupIndex -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupIndex
mOrbit
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
                              Just [] -> (ActCont
ac,Bool
True)
                              Just wtags :: WinTags
wtags -> (WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags ActCont
ac,Bool
False)
                              _ -> 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 ([(GroupIndex, 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
. [GroupIndex] -> QT -> QT
resetOrbitsQT [GroupIndex]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> QT -> QT
enterOrbitQT Maybe GroupIndex
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 GroupIndex -> E -> E
leaveOrbit Maybe GroupIndex
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 ([(GroupIndex, 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 ([(GroupIndex, TagTask)], QNFA)
forall a. Maybe a
Nothing)
          (thisAC :: ActCont
thisAC@(this :: E
this,_,_),ansAC :: ActCont
ansAC) <- 
            case Maybe E
mChildAccepting of
              Nothing -> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     (ActCont, ActCont)
forall a. String -> a
err (String
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      (ActCont, ActCont))
-> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     (ActCont, ActCont)
forall a b. (a -> b) -> a -> b
$ "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 childAccepting :: E
childAccepting -> do
                let childQT :: QT
childQT = [GroupIndex] -> QT -> QT
resetOrbitsQT [GroupIndex]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> QT -> QT
enterOrbitQT Maybe GroupIndex
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 GroupIndex -> E -> E
leaveOrbit Maybe GroupIndex
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 futureAccepting :: 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
                        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 "actNullableTagless/Star" QT
thisQT
                                     ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> E
fromQNFA QNFA
thisQNFA, Maybe E
thisAccepting, ([(GroupIndex, TagTask)], QNFA)
-> Maybe ([(GroupIndex, TagTask)], QNFA)
forall a. a -> Maybe a
Just ([(GroupIndex, 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 ([(GroupIndex, 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 futureAccepting0 :: 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
                        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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, 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
q -> String -> S ActCont -> S ActCont
forall a. String -> a -> a
ecart ("\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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a. String -> a
err (String
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      ())
-> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a b. (a -> b) -> a -> b
$ "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
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a. String -> a
err (String
 -> StateT
      (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
      Identity
      ())
-> String
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     ()
forall a b. (a -> b) -> a -> b
$ "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 (clearE :: E
clearE,_,_) = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                             Just [] -> ActCont
ac
                             Just _wtags :: WinTags
_wtags -> ActCont
ac -- addWinTagsAC wtags ac XXX was duplicating tags
                             Nothing -> String -> ActCont
forall a. String -> a
err (String -> ActCont) -> String -> ActCont
forall a b. (a -> b) -> a -> b
$ "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)
        (_,mChildAccepting :: Maybe E
mChildAccepting,_) <- Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac
        case Maybe E
mChildAccepting of
          Nothing -> String -> S ActCont
forall a. String -> a
err  (String -> S ActCont) -> String -> S ActCont
forall a b. (a -> b) -> a -> b
$ "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 childAccepting :: E
childAccepting -> do
            let childQT :: QT
childQT = E -> QT
getQT E
childAccepting
                thisAccepting :: Maybe E
thisAccepting = case Maybe E
mAccepting of
                                  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 futureAcceptingE :: 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 ([(GroupIndex, TagTask)], QNFA)
forall a. Maybe a
Nothing)
      _ -> String -> S ActCont
forall a. String -> a
err (String -> S ActCont) -> String -> S ActCont
forall a b. (a -> b) -> a -> b
$ "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 :: [GroupIndex] -> QT -> QT
resetOrbitsQT | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (QT -> QT) -> [GroupIndex] -> QT -> QT
forall a b. a -> b -> a
const QT -> QT
forall a. a -> a
id
                | Bool
otherwise = (\tags :: [GroupIndex]
tags -> WinTags -> QT -> QT
prependTags' [(GroupIndex
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetOrbitTask)|GroupIndex
tag<-[GroupIndex]
tags])

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

  leaveOrbit :: Maybe Tag -> E -> E
  leaveOrbit :: Maybe GroupIndex -> E -> E
leaveOrbit | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (E -> E) -> Maybe GroupIndex -> E -> E
forall a b. a -> b -> a
const E -> E
forall a. a -> a
id
             | Bool
otherwise = (E -> E) -> (GroupIndex -> E -> E) -> Maybe GroupIndex -> E -> E
forall b a. b -> (a -> b) -> Maybe a -> b
maybe E -> E
forall a. a -> a
id (\tag :: GroupIndex
tag->(\(tags :: [(GroupIndex, TagTask)]
tags,cont :: Either QNFA QT
cont)->((GroupIndex
tag,TagTask
LeaveOrbitTask)(GroupIndex, TagTask)
-> [(GroupIndex, TagTask)] -> [(GroupIndex, TagTask)]
forall a. a -> [a] -> [a]
:[(GroupIndex, 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 -> [GroupIndex] -> Maybe GroupIndex -> Pattern -> E -> S E
newTrans s :: String
s resets :: [GroupIndex]
resets mPre :: Maybe GroupIndex
mPre pat :: Pattern
pat (tags :: [(GroupIndex, TagTask)]
tags,cont :: Either QNFA QT
cont) = do
    GroupIndex
i <- case Either QNFA QT
cont of
           Left qnfa :: QNFA
qnfa -> GroupIndex
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     GroupIndex
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> GroupIndex
q_id QNFA
qnfa)     -- strictQNFA ZZZ no help
           Right qt :: QT
qt -> do QNFA
qnfa <- String -> QT -> S QNFA
newQNFA String
s QT
qt -- strictQT ZZZ no help
                          GroupIndex
-> StateT
     (GroupIndex, [(GroupIndex, QNFA)] -> [(GroupIndex, QNFA)])
     Identity
     GroupIndex
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> GroupIndex
q_id QNFA
qnfa)
    let post :: WinTags
post = (TagTask -> TagUpdate) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PostUpdate [(GroupIndex, TagTask)]
tags
        pre :: WinTags
pre  = (TagTask -> TagUpdate) -> [(GroupIndex, TagTask)] -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate ([(GroupIndex
tag,TagTask
ResetGroupStopTask) | GroupIndex
tag<-[GroupIndex]
resets] [(GroupIndex, TagTask)]
-> [(GroupIndex, TagTask)] -> [(GroupIndex, TagTask)]
forall a. [a] -> [a] -> [a]
++ [(GroupIndex, TagTask)]
-> (GroupIndex -> [(GroupIndex, TagTask)])
-> Maybe GroupIndex
-> [(GroupIndex, TagTask)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\tag :: GroupIndex
tag -> [(GroupIndex
tag,TagTask
TagTask)]) Maybe GroupIndex
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 -> GroupIndex -> QT
acceptTrans WinTags
pre Pattern
pat WinTags
post GroupIndex
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 -> GroupIndex -> QT
acceptTrans pre :: WinTags
pre pIn :: Pattern
pIn post :: WinTags
post i :: GroupIndex
i =
    let target :: QTrans
target = GroupIndex -> [TagCommand] -> QTrans
forall a. GroupIndex -> a -> IntMap a
IMap.singleton GroupIndex
i [(Pattern -> DoPa
getDoPa Pattern
pIn,WinTags
preWinTags -> WinTags -> WinTags
forall a. [a] -> [a] -> [a]
++WinTags
post)]
    in case Pattern
pIn of
         PChar _ char :: 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 _ char :: 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 _ -> 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 _ ps :: 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 _ ps :: 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 }
         _ -> String -> QT
forall a. String -> a
err ("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 chraceters
           -- 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 dest :: 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
. [(GroupIndex, QTrans)] -> IntMap QTrans
forall a. [(GroupIndex, a)] -> IntMap a
IMap.fromDistinctAscList ([(GroupIndex, QTrans)] -> IntMap QTrans)
-> (String -> [(GroupIndex, QTrans)]) -> String -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (GroupIndex, QTrans)) -> String -> [(GroupIndex, QTrans)]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: Char
c -> (Char -> GroupIndex
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
. [(GroupIndex, QTrans)] -> IntMap QTrans
forall a. [(GroupIndex, a)] -> IntMap a
IMap.fromList ([(GroupIndex, QTrans)] -> IntMap QTrans)
-> (String -> [(GroupIndex, QTrans)]) -> String -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
forall a b. (a -> b) -> a -> b
$ []) 
                               (([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
 -> [(GroupIndex, QTrans)])
-> (String -> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> String
-> [(GroupIndex, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
 -> ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
 -> [(GroupIndex, QTrans)]
 -> [(GroupIndex, QTrans)])
-> ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> String
-> [(GroupIndex, QTrans)]
-> [(GroupIndex, QTrans)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\c :: Char
c dl :: [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
dl -> if Char -> Bool
isAlpha Char
c
                                                   then ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
dl([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> [(GroupIndex, QTrans)]
-> [(GroupIndex, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> GroupIndex
ord (Char -> Char
toUpper Char
c),QTrans
dest)(GroupIndex, QTrans)
-> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                           ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> [(GroupIndex, QTrans)]
-> [(GroupIndex, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> GroupIndex
ord (Char -> Char
toLower Char
c),QTrans
dest)(GroupIndex, QTrans)
-> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                        )
                                                   else ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
dl([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> ([(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)])
-> [(GroupIndex, QTrans)]
-> [(GroupIndex, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> GroupIndex
ord Char
c,QTrans
dest)(GroupIndex, QTrans)
-> [(GroupIndex, QTrans)] -> [(GroupIndex, QTrans)]
forall a. a -> [a] -> [a]
:))
                                       ) [(GroupIndex, QTrans)] -> [(GroupIndex, 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 '\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 '\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 msc :: Maybe (Set Char)
msc mscc :: Maybe (Set PatternSetCharacterClass)
mscc _ msec :: 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 disctince ascending list of characters
-- represented by [: :] values in legalCharacterClasses; unrecognized
-- class names return an empty string
decodeCharacterClass :: PatternSetCharacterClass -> String
decodeCharacterClass :: PatternSetCharacterClass -> String
decodeCharacterClass (PatternSetCharacterClass s :: String
s) =
  case String
s of
    "alnum" -> ['0'..'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++['a'..'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++['A'..'Z']
    "digit" -> ['0'..'9']
    "punct" -> ['\33'..'\47']String -> String -> String
forall a. [a] -> [a] -> [a]
++['\58'..'\64']String -> String -> String
forall a. [a] -> [a] -> [a]
++['\91'..'\95']String -> String -> String
forall a. [a] -> [a] -> [a]
++"\96"String -> String -> String
forall a. [a] -> [a] -> [a]
++['\123'..'\126']
    "alpha" -> ['a'..'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++['A'..'Z']
    "graph" -> ['\41'..'\126']
    "space" -> "\t\n\v\f\r "
    "blank" -> "\t "
    "lower" -> ['a'..'z']
    "upper" -> ['A'..'Z']
    "cntrl" -> ['\0'..'\31']String -> String -> String
forall a. [a] -> [a] -> [a]
++"\127" -- with NUL
    "print" -> ['\32'..'\126']
    "xdigit" -> ['0'..'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++['a'..'f']String -> String -> String
forall a. [a] -> [a] -> [a]
++['A'..'F']
    "word" -> ['0'..'9']String -> String -> String
forall a. [a] -> [a] -> [a]
++['a'..'z']String -> String -> String
forall a. [a] -> [a] -> [a]
++['A'..'Z']String -> String -> String
forall a. [a] -> [a] -> [a]
++"_"
    _ -> []

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

-}