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

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

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

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

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

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

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(..), decodePatternSet)

ecart :: String -> a -> a
ecart :: forall a. [Char] -> a -> a
ecart [Char]
_ = forall a. a -> a
id

err :: String -> a
err :: forall a. [Char] -> a
err [Char]
t = 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 further transitions and sets tag #1 to the current position.
qtwin :: QT
qtwin = Simple {qt_win :: WinTags
qt_win=[(Key
1,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)],qt_trans :: CharMap QTrans
qt_trans=forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=forall a. Monoid a => a
mempty}
-- qtlose is the continuation to nothing, used when ^ or $ tests fail.
qtlose :: QT
qtlose = Simple {qt_win :: WinTags
qt_win=forall a. Monoid a => a
mempty,qt_trans :: CharMap QTrans
qt_trans=forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=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 [ forall a. Show a => a -> [Char]
show Q
q ]
  in 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> NullView
nullQ

notNullable :: Q -> Bool
notNullable :: Q -> Bool
notNullable = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> NullView
nullQ

-- This asks if the preferred (i.e. first) NullView has no tests.
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty (Q {nullQ :: Q -> NullView
nullQ = ((SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags):NullView
_)}) = if forall key a. Enum key => EnumMap key a -> Bool
EMap.null EnumMap WhichTest (EnumSet DoPa)
sti then forall a. a -> Maybe a
Just WinTags
tags else forall a. Maybe a
Nothing
maybeOnlyEmpty Q
_ = 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 = forall a s. Show a => a -> s -> s
debug ([Char]
"\n>QNFA id="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Key
i) forall a b. (a -> b) -> a -> b
$
  Key -> QT -> QNFA
QNFA Key
i (forall a s. Show a => a -> s -> s
debug ([Char]
"\ngetting QT for "forall a. [a] -> [a] -> [a]
++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
aforall a. Eq a => a -> a -> Bool
==QT
b then QT
a else QT
t -- Move to nfsToDFA XXX
mkTesting QT
t = QT
t

nullQT :: QT -> Bool
nullQT :: QT -> Bool
nullQT (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) = WinTags -> Bool
noWin WinTags
w Bool -> Bool -> Bool
&& forall a. CharMap a -> Bool
Map.null CharMap QTrans
t Bool -> Bool -> 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 = forall s a. State s a -> s -> s
execState (forall {m :: * -> *}.
MonadState (EnumSet WhichTest) m =>
QT -> m ()
helper QT
qt) EnumSet WhichTest
s
  where helper :: QT -> m ()
helper (Simple {}) = 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
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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 :: NullView -> QT -> QT
applyNullViews [] QT
win = QT
win
applyNullViews NullView
nvs QT
win = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
qtlose (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ NullView -> NullView
cleanNullView NullView
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 :: NullView -> QT -> QT
preferNullViews [] QT
win = QT
win
preferNullViews NullView
nvs QT
win = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
win (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ NullView -> NullView
cleanNullView NullView
nvs) where

{-
dominate is common to applyNullViews and preferNullViews above.

Even I no longer understand it without study.

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

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

Detail: The merging is done by useTest, where the tests in sti divert
losing to a branch of "lose" and winning to a branch of "win".  Tests
not in sti are unchanged (but the losing DoPa index might be added).
-}
dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT
dominate :: QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win QT
lose x :: (SetTestInfo, WinTags)
x@(SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags) = forall a s. Show a => a -> s -> s
debug ([Char]
"dominate "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (SetTestInfo, WinTags)
x) forall a b. (a -> b) -> a -> b
$
  let -- The winning states are reached through the SetTag
      win' :: QT
win' = WinTags -> QT -> QT
prependTags' WinTags
tags QT
win
      -- get the SetTestInfo
      winTests :: EnumSet WhichTest
winTests = QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
win forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
      allTests :: EnumSet WhichTest
allTests = (QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
lose forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
winTests) forall a. Monoid a => a -> a -> a
`mappend` (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
aTestforall 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,forall a. Monoid a => a
mempty)
        in if WhichTest
aTest forall a. Eq a => a -> a -> Bool
== WhichTest
dTest
             then Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = (EnumSet DoPa
dopas forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
wD) 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 {qt_test :: WhichTest
qt_test = WhichTest
aTest
                          ,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa
wD 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
_ = 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 (forall e. Enum e => EnumSet e -> [e]
Set.toList EnumSet WhichTest
allTests) (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 forall a b. (a -> b) -> a -> b
$ Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
                        ,qt_dopas :: EnumSet DoPa
qt_dopas = 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 forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt WhichTest
wt' of
      Ordering
LT -> Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
                    ,qt_dopas :: EnumSet DoPa
qt_dopas = 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 = forall e. Enum e => e -> EnumSet e -> EnumSet e
Set.insert DoPa
dopa (QT -> EnumSet DoPa
qt_dopas QT
q)
              ,qt_b :: QT
qt_b = QT
qtlose}
      Ordering
GT -> QT
q {qt_a :: QT
qt_a = QT -> QT
applyTest' (QT -> QT
qt_a QT
q)
              ,qt_b :: QT
qt_b = QT -> QT
applyTest' (QT -> QT
qt_b QT
q)}

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

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

-- This takes a function which implements a policy on merging
-- winning transitions and then merges all the transitions.  It opens
-- the CharMap newtype for more efficient operation, then rewraps it.
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith WinTags -> WinTags -> WinTags
mergeWins = QT -> QT -> QT
merge where
  merge :: QT -> QT -> QT
  merge :: QT -> QT -> QT
merge (Simple WinTags
w1 CharMap QTrans
t1 QTrans
o1) (Simple WinTags
w2 CharMap QTrans
t2 QTrans
o2) =
    let w' :: WinTags
w' = WinTags -> WinTags -> WinTags
mergeWins WinTags
w1 WinTags
w2
        t' :: CharMap QTrans
t' = CharMap QTrans
-> QTrans -> CharMap QTrans -> QTrans -> CharMap QTrans
fuseQTrans CharMap QTrans
t1 QTrans
o1 CharMap QTrans
t2 QTrans
o2
        o' :: QTrans
o' = QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1 QTrans
o2
    in WinTags -> CharMap QTrans -> QTrans -> QT
Simple WinTags
w' CharMap QTrans
t' QTrans
o'
  merge t1 :: QT
t1@(Testing WhichTest
_ EnumSet DoPa
_ QT
a1 QT
b1) s2 :: QT
s2@(Simple {}) = QT -> QT
mkTesting 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 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 forall a b. (a -> b) -> a -> b
$
    case 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 {qt_test :: WhichTest
qt_test = WhichTest
wt1 -- same as wt2
                    ,qt_dopas :: EnumSet DoPa
qt_dopas = 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 = forall a. IntMap a -> CharMap a
CharMap (forall a. [(Key, a)] -> IntMap a
IMap.fromDistinctAscList (forall {a}.
Ord a =>
[(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(Key, QTrans)]
l1 [(Key, QTrans)]
l2)) where
    l1 :: [(Key, QTrans)]
l1 = forall a. IntMap a -> [(Key, a)]
IMap.toAscList IntMap QTrans
t1
    l2 :: [(Key, QTrans)]
l2 = forall a. IntMap a -> [(Key, a)]
IMap.toAscList IntMap QTrans
t2
    fuse :: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [] [(a, QTrans)]
y  = 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  [] = 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 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) 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) 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) 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 = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IMap.unionWith 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 = WinTags -> 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 = WinTags -> QT -> QT
prependTags' [(Key
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetGroupStopTask)|Key
tag<-[Key]
tags] QT
qt

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

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

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

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

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

-- newQNFA is the only operation that actually uses the monad get and put operations
newQNFA :: String -> QT -> S QNFA
newQNFA :: [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt = do
  (Key
thisI,[(Key, QNFA)] -> [(Key, QNFA)]
oldQs) <- forall s (m :: * -> *). MonadState s m => m s
get
  let futureI :: Key
futureI = forall a. Enum a => a -> a
succ Key
thisI in seq :: forall a b. a -> b -> b
seq Key
futureI forall a b. (a -> b) -> a -> b
$ forall a s. Show a => a -> s -> s
debug ([Char]
">newQNFA< "forall a. [a] -> [a] -> [a]
++[Char]
sforall a. [a] -> [a] -> [a]
++[Char]
" : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Key
thisI) 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
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$! (Key
futureI, [(Key, QNFA)] -> [(Key, QNFA)]
oldQs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
thisI,QNFA
qnfa)forall a. a -> [a] -> [a]
:))
  forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa

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

fromQNFA :: QNFA -> E
fromQNFA :: QNFA -> E
fromQNFA QNFA
qnfa = (forall a. Monoid a => a
mempty,forall a b. a -> Either a b
Left QNFA
qnfa)

fromQT :: QT -> E
fromQT :: QT -> E
fromQT QT
qt = (forall a. Monoid a => a
mempty,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
_) = 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
                              forall (m :: * -> *) a. Monad m => a -> m a
return (TagTasks
tags, 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) = 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 (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
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 (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
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) = WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_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, forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> QT -> QT
applyTest TestInfo
ti forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_qt forall a. a -> a
id 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 -> WinTags
promoteTasks TagTask -> TagUpdate
promote TagTasks
tags = 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 :: WinTags -> TagTasks
demoteTags = forall a b. (a -> b) -> [a] -> [b]
map 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. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags (TagTasks
tags,a
cont) = (WinTags -> TagTasks
demoteTags WinTags
wtags 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)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 = 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) = (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) TagTasks
tags' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Key
tag -> (Key
tag,TagTask
ResetGroupStopTask)) 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) = (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) TagTasks
tags' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Key
tag -> (Key
tag,TagTask
SetGroupStopTask)) 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, 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 comment for addTest.  Here is a case where the third component might be a (Just qnfa) and it
-- is being lost even though the added test might be redundant.
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
_) = (TestInfo -> E -> E
addTest TestInfo
ti E
e
                        ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestInfo -> E -> E
addTest TestInfo
ti) Maybe E
mE
                        ,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) = (forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag E
e
                                   ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag) Maybe E
mE
                                   ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) = (forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
tags E
e
                                     ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
tags) Maybe E
mE
                                     ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) = (forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags E
e
                                   ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags) Maybe E
mE
                                   ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags) Maybe (TagTasks, QNFA)
mQNFA)

addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = (forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags E
e
                                  ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags) Maybe E
mE
                                  ,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
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
                      ,forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Key
0,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)) =
    forall s a. State s a -> s -> (a, s)
runState (Q -> E -> S E
getTrans Q
qTop (QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ QT
qtwin) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> E -> S QNFA
getQNFA [Char]
"top level") forall {a}. (Key, a -> a)
startState
  startState :: (Key, a -> a)
startState = (Key
0,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 = forall a s. Show a => a -> s -> s
debug ([Char]
">< getTrans "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets forall a b. (a -> b) -> a -> b
$ E
e
      P
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets forall a b. (a -> b) -> a -> b
$ E
e
      Test TestInfo
ti -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> E -> E
addTest TestInfo
ti forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets forall a b. (a -> b) -> a -> b
$ E
e
      P
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets forall a b. (a -> b) -> a -> b
$ E
e)

  getTransTagless :: Q -> E -> S E
getTransTagless Q
qIn E
e = forall a s. Show a => a -> s -> s
debug ([Char]
">< getTransTagless "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q2 E
e
      Or [] -> 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
                    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 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 = forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT [E]
eqts
        forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT (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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
                              Just [] -> (E
e,Bool
True)    -- True because null of subpattern is same as skipping subpattern
                              Just WinTags
tagList -> (forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
tagList E
e,Bool
False) -- null of subpattern NOT same as skipping
                              Maybe WinTags
_ -> (QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. NullView -> QT -> QT
preferNullViews (Q -> NullView
nullQ Q
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)  -- is NOT same as skipping
                       else (QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit -- resetOrbitsQT and enterOrbitQT commute
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. NullView -> QT -> QT
preferNullViews (Q -> NullView
nullQ Q
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit 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 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 -> forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/Star: " forall a. [a] -> [a] -> [a]
++ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit forall a b. (a -> b) -> a -> b
$ QT
qt -- resetOrbitsQT and enterOrbitQT commute
                              thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
qt' forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
qt' forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. QNFA -> E
fromQNFA forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> QT -> S QNFA
newQNFA [Char]
"getTransTagless/Star" QT
thisQT
                                  else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ QT
thisQT
                          forall (m :: * -> *) a. Monad m => a -> m a
return (E
thisE,E
ansE)
        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 -> forall a. [Char] -> a -> a
ecart ([Char]
"\n> getTransTagless/NonEmpty"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qIn)  forall a b. (a -> b) -> a -> b
$ do
        -- Assertion to check than Pattern.starTrans did its job right:
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        let e' :: E
e' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                   Just [] -> E
e
                   Just WinTags
_wtags -> E
e -- addWinTags wtags e  XXX was duplicating tags
                   Maybe WinTags
Nothing -> forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qIn
        Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe QT
mqt of
                   Maybe QT
Nothing -> forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/NonEmpty: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
                   Just QT
qt -> QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT_2nd QT
qt forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
e' -- ...and then this sets qt_win to exactly that of e'
      P
_ -> forall a. [Char] -> a
err ([Char]
"This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" forall a. [a] -> [a] -> [a]
++ 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 =
    forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/1 "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn E
eLoop
                                                                 | Bool
otherwise =
    forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/2 "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> QT -> QT
prependGroupResets [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
prependPreTag Maybe Key
pre) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets forall a b. (a -> b) -> a -> b
$ E
eLoop)

  inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn E
eLoop = forall a s. Show a => a -> s -> s
debug ([Char]
">< inStarNullableTagless "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") forall a b. (a -> b) -> a -> b
$ do
    case Q -> P
unQ Q
qIn of
      P
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- with Or this discards () branch in "(^|foo|())*"
      Or [] -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
                          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 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 = forall a. [Maybe a] -> [a]
catMaybes [Maybe QT]
mqts
            mqt :: Maybe QT
mqt = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
        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
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
q1 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
q2 (E
eLoop,forall a. Maybe a
Nothing,forall a. Maybe a
Nothing)
                      forall (m :: * -> *) a. Monad m => a -> m a
return (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
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullableTagless Q
qIn (E
eLoop,forall a. Maybe a
Nothing,forall a. Maybe a
Nothing)
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      NonEmpty {} -> forall a. [Char] -> a -> a
ecart ([Char]
"\n> inStarNullableTagless/NonEmpty"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qIn) forall a b. (a -> b) -> a -> b
$
                     do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullableTagless Q
qIn (E
eLoop,forall a. Maybe a
Nothing,forall a. Maybe a
Nothing)
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
      Test {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- with Or this discards ^ branch in "(^|foo|())*"
      OneChar {} -> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b c. (a, b, c) -> b
snd3 forall a b. (a -> b) -> a -> b
$ Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
qIn ActCont
c
            | Bool
otherwise = forall a s. Show a => a -> s -> s
debug ([Char]
">< act "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") forall a b. (a -> b) -> a -> b
$ do
    Maybe E
mqt <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn ( ActCont -> E
getE forall a b. (a -> b) -> a -> b
$ ActCont
c )
    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
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity 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 =
    forall a s. Show a => a -> s -> s
debug ([Char]
">< actNullable "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qInforall a. [a] -> [a] -> [a]
++[Char]
" <>") forall a b. (a -> b) -> a -> b
$ do
    case P
pIn of
      P
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets forall a b. (a -> b) -> a -> b
$ ActCont
ac
      Test TestInfo
ti -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets forall a b. (a -> b) -> a -> b
$ ActCont
ac
      OneChar {} -> forall a. [Char] -> a
err ([Char]
"OneChar cannot have nullable True ")
      P
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullableTagless Q
qIn ( Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets forall a b. (a -> b) -> a -> b
$ ActCont
ac )

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

      Or [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac
      Or [Q
q] -> Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullableTagless Q
q ActCont
ac
      Or [Q]
qs -> do
        [Maybe E]
cqts <- do
          if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Q -> Bool
nullable [Q]
qs
            then forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b c. (a, b, c) -> b
snd3 forall a b. (a -> b) -> a -> b
$ Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
q ActCont
ac | Q
q <- [Q]
qs]
            else do
              E
e' <- [Char] -> E -> S E
asQNFA [Char]
"qToNFA/actNullableTagless/Or" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE forall a b. (a -> b) -> a -> b
$ ActCont
ac
              let act' :: Q -> S (Maybe E)
                  act' :: Q -> S (Maybe E)
act' Q
q = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q E
e'
              forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ if Q -> Bool
nullable Q
q then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b c. (a, b, c) -> b
snd3 forall a b. (a -> b) -> a -> b
$ Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
q ActCont
ac else Q -> S (Maybe E)
act' Q
q | Q
q <- [Q]
qs ]
        let qts :: [QT]
qts = forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT (forall a. [Maybe a] -> [a]
catMaybes [Maybe E]
cqts)
            eLoop' :: E
eLoop' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                       Just WinTags
wtags -> forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags E
eLoop -- nullable without tests; avoid getQT
                       Maybe WinTags
Nothing -> QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ NullView -> QT -> QT
applyNullViews (Q -> NullView
nullQ Q
qIn) (E -> QT
getQT E
eLoop) -- suspect this of duplicating some tags with nullQ qIn
            mAccepting' :: Maybe E
mAccepting' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
                            then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. NullView -> QT -> QT
applyNullViews (Q -> NullView
nullQ Q
qIn) 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 forall a. a -> Maybe a
Just (QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
            mQNFA' :: Maybe (TagTasks, QNFA)
mQNFA' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
                              Just WinTags
wtags -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags) Maybe (TagTasks, QNFA)
mQNFA
                              Maybe WinTags
Nothing -> forall a. Maybe a
Nothing
                       else forall a. Maybe a
Nothing
        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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
                       then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
                              Just [] -> (ActCont
ac,Bool
True)
                              Just WinTags
wtags -> (WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags ActCont
ac,Bool
False)
                              Maybe WinTags
_ -> let nQ :: E -> E
nQ = QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. NullView -> QT -> QT
preferNullViews (Q -> NullView
nullQ Q
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT
                                   in ((E -> E
nQ E
eLoop,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,forall a. Maybe a
Nothing),Bool
False)
                       else let nQ :: E -> E
nQ = QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit
                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. NullView -> QT -> QT
preferNullViews (Q -> NullView
nullQ Q
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit
                            in ((E -> E
nQ E
eLoop,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,forall a. Maybe a
Nothing),Bool
False)
        if Q -> Bool
cannotAccept Q
q then 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,forall a. Maybe a
Nothing,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 -> forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"Weird pattern in getTransTagless/Star: " forall a. [a] -> [a] -> [a]
++ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
childAccepting
                    thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
childQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE forall a b. (a -> b) -> a -> b
$ ActCont
ac
                    thisAccepting :: Maybe E
thisAccepting =
                      case Maybe E
mAccepting of
                        Just E
futureAccepting -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
futureAccepting
                        Maybe E
Nothing -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT 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
                                     forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> E
fromQNFA QNFA
thisQNFA, Maybe E
thisAccepting, forall a. a -> Maybe a
Just (forall a. Monoid a => a
mempty,QNFA
thisQNFA))
                             else forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT QT
thisQT, Maybe E
thisAccepting, forall a. Maybe a
Nothing)
                let skipQT :: QT
skipQT = QT -> QT -> QT
mergeQT QT
childQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE 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 -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
futureAccepting0
                        Maybe E
Nothing -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ QT
childQT
                    ansAll :: (E, Maybe E, Maybe a)
ansAll = (QT -> E
fromQT QT
skipQT, Maybe E
skipAccepting, forall a. Maybe a
Nothing)
                forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont
thisAll,forall {a}. (E, Maybe E, Maybe a)
ansAll)
          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 -> forall a. [Char] -> a -> a
ecart ([Char]
"\n> actNullableTagless/NonEmpty"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Q
qIn) forall a b. (a -> b) -> a -> b
$ do
        -- We *know* that q is nullable from Pattern and CorePattern checks, but assert here anyway
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) (forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) (forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "forall a. [a] -> [a] -> [a]
++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 WinTags
maybeOnlyEmpty Q
qIn of
                             Just [] -> ActCont
ac
                             Just WinTags
_wtags -> ActCont
ac -- addWinTagsAC wtags ac XXX was duplicating tags
                             Maybe WinTags
Nothing -> forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
        (E
_,Maybe E
mChildAccepting,Maybe (TagTasks, QNFA)
_) <- Q
-> ActCont
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ActCont
actNullable Q
q ActCont
ac
        case Maybe E
mChildAccepting of
          Maybe E
Nothing -> forall a. [Char] -> a
err  forall a b. (a -> b) -> a -> b
$ [Char]
"Weird pattern in actNullableTagless/NonEmpty: " forall a. [a] -> [a] -> [a]
++ 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 -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ QT
childQT
                                  Just E
futureAcceptingE -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT forall a b. (a -> b) -> a -> b
$ E
futureAcceptingE
                                  -- I _think_ there is no need for mergeQT_2nd in the above.
            forall (m :: * -> *) a. Monad m => a -> m a
return (E
clearE,Maybe E
thisAccepting,forall a. Maybe a
Nothing)
      P
_ -> forall a. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "forall a. [a] -> [a] -> [a]
++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 = forall a b. a -> b -> a
const forall a. a -> a
id
                | Bool
otherwise = (\[Key]
tags -> WinTags -> 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 = forall a b. a -> b -> a
const forall a. a -> a
id
               | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Key
tag->WinTags -> 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 = forall a b. a -> b -> a
const forall a. a -> a
id
             | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Key
tag->(\(TagTasks
tags,Either QNFA QT
cont)->((Key
tag,TagTask
LeaveOrbitTask)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 -> 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
                          forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Key
q_id QNFA
qnfa)
    let post :: WinTags
post = (TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PostUpdate TagTasks
tags
        pre :: WinTags
pre  = (TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate ([(Key
tag,TagTask
ResetGroupStopTask) | Key
tag<-[Key]
resets] forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Key
tag -> [(Key
tag,TagTask
TagTask)]) Maybe Key
mPre)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT forall a b. (a -> b) -> a -> b
$ WinTags -> Pattern -> WinTags -> Key -> QT
acceptTrans WinTags
pre Pattern
pat WinTags
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 :: WinTags -> Pattern -> WinTags -> Key -> QT
acceptTrans WinTags
pre Pattern
pIn WinTags
post Key
i =
    let target :: QTrans
target = forall a. Key -> a -> IntMap a
IMap.singleton Key
i [(Pattern -> DoPa
getDoPa Pattern
pIn,WinTags
preforall a. [a] -> [a] -> [a]
++WinTags
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 { qt_win :: WinTags
qt_win = forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = 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 { qt_win :: WinTags
qt_win = forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = forall a. Monoid a => a
mempty }
         PDot DoPa
_ -> Simple { qt_win :: WinTags
qt_win = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet forall a b. (a -> b) -> a -> b
$ PatternSet
ps
           in Simple { qt_win :: WinTags
qt_win = forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = forall a. Monoid a => a
mempty }
         PAnyNot DoPa
_ PatternSet
ps ->
           let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> Set Char
addNewline forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet forall a b. (a -> b) -> a -> b
$ PatternSet
ps
           in Simple { qt_win :: WinTags
qt_win = forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
target }
         Pattern
_ -> forall a. [Char] -> a
err ([Char]
"Cannot acceptTrans pattern "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (Q
qTop,Pattern
pIn))
    where  -- Take a common destination and a sorted list of unique characters
           -- and create a map from those characters to the common destination
      toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]
            -> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])])
      toMap :: QTrans -> [Char] -> CharMap QTrans
toMap QTrans
dest | CompOption -> Bool
caseSensitive CompOption
compOpt = forall a. IntMap a -> CharMap a
CharMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Key, a)] -> IntMap a
IMap.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Char -> Key
ord Char
c,QTrans
dest))
                 | Bool
otherwise = forall a. IntMap a -> CharMap a
CharMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Key, a)] -> IntMap a
IMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ [])
                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)]
dlforall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toUpper Char
c),QTrans
dest)forall a. a -> [a] -> [a]
:)
                                                           forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toLower Char
c),QTrans
dest)forall a. a -> [a] -> [a]
:)
                                                        )
                                                   else ([(Key, QTrans)] -> [(Key, QTrans)]
dlforall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord Char
c,QTrans
dest)forall a. a -> [a] -> [a]
:))
                                       ) forall a. a -> a
id
      addNewline :: Set Char -> Set Char
addNewline | CompOption -> Bool
multiline CompOption
compOpt = forall a. Ord a => a -> Set a -> Set a
S.insert Char
'\n'
                 | Bool
otherwise = forall a. a -> a
id
      dotTrans :: CharMap QTrans
dotTrans | CompOption -> Bool
multiline CompOption
compOpt = forall a. Char -> a -> CharMap a
Map.singleton Char
'\n' forall a. Monoid a => a
mempty
               | Bool
otherwise = 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

-}