-- | The CorePattern module deconstructs the Pattern tree created by
-- ReadRegex.parseRegex and returns a simpler Q\/P tree with
-- annotations at each Q node.  This will be converted by the TNFA
-- module into a QNFA finite automata.
--
-- Of particular note, this Pattern to Q\/P conversion creates and
-- assigns all the internal Tags that will be used during the matching
-- process, and associates the captures groups with the tags that
-- represent their starting and ending locations and with their
-- immediate parent group.
--
-- Each Maximize and Minimize tag is held as either a preTag or a
-- postTag by one and only one location in the Q\/P tree.  The Orbit
-- tags are each held by one and only one Star node.  Tags that stop a
-- Group are also held in perhaps numerous preReset lists.
--
-- The additional nullQ::nullView field of Q records the potentially
-- complex information about what tests and tags must be used if the
-- pattern unQ::P matches 0 zero characters.  There can be redundancy
-- in nullView, which is eliminated by cleanNullView.
--
-- Uses recursive do notation.
--
-- 2009 XXX TODO: we can avoid needing tags in the part of the pattern
-- after the last capturing group (when right-associative).  This is
-- flipped for left-associative where the front of the pattern before
-- the first capturing group needs no tags.  The edge of these regions
-- is subtle: both case needs a Maximize tag.  One ought to be able to
-- check the Pattern: if the root is PConcat then a scan from the end
-- (start) looking for the first with an embedded PGroup can be found
-- and the PGroup free elements can be wrapped in some new PNOTAG
-- semantic indicator.
module Text.Regex.TDFA.CorePattern(Q(..),P(..),WhichTest(..),Wanted(..)
                                  ,TestInfo,OP(..),SetTestInfo(..),NullView
                                  ,patternToQ,cleanNullView,cannotAccept,mustAccept) where

import Control.Monad (liftM2, forM, replicateM)
import Control.Monad.RWS (RWS, runRWS, ask, local, listens, tell, get, put)

import Data.Array.IArray(Array,(!),accumArray,listArray)
import Data.Either (partitionEithers, rights)
import Data.List(sort)
import Data.IntMap.EnumMap2(EnumMap)
import qualified Data.IntMap.EnumMap2 as Map(singleton,null,assocs,keysSet)
--import Data.Maybe(isNothing)
import Data.IntSet.EnumSet2(EnumSet)
import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,isSubsetOf)
import Data.Semigroup as Sem

import Text.Regex.TDFA.Common {- all -}
import Text.Regex.TDFA.Pattern(Pattern(..),starTrans)
-- import Debug.Trace

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


--err :: String -> a
--err = common_error "Text.Regex.TDFA.CorePattern"

--debug :: (Show a) => a -> b -> b
--debug _ = id

-- Core Pattern Language
data P = Empty                       -- Could be replaced by (Test Nothing)??
       | Or [Q]
       | Seq Q Q
       | Star { P -> Maybe GroupIndex
getOrbit :: Maybe Tag -- tag to prioritize the need to keep track of length of each pass though q
              , P -> [GroupIndex]
resetOrbits :: [Tag]  -- child star's orbits to reset (ResetOrbitTask) at all depths
              , P -> Bool
firstNull :: Bool     -- Usually True to mean the first pass may match 0 characters
              , P -> Q
unStar :: Q}
       | Test TestInfo               -- Require the test to be true (merge with empty as (Test (Maybe TestInfo)) ??)
       | OneChar Pattern             -- Bring the Pattern element that accepts a character
       | NonEmpty Q                  -- Don't let the Q pattern match nothing
         deriving (GroupIndex -> P -> ShowS
[P] -> ShowS
P -> String
(GroupIndex -> P -> ShowS)
-> (P -> String) -> ([P] -> ShowS) -> Show P
forall a.
(GroupIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: GroupIndex -> P -> ShowS
showsPrec :: GroupIndex -> P -> ShowS
$cshow :: P -> String
show :: P -> String
$cshowList :: [P] -> ShowS
showList :: [P] -> ShowS
Show,P -> P -> Bool
(P -> P -> Bool) -> (P -> P -> Bool) -> Eq P
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: P -> P -> Bool
== :: P -> P -> Bool
$c/= :: P -> P -> Bool
/= :: P -> P -> Bool
Eq)

-- The diagnostics about the pattern.  Note that when unQ is 'Seq' the
-- the preTag and postTag are Nothing but the preReset might have tags
-- from PGroup injecting them.
data Q = Q {Q -> NullView
nullQ :: NullView                  -- Ordered list of nullable views
           ,Q -> (GroupIndex, Maybe GroupIndex)
takes :: (Position,Maybe Position) -- Range of number of accepted characters
           ,Q -> [GroupIndex]
preReset :: [Tag]                  -- Tags to "reset" (ResetGroupStopTask) (Only immediate children for efficiency)
           ,Q -> [GroupIndex]
postSet :: [Tag]                   -- Tags to "set" (SetGroupStopTask)
           ,Q -> Maybe GroupIndex
preTag,Q -> Maybe GroupIndex
postTag :: Maybe Tag        -- Tags assigned around this pattern (TagTask)
           ,Q -> Bool
tagged :: Bool                     -- Whether this node should be tagged -- patternToQ use only
           ,Q -> Bool
childGroups :: Bool                -- Whether unQ has any PGroups -- patternToQ use only
           ,Q -> Wanted
wants :: Wanted                    -- What kind of continuation is used by this pattern
           ,Q -> P
unQ :: P} deriving (Q -> Q -> Bool
(Q -> Q -> Bool) -> (Q -> Q -> Bool) -> Eq Q
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Q -> Q -> Bool
== :: Q -> Q -> Bool
$c/= :: Q -> Q -> Bool
/= :: Q -> Q -> Bool
Eq)

type TestInfo = (WhichTest,DoPa)

-- This is newtype'd to allow control over class instances
-- This is a set of WhichTest where each test has associated pattern location information
newtype SetTestInfo = SetTestInfo {SetTestInfo -> EnumMap WhichTest (EnumSet DoPa)
getTests :: EnumMap WhichTest (EnumSet DoPa)} deriving (SetTestInfo -> SetTestInfo -> Bool
(SetTestInfo -> SetTestInfo -> Bool)
-> (SetTestInfo -> SetTestInfo -> Bool) -> Eq SetTestInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SetTestInfo -> SetTestInfo -> Bool
== :: SetTestInfo -> SetTestInfo -> Bool
$c/= :: SetTestInfo -> SetTestInfo -> Bool
/= :: SetTestInfo -> SetTestInfo -> Bool
Eq)

instance Semigroup SetTestInfo where
  SetTestInfo EnumMap WhichTest (EnumSet DoPa)
x <> :: SetTestInfo -> SetTestInfo -> SetTestInfo
<> SetTestInfo EnumMap WhichTest (EnumSet DoPa)
y = EnumMap WhichTest (EnumSet DoPa) -> SetTestInfo
SetTestInfo (EnumMap WhichTest (EnumSet DoPa)
x EnumMap WhichTest (EnumSet DoPa)
-> EnumMap WhichTest (EnumSet DoPa)
-> EnumMap WhichTest (EnumSet DoPa)
forall a. Semigroup a => a -> a -> a
Sem.<> EnumMap WhichTest (EnumSet DoPa)
y)

instance Monoid SetTestInfo where
  mempty :: SetTestInfo
mempty = EnumMap WhichTest (EnumSet DoPa) -> SetTestInfo
SetTestInfo EnumMap WhichTest (EnumSet DoPa)
forall a. Monoid a => a
mempty
  mappend :: SetTestInfo -> SetTestInfo -> SetTestInfo
mappend = SetTestInfo -> SetTestInfo -> SetTestInfo
forall a. Semigroup a => a -> a -> a
(Sem.<>)

instance Show SetTestInfo where
  show :: SetTestInfo -> String
show (SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti) = String
"SetTestInfo "String -> ShowS
forall a. [a] -> [a] -> [a]
++[(WhichTest, [DoPa])] -> String
forall a. Show a => a -> String
show ((EnumSet DoPa -> [DoPa])
-> [(WhichTest, EnumSet DoPa)] -> [(WhichTest, [DoPa])]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (EnumSet DoPa -> [DoPa]
forall e. Enum e => EnumSet e -> [e]
Set.toList) ([(WhichTest, EnumSet DoPa)] -> [(WhichTest, [DoPa])])
-> [(WhichTest, EnumSet DoPa)] -> [(WhichTest, [DoPa])]
forall a b. (a -> b) -> a -> b
$ EnumMap WhichTest (EnumSet DoPa) -> [(WhichTest, EnumSet DoPa)]
forall key a. Enum key => EnumMap key a -> [(key, a)]
Map.assocs EnumMap WhichTest (EnumSet DoPa)
sti)

-- There may be several distinct ways for a subtree to conditionally
-- (i.e. with a Test) or unconditionally accept 0 characters.  These
-- are in the list in order of preference, with most preferred listed
-- first.
type NullView = [(SetTestInfo,TagList)]  -- Ordered list of null views, each is a set of tests and tags

-- During the depth first traversal, children are told about tags by the parent.
-- They may change Apply to Advice and they may generate new tags.
data HandleTag = NoTag             -- No tag at this boundary
               | Advice Tag        -- tag at this boundary, applied at higher level in tree
               | Apply Tag         -- tag at this boundary, may be applied at this node or passed to one child
                 deriving (GroupIndex -> HandleTag -> ShowS
[HandleTag] -> ShowS
HandleTag -> String
(GroupIndex -> HandleTag -> ShowS)
-> (HandleTag -> String)
-> ([HandleTag] -> ShowS)
-> Show HandleTag
forall a.
(GroupIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: GroupIndex -> HandleTag -> ShowS
showsPrec :: GroupIndex -> HandleTag -> ShowS
$cshow :: HandleTag -> String
show :: HandleTag -> String
$cshowList :: [HandleTag] -> ShowS
showList :: [HandleTag] -> ShowS
Show)

-- Nodes in the tree are labeled by the type kind of continuation they
-- prefer to be passed when processing.  This makes it possible to
-- create a smaller number of QNFA states and avoid creating wasteful
-- QNFA states that won't be reachable in the final automata.
--
-- In practice WantsBoth is treated identically to WantsQNFA and
-- WantsBoth could be removed.
data Wanted = WantsQNFA | WantsQT | WantsBoth | WantsEither deriving (Wanted -> Wanted -> Bool
(Wanted -> Wanted -> Bool)
-> (Wanted -> Wanted -> Bool) -> Eq Wanted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Wanted -> Wanted -> Bool
== :: Wanted -> Wanted -> Bool
$c/= :: Wanted -> Wanted -> Bool
/= :: Wanted -> Wanted -> Bool
Eq,GroupIndex -> Wanted -> ShowS
[Wanted] -> ShowS
Wanted -> String
(GroupIndex -> Wanted -> ShowS)
-> (Wanted -> String) -> ([Wanted] -> ShowS) -> Show Wanted
forall a.
(GroupIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: GroupIndex -> Wanted -> ShowS
showsPrec :: GroupIndex -> Wanted -> ShowS
$cshow :: Wanted -> String
show :: Wanted -> String
$cshowList :: [Wanted] -> ShowS
showList :: [Wanted] -> ShowS
Show)

instance Show Q where
  show :: Q -> String
show = Q -> String
showQ

showQ :: Q -> String
showQ :: Q -> String
showQ Q
q = String
"Q { nullQ = "String -> ShowS
forall a. [a] -> [a] -> [a]
++NullView -> String
forall a. Show a => a -> String
show (Q -> NullView
nullQ Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , takes = "String -> ShowS
forall a. [a] -> [a] -> [a]
++(GroupIndex, Maybe GroupIndex) -> String
forall a. Show a => a -> String
show (Q -> (GroupIndex, Maybe GroupIndex)
takes Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , preReset = "String -> ShowS
forall a. [a] -> [a] -> [a]
++[GroupIndex] -> String
forall a. Show a => a -> String
show (Q -> [GroupIndex]
preReset Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , postSet = "String -> ShowS
forall a. [a] -> [a] -> [a]
++[GroupIndex] -> String
forall a. Show a => a -> String
show (Q -> [GroupIndex]
postSet Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , preTag = "String -> ShowS
forall a. [a] -> [a] -> [a]
++Maybe GroupIndex -> String
forall a. Show a => a -> String
show (Q -> Maybe GroupIndex
preTag Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , postTag = "String -> ShowS
forall a. [a] -> [a] -> [a]
++Maybe GroupIndex -> String
forall a. Show a => a -> String
show (Q -> Maybe GroupIndex
postTag Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , tagged = "String -> ShowS
forall a. [a] -> [a] -> [a]
++Bool -> String
forall a. Show a => a -> String
show (Q -> Bool
tagged Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , wants = "String -> ShowS
forall a. [a] -> [a] -> [a]
++Wanted -> String
forall a. Show a => a -> String
show (Q -> Wanted
wants Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\n  , unQ = "String -> ShowS
forall a. [a] -> [a] -> [a]
++ P -> String
indent' (Q -> P
unQ Q
q)String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" }"
   where indent' :: P -> String
indent' = [String] -> String
unlines ([String] -> String) -> (P -> [String]) -> P -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[String]
s -> case [String]
s of
                                      [] -> []
                                      (String
h:[String]
t) -> String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
spaces String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
t)) ([String] -> [String]) -> (P -> [String]) -> P -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (P -> String) -> P -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P -> String
forall a. Show a => a -> String
show
         spaces :: String
spaces = GroupIndex -> Char -> String
forall a. GroupIndex -> a -> [a]
replicate GroupIndex
10 Char
' '

-- Smart constructors for NullView
notNull :: NullView
notNull :: NullView
notNull = []

-- Shorthand for combining a preTag and a postTag
-- preTags :: Maybe Tag -> Maybe Tag -> TagList
-- preTags a b = promote a `mappend` promote b
--   where promote = maybe [] (\x -> [(x,PreUpdate TagTask)])

promotePreTag :: HandleTag -> TagList
promotePreTag :: HandleTag -> TagList
promotePreTag = TagList -> (GroupIndex -> TagList) -> Maybe GroupIndex -> TagList
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\GroupIndex
x -> [(GroupIndex
x,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)]) (Maybe GroupIndex -> TagList)
-> (HandleTag -> Maybe GroupIndex) -> HandleTag -> TagList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleTag -> Maybe GroupIndex
apply

makeEmptyNullView :: HandleTag -> HandleTag -> NullView
makeEmptyNullView :: HandleTag -> HandleTag -> NullView
makeEmptyNullView HandleTag
a HandleTag
b = [(SetTestInfo
forall a. Monoid a => a
mempty, HandleTag -> TagList
promotePreTag HandleTag
a TagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++ HandleTag -> TagList
promotePreTag HandleTag
b)]

makeTestNullView ::  TestInfo -> HandleTag -> HandleTag -> NullView
makeTestNullView :: TestInfo -> HandleTag -> HandleTag -> NullView
makeTestNullView (WhichTest
w,DoPa
d) HandleTag
a HandleTag
b = [(EnumMap WhichTest (EnumSet DoPa) -> SetTestInfo
SetTestInfo (WhichTest -> EnumSet DoPa -> EnumMap WhichTest (EnumSet DoPa)
forall key a. Enum key => key -> a -> EnumMap key a
Map.singleton WhichTest
w (DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e
Set.singleton DoPa
d)), HandleTag -> TagList
promotePreTag HandleTag
a TagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++ HandleTag -> TagList
promotePreTag HandleTag
b)]

tagWrapNullView :: HandleTag -> HandleTag -> NullView -> NullView
tagWrapNullView :: HandleTag -> HandleTag -> NullView -> NullView
tagWrapNullView HandleTag
a HandleTag
b NullView
oldNV =
  case (HandleTag -> TagList
promotePreTag HandleTag
a, HandleTag -> TagList
promotePreTag HandleTag
b) of
    ([],[]) -> NullView
oldNV
    (TagList
pre,TagList
post) -> do
      (SetTestInfo
oldTests,TagList
oldTasks) <- NullView
oldNV
      (SetTestInfo, TagList) -> NullView
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (SetTestInfo
oldTests,TagList
preTagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++TagList
oldTasksTagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++TagList
post)

-- For PGroup, need to prepend reset tasks before others in nullView
addGroupResetsToNullView :: [Tag] -> Tag -> NullView -> NullView
addGroupResetsToNullView :: [GroupIndex] -> GroupIndex -> NullView -> NullView
addGroupResetsToNullView [GroupIndex]
groupResets GroupIndex
groupSet NullView
nv = [ (SetTestInfo
test, TagList -> TagList
prepend (TagList -> TagList
append TagList
tags) ) | (SetTestInfo
test,TagList
tags) <- NullView
nv ]
  where prepend :: TagList -> TagList
prepend = ((GroupIndex, TagUpdate)
 -> (TagList -> TagList) -> TagList -> TagList)
-> (TagList -> TagList) -> TagList -> TagList -> TagList
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GroupIndex, TagUpdate)
h TagList -> TagList
t -> ((GroupIndex, TagUpdate)
h(GroupIndex, TagUpdate) -> TagList -> TagList
forall a. a -> [a] -> [a]
:)(TagList -> TagList) -> (TagList -> TagList) -> TagList -> TagList
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TagList -> TagList
t) TagList -> TagList
forall a. a -> a
id (TagList -> TagList -> TagList)
-> ([GroupIndex] -> TagList) -> [GroupIndex] -> TagList -> TagList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupIndex -> (GroupIndex, TagUpdate)) -> [GroupIndex] -> TagList
forall a b. (a -> b) -> [a] -> [b]
map (\GroupIndex
tag->(GroupIndex
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetGroupStopTask)) ([GroupIndex] -> TagList -> TagList)
-> [GroupIndex] -> TagList -> TagList
forall a b. (a -> b) -> a -> b
$ [GroupIndex]
groupResets
        append :: TagList -> TagList
append = (TagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++[(GroupIndex
groupSet,TagTask -> TagUpdate
PreUpdate TagTask
SetGroupStopTask)])

-- For PStar, need to put in the orbit TagTasks
orbitWrapNullView :: Maybe Tag -> [Tag] -> NullView -> NullView
orbitWrapNullView :: Maybe GroupIndex -> [GroupIndex] -> NullView -> NullView
orbitWrapNullView Maybe GroupIndex
mOrbit [GroupIndex]
orbitResets NullView
oldNV =
  case (Maybe GroupIndex
mOrbit,[GroupIndex]
orbitResets) of
    (Maybe GroupIndex
Nothing,[]) -> NullView
oldNV
    (Maybe GroupIndex
Nothing,[GroupIndex]
_) -> do (SetTestInfo
oldTests,TagList
oldTasks) <- NullView
oldNV
                      (SetTestInfo, TagList) -> NullView
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (SetTestInfo
oldTests,TagList -> TagList
prepend TagList
oldTasks)
    (Just GroupIndex
o,[GroupIndex]
_) -> do (SetTestInfo
oldTests,TagList
oldTasks) <- NullView
oldNV
                     (SetTestInfo, TagList) -> NullView
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (SetTestInfo
oldTests,TagList -> TagList
prepend (TagList -> TagList) -> TagList -> TagList
forall a b. (a -> b) -> a -> b
$ [(GroupIndex
o,TagTask -> TagUpdate
PreUpdate TagTask
EnterOrbitTask)] TagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++ TagList
oldTasks TagList -> TagList -> TagList
forall a. [a] -> [a] -> [a]
++ [(GroupIndex
o,TagTask -> TagUpdate
PreUpdate TagTask
LeaveOrbitTask)])
  where prepend :: TagList -> TagList
prepend = ((GroupIndex, TagUpdate)
 -> (TagList -> TagList) -> TagList -> TagList)
-> (TagList -> TagList) -> TagList -> TagList -> TagList
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GroupIndex, TagUpdate)
h TagList -> TagList
t -> ((GroupIndex, TagUpdate)
h(GroupIndex, TagUpdate) -> TagList -> TagList
forall a. a -> [a] -> [a]
:)(TagList -> TagList) -> (TagList -> TagList) -> TagList -> TagList
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TagList -> TagList
t) TagList -> TagList
forall a. a -> a
id (TagList -> TagList -> TagList)
-> ([GroupIndex] -> TagList) -> [GroupIndex] -> TagList -> TagList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupIndex -> (GroupIndex, TagUpdate)) -> [GroupIndex] -> TagList
forall a b. (a -> b) -> [a] -> [b]
map (\GroupIndex
tag->(GroupIndex
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetOrbitTask)) ([GroupIndex] -> TagList -> TagList)
-> [GroupIndex] -> TagList -> TagList
forall a b. (a -> b) -> a -> b
$ [GroupIndex]
orbitResets

-- The NullViews are ordered, and later test sets that contain the
-- tests from any earlier entry will never be chosen.  This function
-- returns a list with these redundant elements removed.  Note that
-- the first unconditional entry in the list will be the last entry of
-- the returned list since the empty set is a subset of any other set.
cleanNullView :: NullView -> NullView
cleanNullView :: NullView -> NullView
cleanNullView [] = []
cleanNullView (first :: (SetTestInfo, TagList)
first@(SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,TagList
_):NullView
rest) | EnumMap WhichTest (EnumSet DoPa) -> Bool
forall key a. Enum key => EnumMap key a -> Bool
Map.null EnumMap WhichTest (EnumSet DoPa)
sti = (SetTestInfo, TagList)
first (SetTestInfo, TagList) -> NullView -> NullView
forall a. a -> [a] -> [a]
: []  -- optimization
                                               | Bool
otherwise =
  (SetTestInfo, TagList)
first (SetTestInfo, TagList) -> NullView -> NullView
forall a. a -> [a] -> [a]
: NullView -> NullView
cleanNullView (((SetTestInfo, TagList) -> Bool) -> NullView -> NullView
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((SetTestInfo, TagList) -> Bool)
-> (SetTestInfo, TagList)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumSet WhichTest
setTI EnumSet WhichTest -> EnumSet WhichTest -> Bool
forall e. Enum e => EnumSet e -> EnumSet e -> Bool
`Set.isSubsetOf`) (EnumSet WhichTest -> Bool)
-> ((SetTestInfo, TagList) -> EnumSet WhichTest)
-> (SetTestInfo, TagList)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest
forall key a. Enum key => EnumMap key a -> EnumSet key
Map.keysSet (EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest)
-> ((SetTestInfo, TagList) -> EnumMap WhichTest (EnumSet DoPa))
-> (SetTestInfo, TagList)
-> EnumSet WhichTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetTestInfo -> EnumMap WhichTest (EnumSet DoPa)
getTests (SetTestInfo -> EnumMap WhichTest (EnumSet DoPa))
-> ((SetTestInfo, TagList) -> SetTestInfo)
-> (SetTestInfo, TagList)
-> EnumMap WhichTest (EnumSet DoPa)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SetTestInfo, TagList) -> SetTestInfo
forall a b. (a, b) -> a
fst) NullView
rest)
  where setTI :: EnumSet WhichTest
setTI = EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest
forall key a. Enum key => EnumMap key a -> EnumSet key
Map.keysSet EnumMap WhichTest (EnumSet DoPa)
sti

-- Ordered Sequence of two NullViews: all ordered combinations of tests and tags.
-- Order of <- s1 and <- s2 is deliberately chosen to maintain preference priority
mergeNullViews :: NullView -> NullView -> NullView
mergeNullViews :: NullView -> NullView -> NullView
mergeNullViews NullView
s1 NullView
s2 = NullView -> NullView
cleanNullView (NullView -> NullView) -> NullView -> NullView
forall a b. (a -> b) -> a -> b
$ do
  (SetTestInfo
test1,TagList
tag1) <- NullView
s1
  (SetTestInfo
test2,TagList
tag2) <- NullView
s2
  (SetTestInfo, TagList) -> NullView
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (SetTestInfo -> SetTestInfo -> SetTestInfo
forall a. Monoid a => a -> a -> a
mappend SetTestInfo
test1 SetTestInfo
test2,TagList -> TagList -> TagList
forall a. Monoid a => a -> a -> a
mappend TagList
tag1 TagList
tag2)
-- mergeNullViews = cleanNullView $ liftM2 (mappend *** mappend)

-- Concatenated two ranges of number of accepted characters
seqTake :: (Int, Maybe Int) -> (Int, Maybe Int) -> (Int, Maybe Int)
seqTake :: (GroupIndex, Maybe GroupIndex)
-> (GroupIndex, Maybe GroupIndex) -> (GroupIndex, Maybe GroupIndex)
seqTake (GroupIndex
x1,Maybe GroupIndex
y1) (GroupIndex
x2,Maybe GroupIndex
y2) = (GroupIndex
x1GroupIndex -> GroupIndex -> GroupIndex
forall a. Num a => a -> a -> a
+GroupIndex
x2,(GroupIndex -> GroupIndex -> GroupIndex)
-> Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 GroupIndex -> GroupIndex -> GroupIndex
forall a. Num a => a -> a -> a
(+) Maybe GroupIndex
y1 Maybe GroupIndex
y2)

-- Parallel combination of list of ranges of number of accepted characters
orTakes :: [(Int, Maybe Int)] -> (Int,Maybe Int)
orTakes :: [(GroupIndex, Maybe GroupIndex)] -> (GroupIndex, Maybe GroupIndex)
orTakes [] = (GroupIndex
0,GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
0)
orTakes [(GroupIndex, Maybe GroupIndex)]
ts = let ([GroupIndex]
xs,[Maybe GroupIndex]
ys) = [(GroupIndex, Maybe GroupIndex)]
-> ([GroupIndex], [Maybe GroupIndex])
forall a b. [(a, b)] -> ([a], [b])
unzip [(GroupIndex, Maybe GroupIndex)]
ts
             in ([GroupIndex] -> GroupIndex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [GroupIndex]
xs, (Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex)
-> [Maybe GroupIndex] -> Maybe GroupIndex
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ((GroupIndex -> GroupIndex -> GroupIndex)
-> Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 GroupIndex -> GroupIndex -> GroupIndex
forall a. Ord a => a -> a -> a
max) [Maybe GroupIndex]
ys)

-- Invariant: apply (toAdvice _ ) == mempty
apply :: HandleTag -> Maybe Tag
apply :: HandleTag -> Maybe GroupIndex
apply (Apply GroupIndex
tag) = GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
tag
apply HandleTag
_ = Maybe GroupIndex
forall a. Maybe a
Nothing
toAdvice :: HandleTag -> HandleTag
toAdvice :: HandleTag -> HandleTag
toAdvice (Apply GroupIndex
tag) = GroupIndex -> HandleTag
Advice GroupIndex
tag
toAdvice HandleTag
s = HandleTag
s
noTag :: HandleTag -> Bool
noTag :: HandleTag -> Bool
noTag HandleTag
NoTag = Bool
True
noTag HandleTag
_ = Bool
False
fromHandleTag :: HandleTag -> Tag
fromHandleTag :: HandleTag -> GroupIndex
fromHandleTag (Apply GroupIndex
tag) = GroupIndex
tag
fromHandleTag (Advice GroupIndex
tag) = GroupIndex
tag
fromHandleTag HandleTag
_ = String -> GroupIndex
forall a. HasCallStack => String -> a
error String
"fromHandleTag"

-- Predicates on the range of number of accepted  characters
varies :: Q -> Bool
varies :: Q -> Bool
varies Q {takes :: Q -> (GroupIndex, Maybe GroupIndex)
takes = (GroupIndex
_,Maybe GroupIndex
Nothing)} = Bool
True
varies Q {takes :: Q -> (GroupIndex, Maybe GroupIndex)
takes = (GroupIndex
x,Just GroupIndex
y)} = GroupIndex
xGroupIndex -> GroupIndex -> Bool
forall a. Eq a => a -> a -> Bool
/=GroupIndex
y

mustAccept :: Q -> Bool
mustAccept :: Q -> Bool
mustAccept Q
q = (GroupIndex
0GroupIndex -> GroupIndex -> Bool
forall a. Eq a => a -> a -> Bool
/=) (GroupIndex -> Bool) -> (Q -> GroupIndex) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupIndex, Maybe GroupIndex) -> GroupIndex
forall a b. (a, b) -> a
fst ((GroupIndex, Maybe GroupIndex) -> GroupIndex)
-> (Q -> (GroupIndex, Maybe GroupIndex)) -> Q -> GroupIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> (GroupIndex, Maybe GroupIndex)
takes (Q -> Bool) -> Q -> Bool
forall a b. (a -> b) -> a -> b
$ Q
q

canAccept :: Q -> Bool
canAccept :: Q -> Bool
canAccept Q
q = Bool -> (GroupIndex -> Bool) -> Maybe GroupIndex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (GroupIndex
0GroupIndex -> GroupIndex -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Maybe GroupIndex -> Bool) -> Maybe GroupIndex -> Bool
forall a b. (a -> b) -> a -> b
$ (GroupIndex, Maybe GroupIndex) -> Maybe GroupIndex
forall a b. (a, b) -> b
snd ((GroupIndex, Maybe GroupIndex) -> Maybe GroupIndex)
-> (Q -> (GroupIndex, Maybe GroupIndex)) -> Q -> Maybe GroupIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> (GroupIndex, Maybe GroupIndex)
takes (Q -> Maybe GroupIndex) -> Q -> Maybe GroupIndex
forall a b. (a -> b) -> a -> b
$ Q
q

cannotAccept :: Q -> Bool
cannotAccept :: Q -> Bool
cannotAccept Q
q = Bool -> (GroupIndex -> Bool) -> Maybe GroupIndex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (GroupIndex
0GroupIndex -> GroupIndex -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe GroupIndex -> Bool) -> Maybe GroupIndex -> Bool
forall a b. (a -> b) -> a -> b
$ (GroupIndex, Maybe GroupIndex) -> Maybe GroupIndex
forall a b. (a, b) -> b
snd ((GroupIndex, Maybe GroupIndex) -> Maybe GroupIndex)
-> (Q -> (GroupIndex, Maybe GroupIndex)) -> Q -> Maybe GroupIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> (GroupIndex, Maybe GroupIndex)
takes (Q -> Maybe GroupIndex) -> Q -> Maybe GroupIndex
forall a b. (a -> b) -> a -> b
$ Q
q

-- This converts then input Pattern to an analyzed Q structure with
-- the tags assigned.
--
-- The analysis is filled in by a depth first search and the tags are
-- created top down and passed to children.  Thus information flows up
-- from the dfs of the children and simultaneously down in the form of
-- pre and post HandleTag data.  This bidirectional flow is handled
-- declaratively by using the MonadFix (i.e. mdo).
--
-- Invariant: A tag should exist in Q in exactly one place (and will
-- be in a preTag,postTag, or getOrbit field).  This is partly because
-- PGroup needs to know the tags are around precisely the expression
-- that it wants to record.  If the same tag were in other branches
-- then this would no longer be true.  The tag may or may not also
-- show up in one or more preReset list or resetOrbits list.
--
-- This invariant is enforced by each node either taking
-- responsibility (apply) for a passed in / created tag or sending it
-- to exactly one child node.  Other child nodes need to receive it
-- via toAdvice.  Leaf nodes are forced to apply any passed tags.
--
-- There is a final "qwin of Q {postTag=ISet.singleton 1}" and an
-- implied initial index tag of 0.
--
-- favoring pushing Apply into the child postTag makes PGroup happier

type PM = RWS (Maybe GroupIndex) [Either Tag GroupInfo] ([OP]->[OP],Tag)
type HHQ = HandleTag  -- m1 : info about left boundary / preTag
        -> HandleTag  -- m2 : info about right boundary / postTag
        -> PM Q

-- There is no group 0 here, since it is always the whole match and has no parent of its own
makeGroupArray :: GroupIndex -> [GroupInfo] -> Array GroupIndex [GroupInfo]
makeGroupArray :: GroupIndex -> [GroupInfo] -> Array GroupIndex [GroupInfo]
makeGroupArray GroupIndex
maxGroupIndex [GroupInfo]
groups = ([GroupInfo] -> GroupInfo -> [GroupInfo])
-> [GroupInfo]
-> (GroupIndex, GroupIndex)
-> [(GroupIndex, GroupInfo)]
-> Array GroupIndex [GroupInfo]
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray (\[GroupInfo]
earlier GroupInfo
later -> GroupInfo
laterGroupInfo -> [GroupInfo] -> [GroupInfo]
forall a. a -> [a] -> [a]
:[GroupInfo]
earlier) [] (GroupIndex
1,GroupIndex
maxGroupIndex) [(GroupIndex, GroupInfo)]
filler
    where filler :: [(GroupIndex, GroupInfo)]
filler = (GroupInfo -> (GroupIndex, GroupInfo))
-> [GroupInfo] -> [(GroupIndex, GroupInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\GroupInfo
gi -> (GroupInfo -> GroupIndex
thisIndex GroupInfo
gi,GroupInfo
gi)) [GroupInfo]
groups

-- Partial function: assumes starTrans has been run on the Pattern
-- Note that the lazy dependency chain for this very zigzag:
--   varies information is sent up the tree
--   handle tags depend on that and sends m1 m2 down the tree
--     makeGroup sends some tags to the writer (Right _)
--     withParent listens to children send group info to writer
--       and lazily looks resetGroupTags from aGroups, the result of all writer (Right _)
--       preReset stores the resetGroupTags result of the lookup in the tree
--     makeOrbit sends some tags to the writer (Left _)
--     withOrbit listens to children send orbit info to writer for resetOrbitTags
--   nullQ depends m1 m2 and resetOrbitTags and resetGroupTags and is sent up the tree
patternToQ :: CompOption -> (Pattern,(GroupIndex,DoPa)) -> (Q,Array Tag OP,Array GroupIndex [GroupInfo])
patternToQ :: CompOption
-> (Pattern, (GroupIndex, DoPa))
-> (Q, Array GroupIndex OP, Array GroupIndex [GroupInfo])
patternToQ CompOption
compOpt (Pattern
pOrig,(GroupIndex
maxGroupIndex,DoPa
_)) = (Q
tnfa,Array GroupIndex OP
aTags,Array GroupIndex [GroupInfo]
aGroups) where
  (Q
tnfa,([OP] -> [OP]
tag_dlist,GroupIndex
nextTag),[Either GroupIndex GroupInfo]
groups) = RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
-> Maybe GroupIndex
-> ([OP] -> [OP], GroupIndex)
-> (Q, ([OP] -> [OP], GroupIndex), [Either GroupIndex GroupInfo])
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
monad Maybe GroupIndex
startReader ([OP] -> [OP], GroupIndex)
startState
  aTags :: Array GroupIndex OP
aTags = (GroupIndex, GroupIndex) -> [OP] -> Array GroupIndex OP
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (GroupIndex
0,GroupIndex -> GroupIndex
forall a. Enum a => a -> a
pred GroupIndex
nextTag) ([OP] -> [OP]
tag_dlist [])
  aGroups :: Array GroupIndex [GroupInfo]
aGroups = GroupIndex -> [GroupInfo] -> Array GroupIndex [GroupInfo]
makeGroupArray GroupIndex
maxGroupIndex ([Either GroupIndex GroupInfo] -> [GroupInfo]
forall a b. [Either a b] -> [b]
rights [Either GroupIndex GroupInfo]
groups)

  -- implicitly inside a PGroup 0 converted into a GroupInfo 0 undefined 0 1
  monad :: RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
monad = Pattern -> HHQ
go (Pattern -> Pattern
starTrans Pattern
pOrig) (GroupIndex -> HandleTag
Advice GroupIndex
0) (GroupIndex -> HandleTag
Advice GroupIndex
1)
  -- startReader is accessed by getParentIndex and changed by nonCapture and withParent
  startReader :: Maybe GroupIndex
  startReader :: Maybe GroupIndex
startReader = GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
0                           -- start inside group 0, capturing enabled
  -- The startState is only acted upon in the "uniq" command
  -- Tag 0 is Minimized and Tag 1 is maximized, next tag has value of 2
  -- This is regardless of right or left associativity
  startState :: ([OP]->[OP],Tag)
  startState :: ([OP] -> [OP], GroupIndex)
startState = ( (OP
MinimizeOP -> [OP] -> [OP]
forall a. a -> [a] -> [a]
:) ([OP] -> [OP]) -> ([OP] -> [OP]) -> [OP] -> [OP]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OP
MaximizeOP -> [OP] -> [OP]
forall a. a -> [a] -> [a]
:) , GroupIndex
2)

  -- uniq uses MonadState and always returns an "Apply _" tag
  {-# INLINE uniq #-}
  uniq :: String -> PM HandleTag
  uniq :: String -> PM HandleTag
uniq String
_msg = (GroupIndex -> HandleTag)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
-> PM HandleTag
forall a b.
(a -> b)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupIndex -> HandleTag
Apply (OP
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
uniq' OP
Maximize)
--  uniq _msg = do x <- fmap Apply (uniq' Maximize)
--                trace ('\n':msg ++ " Maximize "++show x) $ return x
--                return x

  ignore :: String -> PM Tag
  ignore :: String
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
ignore String
_msg = OP
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
uniq' OP
Ignore
--  ignore _msg = do x <- uniq' Ignore
--                  trace ('\n':msg ++ " Ignore "++show x) $ return x
--                  return x

  {-# NOINLINE uniq' #-}
  uniq' :: OP -> PM Tag
  uniq' :: OP
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
uniq' OP
newOp = do
    ([OP] -> [OP]
op,GroupIndex
s) <- RWST
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Identity
  ([OP] -> [OP], GroupIndex)
forall s (m :: * -> *). MonadState s m => m s
get                -- generate the next tag with bias newOp
    let op' :: [OP] -> [OP]
op' = [OP] -> [OP]
op ([OP] -> [OP]) -> ([OP] -> [OP]) -> [OP] -> [OP]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OP
newOpOP -> [OP] -> [OP]
forall a. a -> [a] -> [a]
:)
        s' :: GroupIndex
s' = GroupIndex -> GroupIndex
forall a. Enum a => a -> a
succ GroupIndex
s
    ([OP] -> [OP], GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (([OP] -> [OP], GroupIndex)
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      ())
-> ([OP] -> [OP], GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
forall a b. (a -> b) -> a -> b
$! ([OP] -> [OP]
op',GroupIndex
s')
    GroupIndex
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return GroupIndex
s

  {-# INLINE makeOrbit #-}
  -- Specialize the monad operations and give more meaningful names
  -- makeOrbit uses MonadState(uniq) and MonadWriter(tell/Left)
  makeOrbit :: PM (Maybe Tag)
  makeOrbit :: PM (Maybe GroupIndex)
makeOrbit = do GroupIndex
x <- OP
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
uniq' OP
Orbit
--                 trace ('\n':"PStar Orbit "++show x) $ do
                 [Either GroupIndex GroupInfo]
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [GroupIndex -> Either GroupIndex GroupInfo
forall a b. a -> Either a b
Left GroupIndex
x]
                 Maybe GroupIndex -> PM (Maybe GroupIndex)
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
x)

  {-# INLINE withOrbit #-}
  -- withOrbit uses MonadWriter(listens to makeOrbit/Left), collects
  -- children at all depths
  withOrbit :: PM a -> PM (a,[Tag])
  withOrbit :: forall a. PM a -> PM (a, [GroupIndex])
withOrbit = ([Either GroupIndex GroupInfo] -> [GroupIndex])
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
forall w (m :: * -> *) b a.
MonadWriter w m =>
(w -> b) -> m a -> m (a, b)
listens (([Either GroupIndex GroupInfo] -> [GroupIndex])
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      a
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      (a, [GroupIndex]))
-> ([Either GroupIndex GroupInfo] -> [GroupIndex])
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
forall a b. (a -> b) -> a -> b
$ ([GroupIndex], [GroupInfo]) -> [GroupIndex]
forall a b. (a, b) -> a
fst (([GroupIndex], [GroupInfo]) -> [GroupIndex])
-> ([Either GroupIndex GroupInfo] -> ([GroupIndex], [GroupInfo]))
-> [Either GroupIndex GroupInfo]
-> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either GroupIndex GroupInfo] -> ([GroupIndex], [GroupInfo])
forall a b. [Either a b] -> ([a], [b])
partitionEithers

  {-# INLINE makeGroup #-}
  -- makeGroup usesMonadWriter(tell/Right)
  makeGroup :: GroupInfo -> PM ()
  makeGroup :: GroupInfo
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
makeGroup = [Either GroupIndex GroupInfo]
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([Either GroupIndex GroupInfo]
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      ())
-> (GroupInfo -> [Either GroupIndex GroupInfo])
-> GroupInfo
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either GroupIndex GroupInfo
-> [Either GroupIndex GroupInfo] -> [Either GroupIndex GroupInfo]
forall a. a -> [a] -> [a]
:[]) (Either GroupIndex GroupInfo -> [Either GroupIndex GroupInfo])
-> (GroupInfo -> Either GroupIndex GroupInfo)
-> GroupInfo
-> [Either GroupIndex GroupInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupInfo -> Either GroupIndex GroupInfo
forall a b. b -> Either a b
Right

  {-# INLINE getParentIndex #-}
  -- getParentIndex uses MonadReader(ask)
  getParentIndex :: PM (Maybe GroupIndex)
  getParentIndex :: PM (Maybe GroupIndex)
getParentIndex = PM (Maybe GroupIndex)
forall r (m :: * -> *). MonadReader r m => m r
ask

  {-# INLINE nonCapture #-}
  -- nonCapture uses MonadReader(local) to suppress getParentIndex to return Nothing
  nonCapture :: PM  a -> PM a
  nonCapture :: forall a. PM a -> PM a
nonCapture = (Maybe GroupIndex -> Maybe GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall a.
(Maybe GroupIndex -> Maybe GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex
forall a b. a -> b -> a
const Maybe GroupIndex
forall a. Maybe a
Nothing)

  -- withParent uses MonadReader(local) to set getParentIndex to return (Just this)
  -- withParent uses MonadWriter(listens to makeGroup/Right) to return contained group indices (stopTag)
  -- withParent is only safe if getParentIndex has been checked to be not equal to Nothing (see PGroup below)
  -- Note use of laziness: the immediate children's group index is used to look up all copies of the
  -- group in aGroups, including copies that are not immediate children.
  withParent :: GroupIndex -> PM a -> PM (a,[Tag])
  withParent :: forall a. GroupIndex -> PM a -> PM (a, [GroupIndex])
withParent GroupIndex
this = (Maybe GroupIndex -> Maybe GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
forall a.
(Maybe GroupIndex -> Maybe GroupIndex)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex
forall a b. a -> b -> a
const (GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
this)) (RWST
   (Maybe GroupIndex)
   [Either GroupIndex GroupInfo]
   ([OP] -> [OP], GroupIndex)
   Identity
   (a, [GroupIndex])
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      (a, [GroupIndex]))
-> (PM a
    -> RWST
         (Maybe GroupIndex)
         [Either GroupIndex GroupInfo]
         ([OP] -> [OP], GroupIndex)
         Identity
         (a, [GroupIndex]))
-> PM a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either GroupIndex GroupInfo] -> [GroupIndex])
-> PM a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a, [GroupIndex])
forall w (m :: * -> *) b a.
MonadWriter w m =>
(w -> b) -> m a -> m (a, b)
listens [Either GroupIndex GroupInfo] -> [GroupIndex]
forall {a}. [Either a GroupInfo] -> [GroupIndex]
childGroupInfo
    where childGroupInfo :: [Either a GroupInfo] -> [GroupIndex]
childGroupInfo [Either a GroupInfo]
x =
            let gs :: [GroupInfo]
gs = ([a], [GroupInfo]) -> [GroupInfo]
forall a b. (a, b) -> b
snd (([a], [GroupInfo]) -> [GroupInfo])
-> ([a], [GroupInfo]) -> [GroupInfo]
forall a b. (a -> b) -> a -> b
$ [Either a GroupInfo] -> ([a], [GroupInfo])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a GroupInfo]
x
                children :: [GroupIndex]
                children :: [GroupIndex]
children = [GroupIndex] -> [GroupIndex]
forall a. Eq a => [a] -> [a]
norep ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupIndex]) -> [GroupInfo] -> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroupIndex] -> [GroupIndex]
forall a. Ord a => [a] -> [a]
sort ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupIndex]) -> [GroupInfo] -> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupInfo -> GroupIndex) -> [GroupInfo] -> [GroupIndex]
forall a b. (a -> b) -> [a] -> [b]
map GroupInfo -> GroupIndex
thisIndex
                           -- filter to get only immediate children (efficiency)
                           ([GroupInfo] -> [GroupIndex])
-> ([GroupInfo] -> [GroupInfo]) -> [GroupInfo] -> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupInfo -> Bool) -> [GroupInfo] -> [GroupInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GroupIndex
thisGroupIndex -> GroupIndex -> Bool
forall a. Eq a => a -> a -> Bool
==)(GroupIndex -> Bool)
-> (GroupInfo -> GroupIndex) -> GroupInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.GroupInfo -> GroupIndex
parentIndex) ([GroupInfo] -> [GroupIndex]) -> [GroupInfo] -> [GroupIndex]
forall a b. (a -> b) -> a -> b
$ [GroupInfo]
gs
            in (GroupIndex -> [GroupIndex]) -> [GroupIndex] -> [GroupIndex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((GroupInfo -> GroupIndex) -> [GroupInfo] -> [GroupIndex]
forall a b. (a -> b) -> [a] -> [b]
map GroupInfo -> GroupIndex
flagTag ([GroupInfo] -> [GroupIndex])
-> (GroupIndex -> [GroupInfo]) -> GroupIndex -> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array GroupIndex [GroupInfo]
aGroupsArray GroupIndex [GroupInfo] -> GroupIndex -> [GroupInfo]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!)) (GroupIndex
thisGroupIndex -> [GroupIndex] -> [GroupIndex]
forall a. a -> [a] -> [a]
:[GroupIndex]
children)

  -- combineConcat is a partial function: Must not pass in an empty list
  -- Policy choices:
  --  * pass tags to apply to children and have no preTag or postTag here (so none added to nullQ)
  --  * middle 'mid' tag: give to left/front child as postTag so a Group there might claim it as a stopTag
  --  * if parent is Group then preReset will become non-empty
  combineConcat :: [Pattern] -> HHQ
  combineConcat :: [Pattern] -> HHQ
combineConcat | CompOption -> Bool
rightAssoc CompOption
compOpt = (HHQ -> HHQ -> HHQ) -> [HHQ] -> HHQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 HHQ -> HHQ -> HHQ
combineSeq ([HHQ] -> HHQ) -> ([Pattern] -> [HHQ]) -> [Pattern] -> HHQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> HHQ) -> [Pattern] -> [HHQ]
forall a b. (a -> b) -> [a] -> [b]
map Pattern -> HHQ
go
                | Bool
otherwise          = (HHQ -> HHQ -> HHQ) -> [HHQ] -> HHQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 HHQ -> HHQ -> HHQ
combineSeq ([HHQ] -> HHQ) -> ([Pattern] -> [HHQ]) -> [Pattern] -> HHQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> HHQ) -> [Pattern] -> [HHQ]
forall a b. (a -> b) -> [a] -> [b]
map Pattern -> HHQ
go -- libtre default
    where {-# INLINE front'end #-}
          front'end :: RWST
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Identity
  a1
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a2
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a1, a2)
front'end | CompOption -> Bool
rightAssoc CompOption
compOpt = (a1 -> a2 -> (a1, a2))
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a1
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a2
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a1, a2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
                    | Bool
otherwise = (RWST
   (Maybe GroupIndex)
   [Either GroupIndex GroupInfo]
   ([OP] -> [OP], GroupIndex)
   Identity
   a2
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      a1
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      (a1, a2))
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a1
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a2
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a1, a2)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a2 -> a1 -> (a1, a2))
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a2
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a1
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a1, a2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 ((a1 -> a2 -> (a1, a2)) -> a2 -> a1 -> (a1, a2)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)))
          combineSeq :: HHQ -> HHQ -> HHQ
          combineSeq :: HHQ -> HHQ -> HHQ
combineSeq HHQ
pFront HHQ
pEnd = (\ HandleTag
m1 HandleTag
m2 -> mdo
            let bothVary :: Bool
bothVary = Q -> Bool
varies Q
qFront Bool -> Bool -> Bool
&& Q -> Bool
varies Q
qEnd
            HandleTag
a <- if HandleTag -> Bool
noTag HandleTag
m1 Bool -> Bool -> Bool
&& Bool
bothVary then String -> PM HandleTag
uniq String
"combineSeq start" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m1
            HandleTag
b <- if HandleTag -> Bool
noTag HandleTag
m2 Bool -> Bool -> Bool
&& Bool
bothVary then String -> PM HandleTag
uniq String
"combineSeq stop" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m2
            HandleTag
mid <- case (HandleTag -> Bool
noTag HandleTag
a,Q -> Bool
canAccept Q
qFront,HandleTag -> Bool
noTag HandleTag
b,Q -> Bool
canAccept Q
qEnd) of
                     (Bool
False,Bool
False,Bool
_,Bool
_) -> HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (HandleTag -> HandleTag
toAdvice HandleTag
a)
                     (Bool
_,Bool
_,Bool
False,Bool
False) -> HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (HandleTag -> HandleTag
toAdvice HandleTag
b)
                     (Bool, Bool, Bool, Bool)
_ -> if Q -> Bool
tagged Q
qFront Bool -> Bool -> Bool
|| Q -> Bool
tagged Q
qEnd then String -> PM HandleTag
uniq String
"combineSeq mid" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
NoTag
      --      qFront <- pFront a mid
      --      qEnd <- pEnd (toAdvice mid) b
            (Q
qFront,Q
qEnd) <- RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (Q, Q)
forall {a1} {a2}.
RWST
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Identity
  a1
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a2
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     (a1, a2)
front'end (HHQ
pFront HandleTag
a HandleTag
mid) (HHQ
pEnd (HandleTag -> HandleTag
toAdvice HandleTag
mid) HandleTag
b)
            -- XXX: Perhaps a "produces" should be created to compliment "wants",
            -- then "produces qEnd" could be compared to "wants qFront"
            let wanted :: Wanted
wanted = if Wanted
WantsEither Wanted -> Wanted -> Bool
forall a. Eq a => a -> a -> Bool
== Q -> Wanted
wants Q
qEnd then Q -> Wanted
wants Q
qFront else Q -> Wanted
wants Q
qEnd
            Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q
 -> RWS
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Q)
-> Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a b. (a -> b) -> a -> b
$ Q { nullQ :: NullView
nullQ = NullView -> NullView -> NullView
mergeNullViews (Q -> NullView
nullQ Q
qFront) (Q -> NullView
nullQ Q
qEnd)
                             , takes :: (GroupIndex, Maybe GroupIndex)
takes = (GroupIndex, Maybe GroupIndex)
-> (GroupIndex, Maybe GroupIndex) -> (GroupIndex, Maybe GroupIndex)
seqTake (Q -> (GroupIndex, Maybe GroupIndex)
takes Q
qFront) (Q -> (GroupIndex, Maybe GroupIndex)
takes Q
qEnd)
                             , preReset :: [GroupIndex]
preReset = [], postSet :: [GroupIndex]
postSet = [], preTag :: Maybe GroupIndex
preTag = Maybe GroupIndex
forall a. Maybe a
Nothing, postTag :: Maybe GroupIndex
postTag = Maybe GroupIndex
forall a. Maybe a
Nothing
                             , tagged :: Bool
tagged = Bool
bothVary
                             , childGroups :: Bool
childGroups = Q -> Bool
childGroups Q
qFront Bool -> Bool -> Bool
|| Q -> Bool
childGroups Q
qEnd
                             , wants :: Wanted
wants = Wanted
wanted
                             , unQ :: P
unQ = Q -> Q -> P
Seq Q
qFront Q
qEnd }
                                   )
  go :: Pattern -> HHQ
  go :: Pattern -> HHQ
go Pattern
pIn HandleTag
m1 HandleTag
m2 =
    let die :: a
die = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"patternToQ cannot handle "String -> ShowS
forall a. [a] -> [a] -> [a]
++Pattern -> String
forall a. Show a => a -> String
show Pattern
pIn
        nil :: RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
nil = Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q
 -> RWS
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Q)
-> Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a b. (a -> b) -> a -> b
$ Q {nullQ :: NullView
nullQ=HandleTag -> HandleTag -> NullView
makeEmptyNullView HandleTag
m1 HandleTag
m2
                         ,takes :: (GroupIndex, Maybe GroupIndex)
takes=(GroupIndex
0,GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
0)
                         ,preReset :: [GroupIndex]
preReset=[],postSet :: [GroupIndex]
postSet=[],preTag :: Maybe GroupIndex
preTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m1,postTag :: Maybe GroupIndex
postTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m2
                         ,tagged :: Bool
tagged=Bool
False,childGroups :: Bool
childGroups=Bool
False,wants :: Wanted
wants=Wanted
WantsEither
                         ,unQ :: P
unQ=P
Empty}
        one :: RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one = Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q
 -> RWS
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Q)
-> Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a b. (a -> b) -> a -> b
$ Q {nullQ :: NullView
nullQ=NullView
notNull
                         ,takes :: (GroupIndex, Maybe GroupIndex)
takes=(GroupIndex
1,GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
1)
                         ,preReset :: [GroupIndex]
preReset=[],postSet :: [GroupIndex]
postSet=[],preTag :: Maybe GroupIndex
preTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m1,postTag :: Maybe GroupIndex
postTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m2
                         ,tagged :: Bool
tagged=Bool
False,childGroups :: Bool
childGroups=Bool
False,wants :: Wanted
wants=Wanted
WantsQNFA
                         ,unQ :: P
unQ = Pattern -> P
OneChar Pattern
pIn}
        test :: TestInfo -> m Q
test TestInfo
myTest = Q -> m Q
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q -> m Q) -> Q -> m Q
forall a b. (a -> b) -> a -> b
$ Q {nullQ :: NullView
nullQ=TestInfo -> HandleTag -> HandleTag -> NullView
makeTestNullView TestInfo
myTest HandleTag
m1 HandleTag
m2
                                 ,takes :: (GroupIndex, Maybe GroupIndex)
takes=(GroupIndex
0,GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
0)
                                 ,preReset :: [GroupIndex]
preReset=[],postSet :: [GroupIndex]
postSet=[],preTag :: Maybe GroupIndex
preTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m1,postTag :: Maybe GroupIndex
postTag=HandleTag -> Maybe GroupIndex
apply HandleTag
m2
                                 ,tagged :: Bool
tagged=Bool
False,childGroups :: Bool
childGroups=Bool
False,wants :: Wanted
wants=Wanted
WantsQT
                                 ,unQ :: P
unQ=TestInfo -> P
Test TestInfo
myTest }
        xtra :: Bool
xtra = CompOption -> Bool
newSyntax CompOption
compOpt
    in case Pattern
pIn of
         Pattern
PEmpty -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
nil
         POr [] -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
nil
         POr [Pattern
branch] -> Pattern -> HHQ
go Pattern
branch HandleTag
m1 HandleTag
m2
         POr [Pattern]
branches -> mdo
           -- 2009 : The PNonEmpty p as POr [PEmpty,p] takes no branch tracking tag.
           --        I claim this is because only accepting branches need tags,
           --        and the last accepting branch does not need a tag.
           --        Non-accepting possibilities can all commute to the front and
           --        become part of the nullQ.  The accepting bits then need prioritizing.
           --    Does the above require changes in POr handling in TNFA?  Yes.
           --    Have to always use nullQ instead of "recapitulating" it.
           --    Could also create a constant-writing tag instead of many index tags.
           -- Exasperation: This POr recursive mdo is very easy to make loop and lockup the program
           -- if needTags is False then there is no way to disambiguate branches so fewer tags are needed
           let needUniqTags :: Bool
needUniqTags = Q -> Bool
childGroups Q
ans
           let needTags :: Bool
needTags = Q -> Bool
varies Q
ans Bool -> Bool -> Bool
|| Q -> Bool
childGroups Q
ans -- childGroups detects that "abc|a(b)c" needs tags
           HandleTag
a <- if HandleTag -> Bool
noTag HandleTag
m1 Bool -> Bool -> Bool
&& Bool
needTags then String -> PM HandleTag
uniq String
"POr start" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m1 -- whole POr
           HandleTag
b <- if HandleTag -> Bool
noTag HandleTag
m2 Bool -> Bool -> Bool
&& Bool
needTags then String -> PM HandleTag
uniq String
"POr stop" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m2 -- whole POr
           let aAdvice :: HandleTag
aAdvice = HandleTag -> HandleTag
toAdvice HandleTag
a -- all branches share 'aAdvice'
               bAdvice :: HandleTag
bAdvice = HandleTag -> HandleTag
toAdvice HandleTag
b -- last branch gets 'bAdvice', others may get own tag
               -- Due to the recursive-do, it seems that I have to put the if needTags into the op'
               newUniq :: PM HandleTag
newUniq = if Bool
needUniqTags then String -> PM HandleTag
uniq String
"POr branch" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
bAdvice
--           trace ("\nPOr sub "++show aAdvice++" "++show bAdvice++"needsTags is "++show needTags) $ return ()
           -- The "bs" values are allocated in left-to-right order before the children in "qs"
           -- optimization: low priority for last branch is implicit, do not create separate tag here.
           [HandleTag]
bs <- ([HandleTag] -> [HandleTag])
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [HandleTag]
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [HandleTag]
forall a b.
(a -> b)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([HandleTag] -> [HandleTag] -> [HandleTag]
forall a. [a] -> [a] -> [a]
++[HandleTag
bAdvice]) (RWST
   (Maybe GroupIndex)
   [Either GroupIndex GroupInfo]
   ([OP] -> [OP], GroupIndex)
   Identity
   [HandleTag]
 -> RWST
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Identity
      [HandleTag])
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [HandleTag]
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [HandleTag]
forall a b. (a -> b) -> a -> b
$ GroupIndex
-> PM HandleTag
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [HandleTag]
forall (m :: * -> *) a. Applicative m => GroupIndex -> m a -> m [a]
replicateM (GroupIndex -> GroupIndex
forall a. Enum a => a -> a
pred (GroupIndex -> GroupIndex) -> GroupIndex -> GroupIndex
forall a b. (a -> b) -> a -> b
$ [Pattern] -> GroupIndex
forall a. [a] -> GroupIndex
forall (t :: * -> *) a. Foldable t => t a -> GroupIndex
length [Pattern]
branches) PM HandleTag
newUniq -- 2 <= length ps
           -- create all the child branches in left-to-right order after the "bs"
           [Q]
qs <- [(Pattern, HandleTag)]
-> ((Pattern, HandleTag)
    -> RWS
         (Maybe GroupIndex)
         [Either GroupIndex GroupInfo]
         ([OP] -> [OP], GroupIndex)
         Q)
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     [Q]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Pattern] -> [HandleTag] -> [(Pattern, HandleTag)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pattern]
branches [HandleTag]
bs) (\(Pattern
branch,HandleTag
bTag) ->  (Pattern -> HHQ
go Pattern
branch HandleTag
aAdvice HandleTag
bTag))
           let wqs :: [Wanted]
wqs = (Q -> Wanted) -> [Q] -> [Wanted]
forall a b. (a -> b) -> [a] -> [b]
map Q -> Wanted
wants [Q]
qs
               wanted :: Wanted
wanted = if (Wanted -> Bool) -> [Wanted] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Wanted
WantsBothWanted -> Wanted -> Bool
forall a. Eq a => a -> a -> Bool
==) [Wanted]
wqs then Wanted
WantsBoth
                          else case ((Wanted -> Bool) -> [Wanted] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Wanted
WantsQNFAWanted -> Wanted -> Bool
forall a. Eq a => a -> a -> Bool
==) [Wanted]
wqs,(Wanted -> Bool) -> [Wanted] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Wanted
WantsQTWanted -> Wanted -> Bool
forall a. Eq a => a -> a -> Bool
==) [Wanted]
wqs) of
                                 (Bool
True,Bool
True) -> Wanted
WantsBoth
                                 (Bool
True,Bool
False) -> Wanted
WantsQNFA
                                 (Bool
False,Bool
True) -> Wanted
WantsQT
                                 (Bool
False,Bool
False) -> Wanted
WantsEither
               nullView :: NullView
nullView = NullView -> NullView
cleanNullView (NullView -> NullView) -> ([Q] -> NullView) -> [Q] -> NullView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleTag -> HandleTag -> NullView -> NullView
tagWrapNullView HandleTag
a HandleTag
b (NullView -> NullView) -> ([Q] -> NullView) -> [Q] -> NullView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q -> NullView) -> [Q] -> NullView
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Q -> NullView
nullQ ([Q] -> NullView) -> [Q] -> NullView
forall a b. (a -> b) -> a -> b
$ [Q]
qs
               -- The nullView computed above takes the nullQ of the branches and combines them.  This
               -- assumes that the pre/post tags of the children are also part of the nullQ values.  So
               -- for consistency, POr must then add its own pre/post tags to its nullQ value.  Note that
               -- concatMap sets the left-to-right preference when choosing the null views.
           let ans :: Q
ans = Q { nullQ :: NullView
nullQ = NullView
nullView
                       , takes :: (GroupIndex, Maybe GroupIndex)
takes = [(GroupIndex, Maybe GroupIndex)] -> (GroupIndex, Maybe GroupIndex)
orTakes ([(GroupIndex, Maybe GroupIndex)]
 -> (GroupIndex, Maybe GroupIndex))
-> ([Q] -> [(GroupIndex, Maybe GroupIndex)])
-> [Q]
-> (GroupIndex, Maybe GroupIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q -> (GroupIndex, Maybe GroupIndex))
-> [Q] -> [(GroupIndex, Maybe GroupIndex)]
forall a b. (a -> b) -> [a] -> [b]
map Q -> (GroupIndex, Maybe GroupIndex)
takes ([Q] -> (GroupIndex, Maybe GroupIndex))
-> [Q] -> (GroupIndex, Maybe GroupIndex)
forall a b. (a -> b) -> a -> b
$ [Q]
qs
                       , preReset :: [GroupIndex]
preReset = [], postSet :: [GroupIndex]
postSet = []
                       , preTag :: Maybe GroupIndex
preTag = HandleTag -> Maybe GroupIndex
apply HandleTag
a, postTag :: Maybe GroupIndex
postTag = HandleTag -> Maybe GroupIndex
apply HandleTag
b
                       , tagged :: Bool
tagged = Bool
needTags
                       , childGroups :: Bool
childGroups = (Q -> Bool) -> [Q] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Q -> Bool
childGroups [Q]
qs
                       , wants :: Wanted
wants = Wanted
wanted
                       , unQ :: P
unQ = [Q] -> P
Or [Q]
qs }
           Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Q
ans
         PConcat [] -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
nil -- fatal to pass [] to combineConcat
         PConcat [Pattern]
ps -> [Pattern] -> HHQ
combineConcat [Pattern]
ps HandleTag
m1 HandleTag
m2
         PStar Bool
mayFirstBeNull Pattern
p -> mdo
           let accepts :: Bool
accepts    = Q -> Bool
canAccept Q
q
               -- if needsOrbit is False then there is no need to disambiguate captures on each orbit
               -- Both checks are useful because (varies q) of True does not imply (childGroups q) of True when under PNonCapture
               needsOrbit :: Bool
needsOrbit = Q -> Bool
varies Q
q Bool -> Bool -> Bool
&& Q -> Bool
childGroups Q
q
               -- if needsOrbit then must check start/stop before the Orbit tag
               -- if accepts then must check start/stop of whole pattern
               needsTags :: Bool
needsTags  = Bool
needsOrbit Bool -> Bool -> Bool
|| Bool
accepts       -- important that needsOrbit implies needsTags
           HandleTag
a <- if HandleTag -> Bool
noTag HandleTag
m1 Bool -> Bool -> Bool
&& Bool
needsTags then String -> PM HandleTag
uniq String
"PStar start" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m1
           HandleTag
b <- if HandleTag -> Bool
noTag HandleTag
m2 Bool -> Bool -> Bool
&& Bool
needsTags then String -> PM HandleTag
uniq String
"PStar stop" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m2
           Maybe GroupIndex
mOrbit <- if Bool
needsOrbit then PM (Maybe GroupIndex)
makeOrbit else Maybe GroupIndex -> PM (Maybe GroupIndex)
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GroupIndex
forall a. Maybe a
Nothing -- any Orbit tag is created after the pre and post tags
--           test1 <- if tagged q then uniq "not-TEST1" Minimize else return NoTag
-- XXX XXX 1.1.5 testing second NoTag replaced with (toAdvice b)
           (Q
q,[GroupIndex]
resetOrbitTags) <- RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
-> PM (Q, [GroupIndex])
forall a. PM a -> PM (a, [GroupIndex])
withOrbit (Pattern -> HHQ
go Pattern
p HandleTag
NoTag (HandleTag -> HandleTag
toAdvice HandleTag
b)) -- all contained orbit tags get listened to (not including this one).
           let nullView :: NullView
nullView | Bool
mayFirstBeNull = NullView -> NullView
cleanNullView (NullView -> NullView) -> NullView -> NullView
forall a b. (a -> b) -> a -> b
$ NullView
childViews NullView -> NullView -> NullView
forall a. [a] -> [a] -> [a]
++ NullView
skipView
                        | Bool
otherwise = NullView
skipView
                 where childViews :: NullView
childViews = HandleTag -> HandleTag -> NullView -> NullView
tagWrapNullView HandleTag
a HandleTag
b (NullView -> NullView)
-> (NullView -> NullView) -> NullView -> NullView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GroupIndex -> [GroupIndex] -> NullView -> NullView
orbitWrapNullView Maybe GroupIndex
mOrbit [GroupIndex]
resetOrbitTags (NullView -> NullView) -> NullView -> NullView
forall a b. (a -> b) -> a -> b
$ Q -> NullView
nullQ Q
q
                       skipView :: NullView
skipView = HandleTag -> HandleTag -> NullView
makeEmptyNullView HandleTag
a HandleTag
b
           Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q
 -> RWS
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Q)
-> Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a b. (a -> b) -> a -> b
$ Q { nullQ :: NullView
nullQ = NullView
nullView
                      , takes :: (GroupIndex, Maybe GroupIndex)
takes = (GroupIndex
0,if Bool
accepts then Maybe GroupIndex
forall a. Maybe a
Nothing else (GroupIndex -> Maybe GroupIndex
forall a. a -> Maybe a
Just GroupIndex
0))
                      , preReset :: [GroupIndex]
preReset = [], postSet :: [GroupIndex]
postSet = []
                      , preTag :: Maybe GroupIndex
preTag = HandleTag -> Maybe GroupIndex
apply HandleTag
a, postTag :: Maybe GroupIndex
postTag = HandleTag -> Maybe GroupIndex
apply HandleTag
b
                      , tagged :: Bool
tagged = Bool
needsTags
                      , childGroups :: Bool
childGroups = Q -> Bool
childGroups Q
q
                      , wants :: Wanted
wants = Wanted
WantsQT
                      , unQ :: P
unQ =Star { getOrbit :: Maybe GroupIndex
getOrbit = Maybe GroupIndex
mOrbit
                                  , resetOrbits :: [GroupIndex]
resetOrbits = [GroupIndex]
resetOrbitTags
                                  , firstNull :: Bool
firstNull = Bool
mayFirstBeNull
                                  , unStar :: Q
unStar = Q
q } }
         PCarat DoPa
dopa -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_BOL,DoPa
dopa)
         PDollar DoPa
dopa -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_EOL,DoPa
dopa)
         PChar {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one
         PDot {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one
         PAny {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one
         PAnyNot {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one
         -- CompOption's newSyntax enables these escaped anchors
         PEscape DoPa
dopa Char
'`'  | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_BOB,DoPa
dopa)
         PEscape DoPa
dopa Char
'\'' | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_EOB,DoPa
dopa)
         PEscape DoPa
dopa Char
'<'  | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_BOW,DoPa
dopa)
         PEscape DoPa
dopa Char
'>'  | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_EOW,DoPa
dopa)
         PEscape DoPa
dopa Char
'b'  | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_EdgeWord,DoPa
dopa)
         PEscape DoPa
dopa Char
'B'  | Bool
xtra -> TestInfo
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall {m :: * -> *}. Monad m => TestInfo -> m Q
test (WhichTest
Test_NotEdgeWord,DoPa
dopa)
         -- otherwise escape codes are just the escaped character
         PEscape {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
one

         -- A PGroup node in the Pattern tree does not become a node
         -- in the Q/P tree. A PGroup can share and pass along a
         -- preTag (with Advice) with other branches, but will pass
         -- down an Apply postTag.
         --
         -- If the parent index is Nothing then this is part of a
         -- non-capturing subtree and ignored.  This is a lazy and
         -- efficient alternative to rebuilding the tree with PGroup
         -- Nothing replacing PGroup (Just _).
         --
         -- Guarded by the getParentIndex /= Nothing check is the
         -- withParent command.
         --
         PGroup Maybe GroupIndex
Nothing Pattern
p -> Pattern -> HHQ
go Pattern
p HandleTag
m1 HandleTag
m2
         PGroup (Just GroupIndex
this) Pattern
p -> do
           Maybe GroupIndex
mParent <- PM (Maybe GroupIndex)
getParentIndex
           case Maybe GroupIndex
mParent of
             Maybe GroupIndex
Nothing -> Pattern -> HHQ
go Pattern
p HandleTag
m1 HandleTag
m2 -- just like PGroup Nothing p
             Just GroupIndex
parent -> do
               -- 'a' may be Advice or Apply from parent or Apply created here
               HandleTag
a <- if HandleTag -> Bool
noTag HandleTag
m1 then String -> PM HandleTag
uniq String
"PGroup start" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m1
               HandleTag
b <- if HandleTag -> Bool
noTag HandleTag
m2 then String -> PM HandleTag
uniq String
"PGroup stop" else HandleTag -> PM HandleTag
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return HandleTag
m2
               GroupIndex
flag <- String
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     GroupIndex
ignore String
"PGroup ignore"
{-
               -- 'b' may be Apply from parent or Apply created here
               b <- if isNothing (apply m2) then uniq "PGroup" else return m2
-}
               (Q
q,[GroupIndex]
resetGroupTags) <- GroupIndex
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
-> PM (Q, [GroupIndex])
forall a. GroupIndex -> PM a -> PM (a, [GroupIndex])
withParent GroupIndex
this (Pattern -> HHQ
go Pattern
p HandleTag
a HandleTag
b)  -- all immediate child groups stop tags get listened to.
               -- 2009: makeGroup performs a tell, why after withParent? I am no longer sure.
               GroupInfo
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     ()
makeGroup (GroupIndex
-> GroupIndex
-> GroupIndex
-> GroupIndex
-> GroupIndex
-> GroupInfo
GroupInfo GroupIndex
this GroupIndex
parent (HandleTag -> GroupIndex
fromHandleTag HandleTag
a) (HandleTag -> GroupIndex
fromHandleTag HandleTag
b) GroupIndex
flag)
               Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a.
a
-> RWST
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Identity
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q
 -> RWS
      (Maybe GroupIndex)
      [Either GroupIndex GroupInfo]
      ([OP] -> [OP], GroupIndex)
      Q)
-> Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a b. (a -> b) -> a -> b
$ Q
q { nullQ = addGroupResetsToNullView resetGroupTags flag (nullQ q)
                          , tagged = True
                          , childGroups = True
                          , preReset = resetGroupTags `mappend` (preReset q)
                          , postSet = (postSet q) `mappend` [flag]
                          }

         -- A PNonCapture node in the Pattern tree does not become a
         -- node in the Q/P tree.  It sets the parent to Nothing while
         -- processing the sub-tree.
         PNonCapture Pattern
p -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
-> RWS
     (Maybe GroupIndex)
     [Either GroupIndex GroupInfo]
     ([OP] -> [OP], GroupIndex)
     Q
forall a. PM a -> PM a
nonCapture (Pattern -> HHQ
go Pattern
p HandleTag
m1 HandleTag
m2)

         -- these are here for completeness of the case branches, currently starTrans replaces them all
         PPlus {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
forall {a}. a
die
         PQuest {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
forall {a}. a
die
         PBound {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
forall {a}. a
die
         -- PNonEmpty is deprecated, and not produced in Pattern by starTrans anymore
         PNonEmpty {} -> RWS
  (Maybe GroupIndex)
  [Either GroupIndex GroupInfo]
  ([OP] -> [OP], GroupIndex)
  Q
forall {a}. a
die

{-
Similar to change in WinTags for QT/QNFA:
Change the NullView to use a tasktags instead of wintags since they are all PreUpdate

         -- PNonEmpty means the child pattern p can be skipped by
         -- bypassing the pattern.  This is only used in the case p
         -- can accept 0 and can accept more than zero characters
         -- (thus the assertions, enforced by CorePattern.starTrans).
         -- The important thing about this case is intercept the
         -- "accept 0" possibility and replace with "skip".
         PNonEmpty p -> mdo
           let needsTags = canAccept q
           a <- if noTag m1 && needsTags then uniq Minimize else return m1
           b <- if noTag m2 && needsTags then uniq Maximize else return m2
           q <- go p (toAdvice a) (toAdvice b)
           when (not needsTags) (err $ "PNonEmpty could not accept characters: "++show (p,pOrig))
           when (mustAccept q) (err $ "patternToQ : PNonEmpty provided with a *mustAccept* pattern: "++show (p,pOrig))
           return $ Q { nullQ = emptyNull (preTags (apply a) (apply b)) -- The meaning of NonEmpty
                      , takes = (0,snd (takes q))                       -- like Or, drop lower bound to 0
                      , preReset = []
                      , preTag = apply a, postTag = apply b             -- own the closing tag so it will not end a PGroup
                      , tagged = needsTags
                      , childGroups = childGroups q
                      , wants = wants q  -- the test case is "x" =~ "(.|$){1,3}"
                      , unQ = NonEmpty q }

-}
{-
emptyNull :: TagList -> NullView
emptyNull tags = (mempty, tags) : []

testNull :: TestInfo -> TagList -> NullView
testNull (w,d) tags = (SetTestInfo (Map.singleton w (Set.singleton d)), tags) : []

-- Prepend tags to nullView
addTagsToNullView :: TagList -> NullView -> NullView
addTagsToNullView [] oldNV = oldNV
addTagsToNullView tags oldNV= do
  (oldTest,oldTags) <- oldNV
  return (oldTest,tags `mappend` oldTags)

-}


-- xxx todo
--
-- see of PNonEmpty -> NonEmpty -> TNFA is really smarter than POr about tags