-- | 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 {- all -}
import Data.Array.IArray(Array,(!),accumArray,listArray)
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
showList :: [P] -> ShowS
$cshowList :: [P] -> ShowS
show :: P -> String
$cshow :: P -> String
showsPrec :: GroupIndex -> P -> ShowS
$cshowsPrec :: GroupIndex -> P -> ShowS
Show,P -> P -> Bool
(P -> P -> Bool) -> (P -> P -> Bool) -> Eq P
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: P -> P -> Bool
$c/= :: P -> P -> Bool
== :: P -> P -> Bool
$c== :: 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
/= :: Q -> Q -> Bool
$c/= :: Q -> Q -> Bool
== :: Q -> Q -> Bool
$c== :: 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
/= :: SetTestInfo -> SetTestInfo -> Bool
$c/= :: SetTestInfo -> SetTestInfo -> Bool
== :: SetTestInfo -> SetTestInfo -> Bool
$c== :: 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
showList :: [HandleTag] -> ShowS
$cshowList :: [HandleTag] -> ShowS
show :: HandleTag -> String
$cshow :: HandleTag -> String
showsPrec :: GroupIndex -> HandleTag -> ShowS
$cshowsPrec :: GroupIndex -> 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
/= :: Wanted -> Wanted -> Bool
$c/= :: Wanted -> Wanted -> Bool
== :: Wanted -> Wanted -> Bool
$c== :: 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
showList :: [Wanted] -> ShowS
$cshowList :: [Wanted] -> ShowS
show :: Wanted -> String
$cshow :: Wanted -> String
showsPrec :: GroupIndex -> Wanted -> ShowS
$cshowsPrec :: GroupIndex -> 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 (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 (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 (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 (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 (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 (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 (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [GroupIndex]
xs, (Maybe GroupIndex -> Maybe GroupIndex -> Maybe GroupIndex)
-> [Maybe GroupIndex] -> Maybe GroupIndex
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 boundaary / 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

fromRight :: [Either Tag GroupInfo] -> [GroupInfo]
fromRight :: [Either GroupIndex GroupInfo] -> [GroupInfo]
fromRight [] = []
fromRight ((Right GroupInfo
x):[Either GroupIndex GroupInfo]
xs) = GroupInfo
xGroupInfo -> [GroupInfo] -> [GroupInfo]
forall a. a -> [a] -> [a]
:[Either GroupIndex GroupInfo] -> [GroupInfo]
fromRight [Either GroupIndex GroupInfo]
xs
fromRight ((Left GroupIndex
_):[Either GroupIndex GroupInfo]
xs) = [Either GroupIndex GroupInfo] -> [GroupInfo]
fromRight [Either GroupIndex GroupInfo]
xs

partitionEither :: [Either Tag GroupInfo] -> ([Tag],[GroupInfo])
partitionEither :: [Either GroupIndex GroupInfo] -> ([GroupIndex], [GroupInfo])
partitionEither = ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupInfo])
-> [Either GroupIndex GroupInfo]
-> ([GroupIndex], [GroupInfo])
helper [GroupIndex] -> [GroupIndex]
forall a. a -> a
id [GroupInfo] -> [GroupInfo]
forall a. a -> a
id where
  helper :: ([Tag]->[Tag]) -> ([GroupInfo]->[GroupInfo]) -> [Either Tag GroupInfo] -> ([Tag],[GroupInfo])
  helper :: ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupInfo])
-> [Either GroupIndex GroupInfo]
-> ([GroupIndex], [GroupInfo])
helper [GroupIndex] -> [GroupIndex]
ls [GroupInfo] -> [GroupInfo]
rs [] = ([GroupIndex] -> [GroupIndex]
ls [],[GroupInfo] -> [GroupInfo]
rs [])
  helper [GroupIndex] -> [GroupIndex]
ls [GroupInfo] -> [GroupInfo]
rs ((Right GroupInfo
x):[Either GroupIndex GroupInfo]
xs) = ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupInfo])
-> [Either GroupIndex GroupInfo]
-> ([GroupIndex], [GroupInfo])
helper  [GroupIndex] -> [GroupIndex]
ls      ([GroupInfo] -> [GroupInfo]
rs([GroupInfo] -> [GroupInfo])
-> ([GroupInfo] -> [GroupInfo]) -> [GroupInfo] -> [GroupInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GroupInfo
xGroupInfo -> [GroupInfo] -> [GroupInfo]
forall a. a -> [a] -> [a]
:)) [Either GroupIndex GroupInfo]
xs
  helper [GroupIndex] -> [GroupIndex]
ls [GroupInfo] -> [GroupInfo]
rs ((Left  GroupIndex
x):[Either GroupIndex GroupInfo]
xs) = ([GroupIndex] -> [GroupIndex])
-> ([GroupInfo] -> [GroupInfo])
-> [Either GroupIndex GroupInfo]
-> ([GroupIndex], [GroupInfo])
helper ([GroupIndex] -> [GroupIndex]
ls([GroupIndex] -> [GroupIndex])
-> ([GroupIndex] -> [GroupIndex]) -> [GroupIndex] -> [GroupIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GroupIndex
xGroupIndex -> [GroupIndex] -> [GroupIndex]
forall a. a -> [a] -> [a]
:)) [GroupInfo] -> [GroupInfo]
rs       [Either GroupIndex GroupInfo]
xs

-- 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]
fromRight [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 (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 (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 (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]
childStars
    where childStars :: [Either GroupIndex GroupInfo] -> [GroupIndex]
childStars [Either GroupIndex GroupInfo]
x = let ([GroupIndex]
ts,[GroupInfo]
_) = [Either GroupIndex GroupInfo] -> ([GroupIndex], [GroupInfo])
partitionEither [Either GroupIndex GroupInfo]
x in [GroupIndex]
ts

  {-# 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 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 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]
childGroupInfo
    where childGroupInfo :: [Either GroupIndex GroupInfo] -> [GroupIndex]
childGroupInfo [Either GroupIndex GroupInfo]
x =
            let ([GroupIndex]
_,[GroupInfo]
gs) = [Either GroupIndex GroupInfo] -> ([GroupIndex], [GroupInfo])
partitionEither [Either GroupIndex 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 addded 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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (HandleTag -> HandleTag
toAdvice HandleTag
a)
                     (Bool
_,Bool
_,Bool
False,Bool
False) -> HandleTag -> PM HandleTag
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 (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 (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 (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 (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 (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 (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 (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 (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"
           -- optimiztion: 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 (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 (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 (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 (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 (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 (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 (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 rebuidling 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 (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 (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 (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 :: NullView
nullQ = [GroupIndex] -> GroupIndex -> NullView -> NullView
addGroupResetsToNullView [GroupIndex]
resetGroupTags GroupIndex
flag (Q -> NullView
nullQ Q
q)
                          , tagged :: Bool
tagged = Bool
True
                          , childGroups :: Bool
childGroups = Bool
True
                          , preReset :: [GroupIndex]
preReset = [GroupIndex]
resetGroupTags [GroupIndex] -> [GroupIndex] -> [GroupIndex]
forall a. Monoid a => a -> a -> a
`mappend` (Q -> [GroupIndex]
preReset Q
q)
                          , postSet :: [GroupIndex]
postSet = (Q -> [GroupIndex]
postSet Q
q) [GroupIndex] -> [GroupIndex] -> [GroupIndex]
forall a. Monoid a => a -> a -> a
`mappend` [GroupIndex
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, enforcted 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