-- 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 :: forall a. [Char] -> a -> a
ecart [Char]
_ = a -> a
forall a. a -> a
id

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

debug :: (Show a) => a -> s -> s
debug :: forall a s. Show a => a -> s -> s
debug a
_ 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 :: TagList -> CharMap QTrans -> QTrans -> QT
Simple {qt_win :: TagList
qt_win=[(Key
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 :: TagList -> CharMap QTrans -> QTrans -> QT
Simple {qt_win :: TagList
qt_win=TagList
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, (Key, DoPa))
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
patternToNFA CompOption
compOpt (Pattern, (Key, DoPa))
pattern =
  let (Q
q,Array Key OP
tags,Array Key [GroupInfo]
groups) = CompOption
-> (Pattern, (Key, DoPa))
-> (Q, Array Key OP, Array Key [GroupInfo])
patternToQ CompOption
compOpt (Pattern, (Key, DoPa))
pattern
      msg :: [Char]
msg = [[Char]] -> [Char]
unlines [ Q -> [Char]
forall a. Show a => a -> [Char]
show Q
q ]
  in [Char]
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
forall a s. Show a => a -> s -> s
debug [Char]
msg (CompOption -> Q -> (Key, Array Key QNFA)
qToNFA CompOption
compOpt Q
q,Array Key OP
tags,Array Key [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, TagList)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(SetTestInfo, TagList)] -> Bool)
-> (Q -> [(SetTestInfo, TagList)]) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(SetTestInfo, TagList)]
nullQ

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

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

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

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

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

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

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

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

-- This is used to view "win" only through NullView, and is used in
-- processing Or.
applyNullViews :: NullView -> QT -> QT
applyNullViews :: [(SetTestInfo, TagList)] -> QT -> QT
applyNullViews [] QT
win = QT
win
applyNullViews [(SetTestInfo, TagList)]
nvs QT
win = (QT -> (SetTestInfo, TagList) -> QT)
-> QT -> [(SetTestInfo, TagList)] -> QT
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, TagList) -> QT
dominate QT
win) QT
qtlose ([(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)])
-> [(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
cleanNullView [(SetTestInfo, TagList)]
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, TagList)] -> QT -> QT
preferNullViews [] QT
win = QT
win
preferNullViews [(SetTestInfo, TagList)]
nvs QT
win = (QT -> (SetTestInfo, TagList) -> QT)
-> QT -> [(SetTestInfo, TagList)] -> QT
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, TagList) -> QT
dominate QT
win) QT
win ([(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)])
-> [(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, TagList)] -> [(SetTestInfo, TagList)]
cleanNullView [(SetTestInfo, TagList)]
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, TagList) -> QT
dominate QT
win QT
lose x :: (SetTestInfo, TagList)
x@(SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,TagList
tags) = [Char] -> QT -> QT
forall a s. Show a => a -> s -> s
debug ([Char]
"dominate "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(SetTestInfo, TagList) -> [Char]
forall a. Show a => a -> [Char]
show (SetTestInfo, TagList)
x) (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
  let -- The winning states are reached through the SetTag
      win' :: QT
win' = TagList -> QT -> QT
prependTags' TagList
tags QT
win
      -- get the SetTestInfo 
      winTests :: EnumSet WhichTest
winTests = QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
win (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
forall a. Monoid a => a
mempty
      allTests :: EnumSet WhichTest
allTests = (QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
lose (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
winTests) EnumSet WhichTest -> EnumSet WhichTest -> EnumSet WhichTest
forall a. Monoid a => a -> a -> a
`mappend` (EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest
forall key a. Enum key => EnumMap key a -> EnumSet key
EMap.keysSet EnumMap WhichTest (EnumSet DoPa)
sti)
      -- The first and second arguments of useTest are sorted
      -- At all times the second argument of useTest is a subset of the first
      useTest :: [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
_ [] QT
w QT
_ = QT
w -- no more dominating tests to fail to choose lose, so just choose win
      useTest (WhichTest
aTest:[WhichTest]
tests) allD :: [(WhichTest, EnumSet DoPa)]
allD@((WhichTest
dTest,EnumSet DoPa
dopas):[(WhichTest, EnumSet DoPa)]
ds) QT
w QT
l =
        let (QT
wA,QT
wB,EnumSet DoPa
wD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
w
            (QT
lA,QT
lB,EnumSet DoPa
lD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
l
            branches :: QT -> (QT, QT, EnumSet DoPa)
branches qt :: QT
qt@(Testing {}) | WhichTest
aTestWhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
==QT -> WhichTest
qt_test QT
qt = (QT -> QT
qt_a QT
qt,QT -> QT
qt_b QT
qt,QT -> EnumSet DoPa
qt_dopas QT
qt)
            branches QT
qt = (QT
qt,QT
qt,EnumSet DoPa
forall a. Monoid a => a
mempty)
        in if WhichTest
aTest WhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
== WhichTest
dTest
             then Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = (EnumSet DoPa
dopas EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
wD) EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
                          ,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
ds QT
wA QT
lA
                          ,qt_b :: QT
qt_b = QT
lB}
             else Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa
wD EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
                          ,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wA QT
lA
                          ,qt_b :: QT
qt_b = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wB QT
lB}
      useTest [] [(WhichTest, EnumSet DoPa)]
_ QT
_  QT
_ = [Char] -> QT
forall a. [Char] -> a
err [Char]
"This case in dominate.useText cannot happen: second argument would have to have been null and that is checked before this case"
  in [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest (EnumSet WhichTest -> [WhichTest]
forall e. Enum e => EnumSet e -> [e]
Set.toList EnumSet WhichTest
allTests) (EnumMap WhichTest (EnumSet DoPa) -> [(WhichTest, EnumSet DoPa)]
forall key a. Enum key => EnumMap key a -> [(key, a)]
EMap.assocs EnumMap WhichTest (EnumSet DoPa)
sti) QT
win' QT
lose

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

-- Three ways to merge a pair of QT's varying how winning transitions
-- are handled.
--
-- mergeQT_2nd is used by the NonEmpty case and always discards the
-- first argument's win and uses the second 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 QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
                  | Bool
otherwise = (TagList -> TagList -> TagList) -> QT -> QT -> QT
mergeQTWith (\TagList
_ TagList
w2 -> TagList
w2) QT
q1 QT
q2

mergeAltQT :: QT -> QT -> QT
mergeAltQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2  -- prefer winning with w1 then with w2
                 | Bool
otherwise = (TagList -> TagList -> TagList) -> QT -> QT -> QT
mergeQTWith (\TagList
w1 TagList
w2 -> if TagList -> Bool
noWin TagList
w1 then TagList
w2 else TagList
w1) QT
q1 QT
q2
mergeQT :: QT -> QT -> QT
mergeQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2  -- union wins
              | QT -> Bool
nullQT QT
q2 = QT
q1  -- union wins
              | Bool
otherwise = (TagList -> TagList -> TagList) -> QT -> QT -> QT
mergeQTWith TagList -> TagList -> TagList
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 :: (TagList -> TagList -> TagList) -> QT -> QT -> QT
mergeQTWith TagList -> TagList -> TagList
mergeWins = QT -> QT -> QT
merge where
  merge :: QT -> QT -> QT
  merge :: QT -> QT -> QT
merge (Simple TagList
w1 CharMap QTrans
t1 QTrans
o1) (Simple TagList
w2 CharMap QTrans
t2 QTrans
o2) =
    let w' :: TagList
w' = TagList -> TagList -> TagList
mergeWins TagList
w1 TagList
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 TagList -> CharMap QTrans -> QTrans -> QT
Simple TagList
w' CharMap QTrans
t' QTrans
o'
  merge t1 :: QT
t1@(Testing WhichTest
_ EnumSet DoPa
_ QT
a1 QT
b1) s2 :: QT
s2@(Simple {}) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    QT
t1 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
a1 QT
s2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
b1 QT
s2)}
  merge s1 :: QT
s1@(Simple {}) t2 :: QT
t2@(Testing WhichTest
_ EnumSet DoPa
_ QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    QT
t2 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
s1 QT
a2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
s1 QT
b2)}
  merge t1 :: QT
t1@(Testing WhichTest
wt1 EnumSet DoPa
ds1 QT
a1 QT
b1) t2 :: QT
t2@(Testing WhichTest
wt2 EnumSet DoPa
ds2 QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
    case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt1 WhichTest
wt2 of
      Ordering
LT -> QT
t1 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
a1 QT
t2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
b1 QT
t2)}
      Ordering
EQ -> Testing :: WhichTest -> EnumSet DoPa -> QT -> QT -> QT
Testing {qt_test :: WhichTest
qt_test = WhichTest
wt1 -- same as wt2
                    ,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
mappend EnumSet DoPa
ds1 EnumSet DoPa
ds2
                    ,qt_a :: QT
qt_a = QT -> QT -> QT
merge QT
a1 QT
a2
                    ,qt_b :: QT
qt_b = QT -> QT -> QT
merge QT
b1 QT
b2}
      Ordering
GT -> QT
t2 {qt_a :: QT
qt_a=(QT -> QT -> QT
merge QT
t1 QT
a2), qt_b :: QT
qt_b=(QT -> QT -> QT
merge QT
t1 QT
b2)}

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

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

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

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

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

prependTags' :: TagList -> QT -> QT
prependTags' :: TagList -> QT -> QT
prependTags' []  QT
qt = QT
qt
prependTags' TagList
tcs' qt :: QT
qt@(Testing {}) = QT
qt { qt_a :: QT
qt_a = TagList -> QT -> QT
prependTags' TagList
tcs' (QT -> QT
qt_a QT
qt)
                                       , qt_b :: QT
qt_b = TagList -> QT -> QT
prependTags' TagList
tcs' (QT -> QT
qt_b QT
qt) }
prependTags' TagList
tcs' (Simple {qt_win :: QT -> TagList
qt_win=TagList
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) =
  Simple :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = if TagList -> Bool
noWin TagList
w then TagList
w else TagList
tcs' TagList -> TagList -> TagList
forall a. Monoid a => a -> a -> a
`mappend` TagList
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, TagList)] -> IntMap [(a, TagList)]
prependQTrans CharMap QTrans
t
         , qt_other :: QTrans
qt_other = QTrans -> QTrans
forall {a}. IntMap [(a, TagList)] -> IntMap [(a, TagList)]
prependQTrans QTrans
o }
  where prependQTrans :: IntMap [(a, TagList)] -> IntMap [(a, TagList)]
prependQTrans = ([(a, TagList)] -> [(a, TagList)])
-> IntMap [(a, TagList)] -> IntMap [(a, TagList)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, TagList) -> (a, TagList)) -> [(a, TagList)] -> [(a, TagList)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
d,TagList
tcs) -> (a
d,TagList
tcs' TagList -> TagList -> TagList
forall a. Monoid a => a -> a -> a
`mappend` TagList
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 :: [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt = do
  (Key
thisI,[(Key, QNFA)] -> [(Key, QNFA)]
oldQs) <- StateT
  (Key, [(Key, QNFA)] -> [(Key, QNFA)])
  Identity
  (Key, [(Key, QNFA)] -> [(Key, QNFA)])
forall s (m :: * -> *). MonadState s m => m s
get
  let futureI :: Key
futureI = Key -> Key
forall a. Enum a => a -> a
succ Key
thisI in Key -> S QNFA -> S QNFA
seq Key
futureI (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ [Char] -> S QNFA -> S QNFA
forall a s. Show a => a -> s -> s
debug ([Char]
">newQNFA< "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Key -> [Char]
forall a. Show a => a -> [Char]
show Key
thisI) (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ do
  let qnfa :: QNFA
qnfa = Key -> QT -> QNFA
mkQNFA Key
thisI QT
qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ
  (Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((Key, [(Key, QNFA)] -> [(Key, QNFA)])
 -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> (Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$! (Key
futureI, [(Key, QNFA)] -> [(Key, QNFA)]
oldQs ([(Key, QNFA)] -> [(Key, QNFA)])
-> ([(Key, QNFA)] -> [(Key, QNFA)])
-> [(Key, QNFA)]
-> [(Key, QNFA)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
thisI,QNFA
qnfa)(Key, QNFA) -> [(Key, QNFA)] -> [(Key, 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 = (TagTasks
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 = (TagTasks
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 :: [Char] -> E -> S E
asQNFA [Char]
_ x :: E
x@(TagTasks
_,Left QNFA
_) = E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
x
asQNFA [Char]
s (TagTasks
tags,Right QT
qt) = do QNFA
qnfa <- [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt      -- YYY Policy choice: leave the tags
                              E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (TagTasks
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 :: [Char] -> E -> S QNFA
getQNFA [Char]
_ ([],Left QNFA
qnfa) = QNFA -> S QNFA
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa
getQNFA [Char]
s (TagTasks
tags,Left QNFA
qnfa) = [Char] -> QT -> S QNFA
newQNFA [Char]
s (TagList -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> TagList
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) (QNFA -> QT
q_qt QNFA
qnfa))
getQNFA [Char]
s (TagTasks
tags,Right QT
qt) = [Char] -> QT -> S QNFA
newQNFA [Char]
s (TagList -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> TagList
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) QT
qt)

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

-- 2009: This looks realllly dodgy, since it can convert a QNFA/Testing to a QT/Testing
-- without actually achieving anything except adding a DoPa to the Testing.  A diagnostic
-- series of runs might be needed to decide if this ever creates orphan id numbers.
-- Then applyTest might need to keep track of whether it actually changes anything.
addTest :: TestInfo -> E -> E
addTest :: TestInfo -> E -> E
addTest TestInfo
ti (TagTasks
tags,Either QNFA QT
cont) = (TagTasks
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) -> TagTasks -> TagList
promoteTasks TagTask -> TagUpdate
promote TagTasks
tags = ((Key, TagTask) -> (Key, TagUpdate)) -> TagTasks -> TagList
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
tag,TagTask
task) -> (Key
tag,TagTask -> TagUpdate
promote TagTask
task)) TagTasks
tags

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

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

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

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

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

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

-- Consume an ActCont.  Uses the mergeQT form to combine non-accepting
-- and accepting view of the continuation.
getE :: ActCont -> E
getE :: ActCont -> E
getE (E
_,Maybe E
_,Just (TagTasks
tags,QNFA
qnfa)) = (TagTasks
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)  -- consume optimized mQNFA value returned by Star
getE (E
eLoop,Just E
accepting,Maybe (TagTasks, QNFA)
_) = QT -> E
fromQT (QT -> QT -> QT
mergeQT (E -> QT
getQT E
eLoop) (E -> QT
getQT E
accepting))
getE (E
eLoop,Maybe E
Nothing,Maybe (TagTasks, QNFA)
_) = 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 TestInfo
ti (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
_) = (TestInfo -> E -> E
addTest TestInfo
ti E
e
                        ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestInfo -> E -> E
addTest TestInfo
ti) Maybe E
mE
                        ,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)

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

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

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

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

addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC :: TagList -> ActCont -> ActCont
addWinTagsAC TagList
wtags (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = (TagList -> E -> E
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
wtags E
e
                                  ,(E -> E) -> Maybe E -> Maybe E
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TagList -> E -> E
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
wtags) Maybe E
mE
                                  ,((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TagList -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
wtags) Maybe (TagTasks, 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 -> (Key, Array Key QNFA)
qToNFA CompOption
compOpt Q
qTop = (QNFA -> Key
q_id QNFA
startingQNFA
                      ,(Key, Key) -> [(Key, QNFA)] -> Array Key QNFA
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Key
0,Key -> Key
forall a. Enum a => a -> a
pred Key
lastIndex) ([(Key, QNFA)] -> [(Key, QNFA)]
table [])) where
  -- Result startingQNFA is the top level's index
  -- State pair: fst 0 is the next state number (not yet used) going in, and lastIndex coming out (succ of last used)
  --             snd id is the difference list of states going in, and the finished list coming out
  (QNFA
startingQNFA,(Key
lastIndex,[(Key, QNFA)] -> [(Key, QNFA)]
table)) =
    S QNFA
-> (Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> (QNFA, (Key, [(Key, QNFA)] -> [(Key, 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
>>= [Char] -> E -> S QNFA
getQNFA [Char]
"top level") (Key, [(Key, QNFA)] -> [(Key, QNFA)])
forall {a}. (Key, a -> a)
startState
  startState :: (Key, a -> a)
startState = (Key
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 -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post,unQ :: Q -> P
unQ=P
pIn}) E
e = [Char] -> S E -> S E
forall a s. Show a => a -> s -> s
debug ([Char]
">< getTrans "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
    case P
pIn of
      -- The case below is the ultimate consumer of every single OneChar in the input and the only caller of
      -- newTrans/acceptTrans which is the sole source of QT/Simple nodes.
      OneChar Pattern
pat -> [Char] -> [Key] -> Maybe Key -> Pattern -> E -> S E
newTrans [Char]
"getTrans/OneChar" [Key]
resets Maybe Key
pre Pattern
pat (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      P
Empty -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      Test TestInfo
ti -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
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 Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
      P
_ -> E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
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 Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e)

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

      Star Maybe Key
mOrbit [Key]
resetTheseOrbits Bool
mayFirstBeNull Q
q ->
        -- mOrbit of Just implies varies q and childGroups q
        let (E
e',Bool
clear) = -- debug ("\n>"++show e++"\n"++show q++"\n<") $
              if Q -> Bool
notNullable Q
q then (E
e,Bool
True)  -- subpattern cannot be null
                else if [Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Key -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
                       then case Q -> Maybe TagList
maybeOnlyEmpty Q
q of
                              Just [] -> (E
e,Bool
True)    -- True because null of subpattern is same as skipping subpattern
                              Just TagList
tagList -> (TagList -> E -> E
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
tagList E
e,Bool
False) -- null of subpattern NOT same as skipping
                              Maybe TagList
_ -> (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, TagList)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, TagList)]
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
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit -- resetOrbitsQT and enterOrbitQT commute
                             (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, TagList)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, TagList)]
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 Key -> E -> E
leaveOrbit Maybe Key
mOrbit (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)  -- perform resets when accepting 0 characters
        in if Q -> Bool
cannotAccept Q
q then E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return E
e' else mdo
        Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
this
        (E
this,E
ans) <- case Maybe QT
mqt of
                        Maybe QT
Nothing -> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (E, E)
forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/Star: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
                        Just QT
qt -> do
                          let qt' :: QT
qt' = [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
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 Key -> E -> E
leaveOrbit Maybe Key
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
=<< [Char] -> QT -> S QNFA
newQNFA [Char]
"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 (Key, [(Key, QNFA)] -> [(Key, 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 -> [Char] -> S E -> S E
forall a. [Char] -> a -> a
ecart ([Char]
"\n> getTransTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
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 (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
 -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
 -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        let e' :: E
e' = case Q -> Maybe TagList
maybeOnlyEmpty Q
qIn of
                   Just [] -> E
e
                   Just TagList
_wtags -> E
e -- addWinTags wtags e  XXX was duplicating tags
                   Maybe TagList
Nothing -> [Char] -> E
forall a. [Char] -> a
err ([Char] -> E) -> [Char] -> E
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn
        Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
e
        E -> S E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ case Maybe QT
mqt of
                   Maybe QT
Nothing -> [Char] -> E
forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/NonEmpty: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
                   Just QT
qt -> QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT_2nd QT
qt (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e' -- ...and then this sets qt_win to exactly that of e'
      P
_ -> [Char] -> S E
forall a. [Char] -> a
err ([Char]
"This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
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 -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post}) E
eLoop | Q -> Bool
notNullable Q
qIn =
    [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/1 "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (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 =
    [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/2 "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (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 ([Key] -> QT -> QT
prependGroupResets [Key]
resets (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
prependPreTag Maybe Key
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 Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
eLoop)
    
  inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn E
eLoop = [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStarNullableTagless "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      P
Empty -> Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing -- with Or this discards () branch in "(^|foo|())*"
      Or [] -> Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing
      Or [Q
q] -> Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop
      Or [Q]
qs -> do
        [Maybe QT]
mqts <- if Q -> Bool
usesQNFA Q
qIn
                  then do E
eQNFA <- [Char] -> E -> S E
asQNFA [Char]
"inStarNullableTagless/Or/usesQNFA" E
eLoop
                          [S (Maybe QT)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, 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 (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [Maybe QT]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop | Q
q <- [Q]
qs ]
        let qts :: [QT]
qts = [Maybe QT] -> [QT]
forall a. [Maybe a] -> [a]
catMaybes [Maybe QT]
mqts
            mqt :: Maybe QT
mqt = if [QT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts then Maybe QT
forall a. Maybe a
Nothing else QT -> Maybe QT
forall a. a -> Maybe a
Just ((QT -> QT -> QT) -> [QT] -> QT
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
        Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
mqt
      -- Calls to act are inlined by hand to actNullable.  This returns only cases where q1 or q2 or both
      -- accepted characters.  The zero-character case is handled by the tag wrapping by inStar.
      -- 2009: Does this look dodgy and repetitios of tags?  Seq by policy has no preTag or postTag.
      -- though it can have prependGroupResets, but those are not repeated in children so it is okay.
      Seq Q
q1 Q
q2 -> do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
                      Maybe QT -> S (Maybe QT)
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      -- Calls to act are inlined by hand and are we losing the tags?
      Star {} -> do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, 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 {} -> [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a. [Char] -> a -> a
ecart ([Char]
"\n> inStarNullableTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn) (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
                     do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, 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 {} -> [Char] -> S (Maybe QT)
forall a. [Char] -> a
err ([Char]
"OneChar cannot have nullable True")

  {- act* functions

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

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

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

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

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

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

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

  -}

  act :: Q -> ActCont -> S (Maybe E)
  act :: Q -> ActCont -> S (Maybe E)
act Q
qIn ActCont
c | Q -> Bool
nullable Q
qIn = (ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
qIn ActCont
c
            | Bool
otherwise = [Char] -> S (Maybe E) -> S (Maybe E)
forall a s. Show a => a -> s -> s
debug ([Char]
">< act "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (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 -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post,unQ :: Q -> P
unQ=P
pIn}) ActCont
ac =
    [Char] -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug ([Char]
">< actNullable "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case P
pIn of
      P
Empty -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
      Test TestInfo
ti -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
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 Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
      OneChar {} -> [Char] -> S ActCont
forall a. [Char] -> a
err ([Char]
"OneChar cannot have nullable True ")
      P
_ -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
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 Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> ActCont) -> ActCont -> ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac )

  actNullableTagless :: Q -> ActCont -> S ActCont
actNullableTagless Q
qIn ac :: ActCont
ac@(E
eLoop,Maybe E
mAccepting,Maybe (TagTasks, QNFA)
mQNFA) = [Char] -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug ([Char]
">< actNullableTagless "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show (Q
qIn)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      Seq Q
q1 Q
q2 -> Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 ActCont
ac   -- We know q1 and q2 are nullable
                      
      Or [] -> ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac
      Or [Q
q] -> Q -> ActCont -> S ActCont
actNullableTagless Q
q ActCont
ac
      Or [Q]
qs -> do
        [Maybe E]
cqts <- do
          if (Q -> Bool) -> [Q] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Q -> Bool
nullable [Q]
qs
            then [S (Maybe E)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, 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' <- [Char] -> E -> S E
asQNFA [Char]
"qToNFA/actNullableTagless/Or" (E -> S E) -> (ActCont -> E) -> ActCont -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> S E) -> ActCont -> S E
forall a b. (a -> b) -> a -> b
$ ActCont
ac
              let act' :: Q -> S (Maybe E)
                  act' :: Q -> S (Maybe E)
act' Q
q = Maybe E -> S (Maybe E)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe E -> S (Maybe E)) -> (E -> Maybe E) -> E -> S (Maybe E)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> Maybe E
forall a. a -> Maybe a
Just (E -> S (Maybe E)) -> S E -> S (Maybe E)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q E
e'
              [S (Maybe E)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, 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 TagList
maybeOnlyEmpty Q
qIn of
                       Just TagList
wtags -> TagList -> E -> E
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
wtags E
eLoop -- nullable without tests; avoid getQT
                       Maybe TagList
Nothing -> QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, TagList)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, TagList)]
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, TagList)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, TagList)]
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 (TagTasks, QNFA)
mQNFA' = if [QT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
                       then case Q -> Maybe TagList
maybeOnlyEmpty Q
qIn of
                              Just TagList
wtags -> ((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TagList -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. TagList -> (TagTasks, a) -> (TagTasks, a)
addWinTags TagList
wtags) Maybe (TagTasks, QNFA)
mQNFA
                              Maybe TagList
Nothing -> Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing
                       else Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing
        ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (E
eLoop',Maybe E
mAccepting',Maybe (TagTasks, QNFA)
mQNFA')

      Star Maybe Key
mOrbit [Key]
resetTheseOrbits Bool
mayFirstBeNull Q
q -> do
        let (ac0 :: ActCont
ac0@(E
_,Maybe E
mAccepting0,Maybe (TagTasks, QNFA)
_),Bool
clear) =
              if Q -> Bool
notNullable Q
q
                then (ActCont
ac,Bool
True)
                else if [Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Key -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
                       then case Q -> Maybe TagList
maybeOnlyEmpty Q
q of
                              Just [] -> (ActCont
ac,Bool
True)
                              Just TagList
wtags -> (TagList -> ActCont -> ActCont
addWinTagsAC TagList
wtags ActCont
ac,Bool
False)
                              Maybe TagList
_ -> 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, TagList)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, TagList)]
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 (TagTasks, 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
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit
                                     (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, TagList)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, TagList)]
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 Key -> E -> E
leaveOrbit Maybe Key
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 (TagTasks, 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 (TagTasks, QNFA)
forall a. Maybe a
Nothing)
          (thisAC :: ActCont
thisAC@(E
this,Maybe E
_,Maybe (TagTasks, QNFA)
_),ActCont
ansAC) <- 
            case Maybe E
mChildAccepting of
              Maybe E
Nothing -> [Char]
-> StateT
     (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont)
forall a. [Char] -> a
err ([Char]
 -> StateT
      (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont))
-> [Char]
-> StateT
     (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont)
forall a b. (a -> b) -> a -> b
$ [Char]
"Weird pattern in getTransTagless/Star: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
              Just E
childAccepting -> do
                let childQT :: QT
childQT = [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
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 Key -> E -> E
leaveOrbit Maybe Key
mOrbit (E -> E) -> (ActCont -> E) -> ActCont -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac
                    thisAccepting :: Maybe E
thisAccepting =
                      case Maybe E
mAccepting of
                        Just E
futureAccepting -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting
                        Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
                ActCont
thisAll <- if Q -> Bool
usesQNFA Q
q
                             then do QNFA
thisQNFA <- [Char] -> QT -> S QNFA
newQNFA [Char]
"actNullableTagless/Star" QT
thisQT
                                     ActCont -> S ActCont
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> E
fromQNFA QNFA
thisQNFA, Maybe E
thisAccepting, (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a. a -> Maybe a
Just (TagTasks
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 (TagTasks, QNFA)
forall a. Maybe a
Nothing)
                let skipQT :: QT
skipQT = QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (ActCont -> QT) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (ActCont -> E) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac0  -- for first iteration the continuation uses NullView
                    skipAccepting :: Maybe E
skipAccepting =
                      case Maybe E
mAccepting0 of
                        Just E
futureAccepting0 -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting0
                        Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
                    ansAll :: (E, Maybe E, Maybe a)
ansAll = (QT -> E
fromQT QT
skipQT, Maybe E
skipAccepting, Maybe a
forall a. Maybe a
Nothing)
                (ActCont, ActCont)
-> StateT
     (Key, [(Key, QNFA)] -> [(Key, 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 -> [Char] -> S ActCont -> S ActCont
forall a. [Char] -> a -> a
ecart ([Char]
"\n> actNullableTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
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 (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
 -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
 -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))

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

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

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

  leaveOrbit :: Maybe Tag -> E -> E
  leaveOrbit :: Maybe Key -> E -> E
leaveOrbit | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (E -> E) -> Maybe Key -> E -> E
forall a b. a -> b -> a
const E -> E
forall a. a -> a
id
             | Bool
otherwise = (E -> E) -> (Key -> E -> E) -> Maybe Key -> E -> E
forall b a. b -> (a -> b) -> Maybe a -> b
maybe E -> E
forall a. a -> a
id (\Key
tag->(\(TagTasks
tags,Either QNFA QT
cont)->((Key
tag,TagTask
LeaveOrbitTask)(Key, TagTask) -> TagTasks -> TagTasks
forall a. a -> [a] -> [a]
:TagTasks
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 :: [Char] -> [Key] -> Maybe Key -> Pattern -> E -> S E
newTrans [Char]
s [Key]
resets Maybe Key
mPre Pattern
pat (TagTasks
tags,Either QNFA QT
cont) = do
    Key
i <- case Either QNFA QT
cont of
           Left QNFA
qnfa -> Key -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity Key
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Key
q_id QNFA
qnfa)     -- strictQNFA ZZZ no help
           Right QT
qt -> do QNFA
qnfa <- [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt -- strictQT ZZZ no help
                          Key -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity Key
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Key
q_id QNFA
qnfa)
    let post :: TagList
post = (TagTask -> TagUpdate) -> TagTasks -> TagList
promoteTasks TagTask -> TagUpdate
PostUpdate TagTasks
tags
        pre :: TagList
pre  = (TagTask -> TagUpdate) -> TagTasks -> TagList
promoteTasks TagTask -> TagUpdate
PreUpdate ([(Key
tag,TagTask
ResetGroupStopTask) | Key
tag<-[Key]
resets] TagTasks -> TagTasks -> TagTasks
forall a. [a] -> [a] -> [a]
++ TagTasks -> (Key -> TagTasks) -> Maybe Key -> TagTasks
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Key
tag -> [(Key
tag,TagTask
TagTask)]) Maybe Key
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
$ TagList -> Pattern -> TagList -> Key -> QT
acceptTrans TagList
pre Pattern
pat TagList
post Key
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 :: TagList -> Pattern -> TagList -> Key -> QT
acceptTrans TagList
pre Pattern
pIn TagList
post Key
i =
    let target :: QTrans
target = Key -> [TagCommand] -> QTrans
forall a. Key -> a -> IntMap a
IMap.singleton Key
i [(Pattern -> DoPa
getDoPa Pattern
pIn,TagList
preTagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++TagList
post)]
    in case Pattern
pIn of
         PChar DoPa
_ Char
char ->
           let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target [Char
char]
           in Simple :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = TagList
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PEscape DoPa
_ Char
char ->
           let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target [Char
char]
           in Simple :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = TagList
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PDot DoPa
_ -> Simple :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = TagList
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
dotTrans, qt_other :: QTrans
qt_other = QTrans
target }
         PAny DoPa
_ PatternSet
ps ->
           let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target ([Char] -> CharMap QTrans)
-> (PatternSet -> [Char]) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> [Char]
forall a. Set a -> [a]
S.toAscList (Set Char -> [Char])
-> (PatternSet -> Set Char) -> PatternSet -> [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 :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = TagList
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
         PAnyNot DoPa
_ PatternSet
ps ->
           let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
forall a. Monoid a => a
mempty ([Char] -> CharMap QTrans)
-> (PatternSet -> [Char]) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> [Char]
forall a. Set a -> [a]
S.toAscList (Set Char -> [Char])
-> (PatternSet -> Set Char) -> PatternSet -> [Char]
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 :: TagList -> CharMap QTrans -> QTrans -> QT
Simple { qt_win :: TagList
qt_win = TagList
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
target }
         Pattern
_ -> [Char] -> QT
forall a. [Char] -> a
err ([Char]
"Cannot acceptTrans pattern "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Pattern) -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> CharMap QTrans
toMap QTrans
dest | CompOption -> Bool
caseSensitive CompOption
compOpt = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> ([Char] -> IntMap QTrans) -> [Char] -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, QTrans)] -> IntMap QTrans
forall a. [(Key, a)] -> IntMap a
IMap.fromDistinctAscList ([(Key, QTrans)] -> IntMap QTrans)
-> ([Char] -> [(Key, QTrans)]) -> [Char] -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Key, QTrans)) -> [Char] -> [(Key, QTrans)]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Char -> Key
ord Char
c,QTrans
dest))
                 | Bool
otherwise = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> ([Char] -> IntMap QTrans) -> [Char] -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, QTrans)] -> IntMap QTrans
forall a. [(Key, a)] -> IntMap a
IMap.fromList ([(Key, QTrans)] -> IntMap QTrans)
-> ([Char] -> [(Key, QTrans)]) -> [Char] -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)] -> [(Key, QTrans)]
forall a b. (a -> b) -> a -> b
$ []) 
                               (([(Key, QTrans)] -> [(Key, QTrans)]) -> [(Key, QTrans)])
-> ([Char] -> [(Key, QTrans)] -> [(Key, QTrans)])
-> [Char]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
 -> ([(Key, QTrans)] -> [(Key, QTrans)])
 -> [(Key, QTrans)]
 -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [Char]
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c [(Key, QTrans)] -> [(Key, QTrans)]
dl -> if Char -> Bool
isAlpha Char
c
                                                   then ([(Key, QTrans)] -> [(Key, QTrans)]
dl([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toUpper Char
c),QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                           ([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toLower Char
c),QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:)
                                                        )
                                                   else ([(Key, QTrans)] -> [(Key, QTrans)]
dl([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord Char
c,QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:))
                                       ) [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> a
id 
      addNewline :: Set Char -> Set Char
addNewline | CompOption -> Bool
multiline CompOption
compOpt = Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
S.insert Char
'\n'
                 | Bool
otherwise = Set Char -> Set Char
forall a. a -> a
id
      dotTrans :: CharMap QTrans
dotTrans | CompOption -> Bool
multiline CompOption
compOpt = Char -> QTrans -> CharMap QTrans
forall a. Char -> a -> CharMap a
Map.singleton Char
'\n' QTrans
forall a. Monoid a => a
mempty
               | Bool
otherwise = CharMap QTrans
forall a. Monoid a => a
Mon.mempty

{-

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

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


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

-}

-- | decodePatternSet cannot handle collating element and treats
-- equivalence classes as just their definition and nothing more.
decodePatternSet :: PatternSet -> S.Set Char
decodePatternSet :: PatternSet -> Set Char
decodePatternSet (PatternSet Maybe (Set Char)
msc Maybe (Set PatternSetCharacterClass)
mscc Maybe (Set PatternSetCollatingElement)
_ Maybe (Set PatternSetEquivalenceClass)
msec) =
  let baseMSC :: Set Char
baseMSC = Set Char -> (Set Char -> Set Char) -> Maybe (Set Char) -> Set Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Char
forall a. Set a
S.empty Set Char -> Set Char
forall a. a -> a
id Maybe (Set Char)
msc
      withMSCC :: Set Char
withMSCC = (Set Char -> Char -> Set Char) -> Set Char -> [Char] -> 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  ([Char]
-> (Set PatternSetCharacterClass -> [Char])
-> Maybe (Set PatternSetCharacterClass)
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((PatternSetCharacterClass -> [Char])
-> [PatternSetCharacterClass] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatternSetCharacterClass -> [Char]
decodeCharacterClass ([PatternSetCharacterClass] -> [Char])
-> (Set PatternSetCharacterClass -> [PatternSetCharacterClass])
-> Set PatternSetCharacterClass
-> [Char]
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 -> [Char] -> 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 ([Char]
-> (Set PatternSetEquivalenceClass -> [Char])
-> Maybe (Set PatternSetEquivalenceClass)
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((PatternSetEquivalenceClass -> [Char])
-> [PatternSetEquivalenceClass] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatternSetEquivalenceClass -> [Char]
unSEC ([PatternSetEquivalenceClass] -> [Char])
-> (Set PatternSetEquivalenceClass -> [PatternSetEquivalenceClass])
-> Set PatternSetEquivalenceClass
-> [Char]
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 -> [Char]
decodeCharacterClass (PatternSetCharacterClass [Char]
s) =
  case [Char]
s of
    [Char]
"alnum" -> [Char
'0'..Char
'9'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'z'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z']
    [Char]
"digit" -> [Char
'0'..Char
'9']
    [Char]
"punct" -> [Char
'\33'..Char
'\47'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'\58'..Char
'\64'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'\91'..Char
'\95'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\96"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'\123'..Char
'\126']
    [Char]
"alpha" -> [Char
'a'..Char
'z'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z']
    [Char]
"graph" -> [Char
'\41'..Char
'\126']
    [Char]
"space" -> [Char]
"\t\n\v\f\r "
    [Char]
"blank" -> [Char]
"\t "
    [Char]
"lower" -> [Char
'a'..Char
'z']
    [Char]
"upper" -> [Char
'A'..Char
'Z']
    [Char]
"cntrl" -> [Char
'\0'..Char
'\31'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\127" -- with NUL
    [Char]
"print" -> [Char
'\32'..Char
'\126']
    [Char]
"xdigit" -> [Char
'0'..Char
'9'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'f'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'F']
    [Char]
"word" -> [Char
'0'..Char
'9'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'z'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z'][Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_"
    [Char]
_ -> []

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

-}