module Text.Regex.TDFA.TNFA
( patternToNFA
, QNFA(..), QT(..), QTrans, TagUpdate(..)
) where
import Control.Monad(when)
import Control.Monad.State(State,runState,execState,get,put,modify)
import Data.Array.IArray(Array,array)
import Data.Char(toLower,toUpper,isAlpha,ord)
import Data.List(foldl')
import Data.IntMap (IntMap)
import qualified Data.IntMap as IMap(toAscList,null,unionWith,singleton,fromList,fromDistinctAscList)
import Data.IntMap.CharMap2(CharMap(..))
import qualified Data.IntMap.CharMap2 as Map(null,singleton,map)
import qualified Data.IntMap.EnumMap2 as EMap(null,keysSet,assocs)
import Data.IntSet.EnumSet2(EnumSet)
import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,insert)
import Data.Maybe(catMaybes,isNothing)
import Data.Monoid as Mon(Monoid(..))
import qualified Data.Set as S (insert, toAscList)
import Text.Regex.TDFA.Common(QT(..),QNFA(..),QTrans,TagTask(..),TagUpdate(..),DoPa(..)
,CompOption(..)
,Tag,TagTasks,TagList,Index,WinTags,GroupIndex,GroupInfo(..)
,common_error,noWin,snd3,mapSnd)
import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView
,SetTestInfo(..),Wanted(..),TestInfo
,mustAccept,cannotAccept,patternToQ)
import Text.Regex.TDFA.Pattern (Pattern(..), decodePatternSet)
ecart :: String -> a -> a
ecart :: forall a. [Char] -> a -> a
ecart [Char]
_ = a -> a
forall a. a -> a
id
err :: String -> a
err :: forall a. [Char] -> a
err [Char]
t = [Char] -> [Char] -> a
forall a. [Char] -> [Char] -> a
common_error [Char]
"Text.Regex.TDFA.TNFA" [Char]
t
debug :: (Show a) => a -> s -> s
debug :: forall a s. Show a => a -> s -> s
debug a
_ s
s = s
s
qtwin,qtlose :: QT
qtwin :: QT
qtwin = Simple {qt_win :: WinTags
qt_win=[(Key
1,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)],qt_trans :: CharMap QTrans
qt_trans=CharMap QTrans
forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=QTrans
forall a. Monoid a => a
mempty}
qtlose :: QT
qtlose = Simple {qt_win :: WinTags
qt_win=WinTags
forall a. Monoid a => a
mempty,qt_trans :: CharMap QTrans
qt_trans=CharMap QTrans
forall a. Monoid a => a
mempty,qt_other :: QTrans
qt_other=QTrans
forall a. Monoid a => a
mempty}
patternToNFA :: CompOption
-> (Pattern,(GroupIndex, DoPa))
-> ((Index,Array Index QNFA)
,Array Tag OP
,Array GroupIndex [GroupInfo])
patternToNFA :: CompOption
-> (Pattern, (Key, DoPa))
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
patternToNFA CompOption
compOpt (Pattern, (Key, DoPa))
pattern =
let (Q
q,Array Key OP
tags,Array Key [GroupInfo]
groups) = CompOption
-> (Pattern, (Key, DoPa))
-> (Q, Array Key OP, Array Key [GroupInfo])
patternToQ CompOption
compOpt (Pattern, (Key, DoPa))
pattern
msg :: [Char]
msg = [[Char]] -> [Char]
unlines [ Q -> [Char]
forall a. Show a => a -> [Char]
show Q
q ]
in [Char]
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
-> ((Key, Array Key QNFA), Array Key OP, Array Key [GroupInfo])
forall a s. Show a => a -> s -> s
debug [Char]
msg (CompOption -> Q -> (Key, Array Key QNFA)
qToNFA CompOption
compOpt Q
q,Array Key OP
tags,Array Key [GroupInfo]
groups)
nullable :: Q -> Bool
nullable :: Q -> Bool
nullable = Bool -> Bool
not (Bool -> Bool) -> (Q -> Bool) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(SetTestInfo, WinTags)] -> Bool)
-> (Q -> [(SetTestInfo, WinTags)]) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(SetTestInfo, WinTags)]
nullQ
notNullable :: Q -> Bool
notNullable :: Q -> Bool
notNullable = [(SetTestInfo, WinTags)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(SetTestInfo, WinTags)] -> Bool)
-> (Q -> [(SetTestInfo, WinTags)]) -> Q -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(SetTestInfo, WinTags)]
nullQ
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty :: Q -> Maybe WinTags
maybeOnlyEmpty (Q {nullQ :: Q -> [(SetTestInfo, WinTags)]
nullQ = ((SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags):[(SetTestInfo, WinTags)]
_)}) = if EnumMap WhichTest (EnumSet DoPa) -> Bool
forall key a. Enum key => EnumMap key a -> Bool
EMap.null EnumMap WhichTest (EnumSet DoPa)
sti then WinTags -> Maybe WinTags
forall a. a -> Maybe a
Just WinTags
tags else Maybe WinTags
forall a. Maybe a
Nothing
maybeOnlyEmpty Q
_ = Maybe WinTags
forall a. Maybe a
Nothing
usesQNFA :: Q -> Bool
usesQNFA :: Q -> Bool
usesQNFA (Q {wants :: Q -> Wanted
wants=Wanted
WantsBoth}) = Bool
True
usesQNFA (Q {wants :: Q -> Wanted
wants=Wanted
WantsQNFA}) = Bool
True
usesQNFA Q
_ = Bool
False
mkQNFA :: Index -> QT -> QNFA
mkQNFA :: Key -> QT -> QNFA
mkQNFA Key
i QT
qt = [Char] -> QNFA -> QNFA
forall a s. Show a => a -> s -> s
debug ([Char]
"\n>QNFA id="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Key -> [Char]
forall a. Show a => a -> [Char]
show Key
i) (QNFA -> QNFA) -> QNFA -> QNFA
forall a b. (a -> b) -> a -> b
$
Key -> QT -> QNFA
QNFA Key
i ([Char] -> QT -> QT
forall a s. Show a => a -> s -> s
debug ([Char]
"\ngetting QT for "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Key -> [Char]
forall a. Show a => a -> [Char]
show Key
i) QT
qt)
mkTesting :: QT -> QT
mkTesting :: QT -> QT
mkTesting t :: QT
t@(Testing {qt_a :: QT -> QT
qt_a=QT
a,qt_b :: QT -> QT
qt_b=QT
b}) = if QT
aQT -> QT -> Bool
forall a. Eq a => a -> a -> Bool
==QT
b then QT
a else QT
t
mkTesting QT
t = QT
t
nullQT :: QT -> Bool
nullQT :: QT -> Bool
nullQT (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) = WinTags -> Bool
noWin WinTags
w Bool -> Bool -> Bool
&& CharMap QTrans -> Bool
forall a. CharMap a -> Bool
Map.null CharMap QTrans
t Bool -> Bool -> Bool
&& QTrans -> Bool
forall a. IntMap a -> Bool
IMap.null QTrans
o
nullQT QT
_ = Bool
False
listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
qt EnumSet WhichTest
s = State (EnumSet WhichTest) ()
-> EnumSet WhichTest -> EnumSet WhichTest
forall s a. State s a -> s -> s
execState (QT -> State (EnumSet WhichTest) ()
forall {m :: * -> *}.
MonadState (EnumSet WhichTest) m =>
QT -> m ()
helper QT
qt) EnumSet WhichTest
s
where helper :: QT -> m ()
helper (Simple {}) = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
helper (Testing {qt_test :: QT -> WhichTest
qt_test = WhichTest
wt, qt_a :: QT -> QT
qt_a = QT
a, qt_b :: QT -> QT
qt_b = QT
b}) = do
(EnumSet WhichTest -> EnumSet WhichTest) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (WhichTest -> EnumSet WhichTest -> EnumSet WhichTest
forall e. Enum e => e -> EnumSet e -> EnumSet e
Set.insert WhichTest
wt)
QT -> m ()
helper QT
a
QT -> m ()
helper QT
b
applyNullViews :: NullView -> QT -> QT
applyNullViews :: [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews [] QT
win = QT
win
applyNullViews [(SetTestInfo, WinTags)]
nvs QT
win = (QT -> (SetTestInfo, WinTags) -> QT)
-> QT -> [(SetTestInfo, WinTags)] -> QT
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
qtlose ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)])
-> [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
cleanNullView [(SetTestInfo, WinTags)]
nvs) where
preferNullViews :: NullView -> QT -> QT
preferNullViews :: [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews [] QT
win = QT
win
preferNullViews [(SetTestInfo, WinTags)]
nvs QT
win = (QT -> (SetTestInfo, WinTags) -> QT)
-> QT -> [(SetTestInfo, WinTags)] -> QT
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win) QT
win ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a. [a] -> [a]
reverse ([(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)])
-> [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> [(SetTestInfo, WinTags)]
cleanNullView [(SetTestInfo, WinTags)]
nvs) where
dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT
dominate :: QT -> QT -> (SetTestInfo, WinTags) -> QT
dominate QT
win QT
lose x :: (SetTestInfo, WinTags)
x@(SetTestInfo EnumMap WhichTest (EnumSet DoPa)
sti,WinTags
tags) = [Char] -> QT -> QT
forall a s. Show a => a -> s -> s
debug ([Char]
"dominate "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(SetTestInfo, WinTags) -> [Char]
forall a. Show a => a -> [Char]
show (SetTestInfo, WinTags)
x) (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
let
win' :: QT
win' = WinTags -> QT -> QT
prependTags' WinTags
tags QT
win
winTests :: EnumSet WhichTest
winTests = QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
win (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
forall a. Monoid a => a
mempty
allTests :: EnumSet WhichTest
allTests = (QT -> EnumSet WhichTest -> EnumSet WhichTest
listTestInfo QT
lose (EnumSet WhichTest -> EnumSet WhichTest)
-> EnumSet WhichTest -> EnumSet WhichTest
forall a b. (a -> b) -> a -> b
$ EnumSet WhichTest
winTests) EnumSet WhichTest -> EnumSet WhichTest -> EnumSet WhichTest
forall a. Monoid a => a -> a -> a
`mappend` (EnumMap WhichTest (EnumSet DoPa) -> EnumSet WhichTest
forall key a. Enum key => EnumMap key a -> EnumSet key
EMap.keysSet EnumMap WhichTest (EnumSet DoPa)
sti)
useTest :: [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
_ [] QT
w QT
_ = QT
w
useTest (WhichTest
aTest:[WhichTest]
tests) allD :: [(WhichTest, EnumSet DoPa)]
allD@((WhichTest
dTest,EnumSet DoPa
dopas):[(WhichTest, EnumSet DoPa)]
ds) QT
w QT
l =
let (QT
wA,QT
wB,EnumSet DoPa
wD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
w
(QT
lA,QT
lB,EnumSet DoPa
lD) = QT -> (QT, QT, EnumSet DoPa)
branches QT
l
branches :: QT -> (QT, QT, EnumSet DoPa)
branches qt :: QT
qt@(Testing {}) | WhichTest
aTestWhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
==QT -> WhichTest
qt_test QT
qt = (QT -> QT
qt_a QT
qt,QT -> QT
qt_b QT
qt,QT -> EnumSet DoPa
qt_dopas QT
qt)
branches QT
qt = (QT
qt,QT
qt,EnumSet DoPa
forall a. Monoid a => a
mempty)
in if WhichTest
aTest WhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
== WhichTest
dTest
then Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
,qt_dopas :: EnumSet DoPa
qt_dopas = (EnumSet DoPa
dopas EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
wD) EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
ds QT
wA QT
lA
,qt_b :: QT
qt_b = QT
lB}
else Testing {qt_test :: WhichTest
qt_test = WhichTest
aTest
,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa
wD EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
lD
,qt_a :: QT
qt_a = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wA QT
lA
,qt_b :: QT
qt_b = [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest [WhichTest]
tests [(WhichTest, EnumSet DoPa)]
allD QT
wB QT
lB}
useTest [] [(WhichTest, EnumSet DoPa)]
_ QT
_ QT
_ = [Char] -> QT
forall a. [Char] -> a
err [Char]
"This case in dominate.useText cannot happen: second argument would have to have been null and that is checked before this case"
in [WhichTest] -> [(WhichTest, EnumSet DoPa)] -> QT -> QT -> QT
useTest (EnumSet WhichTest -> [WhichTest]
forall e. Enum e => EnumSet e -> [e]
Set.toList EnumSet WhichTest
allTests) (EnumMap WhichTest (EnumSet DoPa) -> [(WhichTest, EnumSet DoPa)]
forall key a. Enum key => EnumMap key a -> [(key, a)]
EMap.assocs EnumMap WhichTest (EnumSet DoPa)
sti) QT
win' QT
lose
applyTest :: TestInfo -> QT -> QT
applyTest :: TestInfo -> QT -> QT
applyTest (WhichTest
wt,DoPa
dopa) QT
qt | QT -> Bool
nullQT QT
qt = QT
qt
| Bool
otherwise = QT -> QT
applyTest' QT
qt where
applyTest' :: QT -> QT
applyTest' :: QT -> QT
applyTest' q :: QT
q@(Simple {}) =
QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$ Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
,qt_dopas :: EnumSet DoPa
qt_dopas = DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e
Set.singleton DoPa
dopa
,qt_a :: QT
qt_a = QT
q
,qt_b :: QT
qt_b = QT
qtlose}
applyTest' q :: QT
q@(Testing {qt_test :: QT -> WhichTest
qt_test=WhichTest
wt'}) =
case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt WhichTest
wt' of
Ordering
LT -> Testing {qt_test :: WhichTest
qt_test = WhichTest
wt
,qt_dopas :: EnumSet DoPa
qt_dopas = DoPa -> EnumSet DoPa
forall e. Enum e => e -> EnumSet e
Set.singleton DoPa
dopa
,qt_a :: QT
qt_a = QT
q
,qt_b :: QT
qt_b = QT
qtlose}
Ordering
EQ -> QT
q {qt_dopas = Set.insert dopa (qt_dopas q)
,qt_b = qtlose}
Ordering
GT -> QT
q {qt_a = applyTest' (qt_a q)
,qt_b = applyTest' (qt_b q)}
mergeQT_2nd,mergeAltQT,mergeQT :: QT -> QT -> QT
mergeQT_2nd :: QT -> QT -> QT
mergeQT_2nd QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
| Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith (\WinTags
_ WinTags
w2 -> WinTags
w2) QT
q1 QT
q2
mergeAltQT :: QT -> QT -> QT
mergeAltQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
| Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith (\WinTags
w1 WinTags
w2 -> if WinTags -> Bool
noWin WinTags
w1 then WinTags
w2 else WinTags
w1) QT
q1 QT
q2
mergeQT :: QT -> QT -> QT
mergeQT QT
q1 QT
q2 | QT -> Bool
nullQT QT
q1 = QT
q2
| QT -> Bool
nullQT QT
q2 = QT
q1
| Bool
otherwise = (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
mappend QT
q1 QT
q2
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT
mergeQTWith WinTags -> WinTags -> WinTags
mergeWins = QT -> QT -> QT
merge where
merge :: QT -> QT -> QT
merge :: QT -> QT -> QT
merge (Simple WinTags
w1 CharMap QTrans
t1 QTrans
o1) (Simple WinTags
w2 CharMap QTrans
t2 QTrans
o2) =
let w' :: WinTags
w' = WinTags -> WinTags -> WinTags
mergeWins WinTags
w1 WinTags
w2
t' :: CharMap QTrans
t' = CharMap QTrans
-> QTrans -> CharMap QTrans -> QTrans -> CharMap QTrans
fuseQTrans CharMap QTrans
t1 QTrans
o1 CharMap QTrans
t2 QTrans
o2
o' :: QTrans
o' = QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1 QTrans
o2
in WinTags -> CharMap QTrans -> QTrans -> QT
Simple WinTags
w' CharMap QTrans
t' QTrans
o'
merge t1 :: QT
t1@(Testing WhichTest
_ EnumSet DoPa
_ QT
a1 QT
b1) s2 :: QT
s2@(Simple {}) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
QT
t1 {qt_a=(merge a1 s2), qt_b=(merge b1 s2)}
merge s1 :: QT
s1@(Simple {}) t2 :: QT
t2@(Testing WhichTest
_ EnumSet DoPa
_ QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
QT
t2 {qt_a=(merge s1 a2), qt_b=(merge s1 b2)}
merge t1 :: QT
t1@(Testing WhichTest
wt1 EnumSet DoPa
ds1 QT
a1 QT
b1) t2 :: QT
t2@(Testing WhichTest
wt2 EnumSet DoPa
ds2 QT
a2 QT
b2) = QT -> QT
mkTesting (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$
case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt1 WhichTest
wt2 of
Ordering
LT -> QT
t1 {qt_a=(merge a1 t2), qt_b=(merge b1 t2)}
Ordering
EQ -> Testing {qt_test :: WhichTest
qt_test = WhichTest
wt1
,qt_dopas :: EnumSet DoPa
qt_dopas = EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
mappend EnumSet DoPa
ds1 EnumSet DoPa
ds2
,qt_a :: QT
qt_a = QT -> QT -> QT
merge QT
a1 QT
a2
,qt_b :: QT
qt_b = QT -> QT -> QT
merge QT
b1 QT
b2}
Ordering
GT -> QT
t2 {qt_a=(merge t1 a2), qt_b=(merge t1 b2)}
fuseQTrans :: (CharMap QTrans) -> QTrans
-> (CharMap QTrans) -> QTrans
-> CharMap QTrans
fuseQTrans :: CharMap QTrans
-> QTrans -> CharMap QTrans -> QTrans -> CharMap QTrans
fuseQTrans (CharMap IntMap QTrans
t1) QTrans
o1 (CharMap IntMap QTrans
t2) QTrans
o2 = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap ([(Key, QTrans)] -> IntMap QTrans
forall a. [(Key, a)] -> IntMap a
IMap.fromDistinctAscList ([(Key, QTrans)] -> [(Key, QTrans)] -> [(Key, QTrans)]
forall {a}.
Ord a =>
[(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(Key, QTrans)]
l1 [(Key, QTrans)]
l2)) where
l1 :: [(Key, QTrans)]
l1 = IntMap QTrans -> [(Key, QTrans)]
forall a. IntMap a -> [(Key, a)]
IMap.toAscList IntMap QTrans
t1
l2 :: [(Key, QTrans)]
l2 = IntMap QTrans -> [(Key, QTrans)]
forall a. IntMap a -> [(Key, a)]
IMap.toAscList IntMap QTrans
t2
fuse :: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [] [(a, QTrans)]
y = (QTrans -> QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1) [(a, QTrans)]
y
fuse [(a, QTrans)]
x [] = (QTrans -> QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o2) [(a, QTrans)]
x
fuse x :: [(a, QTrans)]
x@((a
xc,QTrans
xa):[(a, QTrans)]
xs) y :: [(a, QTrans)]
y@((a
yc,QTrans
ya):[(a, QTrans)]
ys) =
case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
xc a
yc of
Ordering
LT -> (a
xc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
xa QTrans
o2) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
xs [(a, QTrans)]
y
Ordering
EQ -> (a
xc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
xa QTrans
ya) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
xs [(a, QTrans)]
ys
Ordering
GT -> (a
yc,QTrans -> QTrans -> QTrans
mergeQTrans QTrans
o1 QTrans
ya) (a, QTrans) -> [(a, QTrans)] -> [(a, QTrans)]
forall a. a -> [a] -> [a]
: [(a, QTrans)] -> [(a, QTrans)] -> [(a, QTrans)]
fuse [(a, QTrans)]
x [(a, QTrans)]
ys
mergeQTrans :: QTrans -> QTrans -> QTrans
mergeQTrans :: QTrans -> QTrans -> QTrans
mergeQTrans = ([TagCommand] -> [TagCommand] -> [TagCommand])
-> QTrans -> QTrans -> QTrans
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IMap.unionWith [TagCommand] -> [TagCommand] -> [TagCommand]
forall a. Monoid a => a -> a -> a
mappend
prependPreTag :: Maybe Tag -> QT -> QT
prependPreTag :: Maybe Key -> QT -> QT
prependPreTag Maybe Key
Nothing QT
qt = QT
qt
prependPreTag (Just Key
tag) QT
qt = WinTags -> QT -> QT
prependTags' [(Key
tag,TagTask -> TagUpdate
PreUpdate TagTask
TagTask)] QT
qt
prependGroupResets :: [Tag] -> QT -> QT
prependGroupResets :: [Key] -> QT -> QT
prependGroupResets [] QT
qt = QT
qt
prependGroupResets [Key]
tags QT
qt = WinTags -> QT -> QT
prependTags' [(Key
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetGroupStopTask)|Key
tag<-[Key]
tags] QT
qt
prependTags' :: TagList -> QT -> QT
prependTags' :: WinTags -> QT -> QT
prependTags' [] QT
qt = QT
qt
prependTags' WinTags
tcs' qt :: QT
qt@(Testing {}) = QT
qt { qt_a = prependTags' tcs' (qt_a qt)
, qt_b = prependTags' tcs' (qt_b qt) }
prependTags' WinTags
tcs' (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w,qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t,qt_other :: QT -> QTrans
qt_other=QTrans
o}) =
Simple { qt_win :: WinTags
qt_win = if WinTags -> Bool
noWin WinTags
w then WinTags
w else WinTags
tcs' WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
`mappend` WinTags
w
, qt_trans :: CharMap QTrans
qt_trans = (QTrans -> QTrans) -> CharMap QTrans -> CharMap QTrans
forall a b. (a -> b) -> CharMap a -> CharMap b
Map.map QTrans -> QTrans
forall {a}. IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans CharMap QTrans
t
, qt_other :: QTrans
qt_other = QTrans -> QTrans
forall {a}. IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans QTrans
o }
where prependQTrans :: IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
prependQTrans = ([(a, WinTags)] -> [(a, WinTags)])
-> IntMap [(a, WinTags)] -> IntMap [(a, WinTags)]
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, WinTags) -> (a, WinTags)) -> [(a, WinTags)] -> [(a, WinTags)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
d,WinTags
tcs) -> (a
d,WinTags
tcs' WinTags -> WinTags -> WinTags
forall a. Monoid a => a -> a -> a
`mappend` WinTags
tcs)))
type S = State (Index
,[(Index,QNFA)]->[(Index,QNFA)])
type E = (TagTasks
,Either QNFA QT)
type ActCont = ( E
, Maybe E
, Maybe (TagTasks,QNFA))
newQNFA :: String -> QT -> S QNFA
newQNFA :: [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt = do
(Key
thisI,[(Key, QNFA)] -> [(Key, QNFA)]
oldQs) <- StateT
(Key, [(Key, QNFA)] -> [(Key, QNFA)])
Identity
(Key, [(Key, QNFA)] -> [(Key, QNFA)])
forall s (m :: * -> *). MonadState s m => m s
get
let futureI :: Key
futureI = Key -> Key
forall a. Enum a => a -> a
succ Key
thisI in Key -> S QNFA -> S QNFA
forall a b. a -> b -> b
seq Key
futureI (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ [Char] -> S QNFA -> S QNFA
forall a s. Show a => a -> s -> s
debug ([Char]
">newQNFA< "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Key -> [Char]
forall a. Show a => a -> [Char]
show Key
thisI) (S QNFA -> S QNFA) -> S QNFA -> S QNFA
forall a b. (a -> b) -> a -> b
$ do
let qnfa :: QNFA
qnfa = Key -> QT -> QNFA
mkQNFA Key
thisI QT
qt
(Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> (Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$! (Key
futureI, [(Key, QNFA)] -> [(Key, QNFA)]
oldQs ([(Key, QNFA)] -> [(Key, QNFA)])
-> ([(Key, QNFA)] -> [(Key, QNFA)])
-> [(Key, QNFA)]
-> [(Key, QNFA)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
thisI,QNFA
qnfa)(Key, QNFA) -> [(Key, QNFA)] -> [(Key, QNFA)]
forall a. a -> [a] -> [a]
:))
QNFA -> S QNFA
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa
fromQNFA :: QNFA -> E
fromQNFA :: QNFA -> E
fromQNFA QNFA
qnfa = (TagTasks
forall a. Monoid a => a
mempty,QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)
fromQT :: QT -> E
fromQT :: QT -> E
fromQT QT
qt = (TagTasks
forall a. Monoid a => a
mempty,QT -> Either QNFA QT
forall a b. b -> Either a b
Right QT
qt)
asQNFA :: String -> E -> S E
asQNFA :: [Char] -> E -> S E
asQNFA [Char]
_ x :: E
x@(TagTasks
_,Left QNFA
_) = E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return E
x
asQNFA [Char]
s (TagTasks
tags,Right QT
qt) = do QNFA
qnfa <- [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt
E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TagTasks
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)
getQNFA :: String -> E -> S QNFA
getQNFA :: [Char] -> E -> S QNFA
getQNFA [Char]
_ ([],Left QNFA
qnfa) = QNFA -> S QNFA
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return QNFA
qnfa
getQNFA [Char]
s (TagTasks
tags,Left QNFA
qnfa) = [Char] -> QT -> S QNFA
newQNFA [Char]
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) (QNFA -> QT
q_qt QNFA
qnfa))
getQNFA [Char]
s (TagTasks
tags,Right QT
qt) = [Char] -> QT -> S QNFA
newQNFA [Char]
s (WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) QT
qt)
getQT :: E -> QT
getQT :: E -> QT
getQT (TagTasks
tags,Either QNFA QT
cont) = WinTags -> QT -> QT
prependTags' ((TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate TagTasks
tags) ((QNFA -> QT) -> (QT -> QT) -> Either QNFA QT -> QT
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_qt QT -> QT
forall a. a -> a
id Either QNFA QT
cont)
addTest :: TestInfo -> E -> E
addTest :: TestInfo -> E -> E
addTest TestInfo
ti (TagTasks
tags,Either QNFA QT
cont) = (TagTasks
tags, QT -> Either QNFA QT
forall a b. b -> Either a b
Right (QT -> Either QNFA QT)
-> (Either QNFA QT -> QT) -> Either QNFA QT -> Either QNFA QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> QT -> QT
applyTest TestInfo
ti (QT -> QT) -> (Either QNFA QT -> QT) -> Either QNFA QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QNFA -> QT) -> (QT -> QT) -> Either QNFA QT -> QT
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QNFA -> QT
q_qt QT -> QT
forall a. a -> a
id (Either QNFA QT -> Either QNFA QT)
-> Either QNFA QT -> Either QNFA QT
forall a b. (a -> b) -> a -> b
$ Either QNFA QT
cont)
promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList
promoteTasks :: (TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
promote TagTasks
tags = ((Key, TagTask) -> (Key, TagUpdate)) -> TagTasks -> WinTags
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
tag,TagTask
task) -> (Key
tag,TagTask -> TagUpdate
promote TagTask
task)) TagTasks
tags
demoteTags :: TagList -> TagTasks
demoteTags :: WinTags -> TagTasks
demoteTags = ((Key, TagUpdate) -> (Key, TagTask)) -> WinTags -> TagTasks
forall a b. (a -> b) -> [a] -> [b]
map (Key, TagUpdate) -> (Key, TagTask)
forall {a}. (a, TagUpdate) -> (a, TagTask)
helper
where helper :: (a, TagUpdate) -> (a, TagTask)
helper (a
tag,PreUpdate TagTask
tt) = (a
tag,TagTask
tt)
helper (a
tag,PostUpdate TagTask
tt) = (a
tag,TagTask
tt)
{-# INLINE addWinTags #-}
addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a)
addWinTags :: forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags (TagTasks
tags,a
cont) = (WinTags -> TagTasks
demoteTags WinTags
wtags TagTasks -> TagTasks -> TagTasks
forall a. Monoid a => a -> a -> a
`mappend` TagTasks
tags
,a
cont)
{-# INLINE addTag' #-}
addTag' :: Tag -> (TagTasks,a) -> (TagTasks,a)
addTag' :: forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag (TagTasks
tags,a
cont) = ((Key
tag,TagTask
TagTask)(Key, TagTask) -> TagTasks -> TagTasks
forall a. a -> [a] -> [a]
:TagTasks
tags
,a
cont)
addTag :: Maybe Tag -> E -> E
addTag :: Maybe Key -> E -> E
addTag Maybe Key
Nothing E
e = E
e
addTag (Just Key
tag) E
e = Key -> E -> E
forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag E
e
{-# INLINE addGroupResets #-}
addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)
addGroupResets :: forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [] (TagTasks, a)
x = (TagTasks, a)
x
addGroupResets [Key]
tags (TagTasks
tags',a
cont) = (((Key, TagTask) -> TagTasks -> TagTasks)
-> TagTasks -> TagTasks -> TagTasks
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) TagTasks
tags' (TagTasks -> TagTasks) -> ([Key] -> TagTasks) -> [Key] -> TagTasks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> (Key, TagTask)) -> [Key] -> TagTasks
forall a b. (a -> b) -> [a] -> [b]
map (\Key
tag -> (Key
tag,TagTask
ResetGroupStopTask)) ([Key] -> TagTasks) -> [Key] -> TagTasks
forall a b. (a -> b) -> a -> b
$ [Key]
tags
,a
cont)
addGroupSets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)
addGroupSets :: forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [] (TagTasks, a)
x = (TagTasks, a)
x
addGroupSets [Key]
tags (TagTasks
tags',a
cont) = (((Key, TagTask) -> TagTasks -> TagTasks)
-> TagTasks -> TagTasks -> TagTasks
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) TagTasks
tags' (TagTasks -> TagTasks) -> ([Key] -> TagTasks) -> [Key] -> TagTasks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> (Key, TagTask)) -> [Key] -> TagTasks
forall a b. (a -> b) -> [a] -> [b]
map (\Key
tag -> (Key
tag,TagTask
SetGroupStopTask)) ([Key] -> TagTasks) -> [Key] -> TagTasks
forall a b. (a -> b) -> a -> b
$ [Key]
tags
,a
cont)
getE :: ActCont -> E
getE :: ActCont -> E
getE (E
_,Maybe E
_,Just (TagTasks
tags,QNFA
qnfa)) = (TagTasks
tags, QNFA -> Either QNFA QT
forall a b. a -> Either a b
Left QNFA
qnfa)
getE (E
eLoop,Just E
accepting,Maybe (TagTasks, QNFA)
_) = QT -> E
fromQT (QT -> QT -> QT
mergeQT (E -> QT
getQT E
eLoop) (E -> QT
getQT E
accepting))
getE (E
eLoop,Maybe E
Nothing,Maybe (TagTasks, QNFA)
_) = E
eLoop
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC :: TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
_) = (TestInfo -> E -> E
addTest TestInfo
ti E
e
,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestInfo -> E -> E
addTest TestInfo
ti) Maybe E
mE
,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
addTagAC :: Maybe Tag -> ActCont -> ActCont
addTagAC :: Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
Nothing ActCont
ac = ActCont
ac
addTagAC (Just Key
tag) (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = (Key -> E -> E
forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag E
e
,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key -> E -> E
forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag) Maybe E
mE
,((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. Key -> (TagTasks, a) -> (TagTasks, a)
addTag' Key
tag) Maybe (TagTasks, QNFA)
mQNFA)
addGroupResetsAC :: [Tag] -> ActCont -> ActCont
addGroupResetsAC :: [Key] -> ActCont -> ActCont
addGroupResetsAC [] ActCont
ac = ActCont
ac
addGroupResetsAC [Key]
tags (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = ([Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
tags E
e
,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
tags) Maybe E
mE
,((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
tags) Maybe (TagTasks, QNFA)
mQNFA)
addGroupSetsAC :: [Tag] -> ActCont -> ActCont
addGroupSetsAC :: [Key] -> ActCont -> ActCont
addGroupSetsAC [] ActCont
ac = ActCont
ac
addGroupSetsAC [Key]
tags (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = ([Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags E
e
,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags) Maybe E
mE
,((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
tags) Maybe (TagTasks, QNFA)
mQNFA)
addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC :: WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags (E
e,Maybe E
mE,Maybe (TagTasks, QNFA)
mQNFA) = (WinTags -> E -> E
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags E
e
,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> E -> E
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags) Maybe E
mE
,((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags) Maybe (TagTasks, QNFA)
mQNFA)
qToNFA :: CompOption -> Q -> (Index,Array Index QNFA)
qToNFA :: CompOption -> Q -> (Key, Array Key QNFA)
qToNFA CompOption
compOpt Q
qTop = (QNFA -> Key
q_id QNFA
startingQNFA
,(Key, Key) -> [(Key, QNFA)] -> Array Key QNFA
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Key
0,Key -> Key
forall a. Enum a => a -> a
pred Key
lastIndex) ([(Key, QNFA)] -> [(Key, QNFA)]
table [])) where
(QNFA
startingQNFA,(Key
lastIndex,[(Key, QNFA)] -> [(Key, QNFA)]
table)) =
S QNFA
-> (Key, [(Key, QNFA)] -> [(Key, QNFA)])
-> (QNFA, (Key, [(Key, QNFA)] -> [(Key, QNFA)]))
forall s a. State s a -> s -> (a, s)
runState (Q -> E -> S E
getTrans Q
qTop (QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ QT
qtwin) S E -> (E -> S QNFA) -> S QNFA
forall a b.
StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
-> (a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity b)
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> E -> S QNFA
getQNFA [Char]
"top level") (Key, [(Key, QNFA)] -> [(Key, QNFA)])
forall {a}. (Key, a -> a)
startState
startState :: (Key, a -> a)
startState = (Key
0,a -> a
forall a. a -> a
id)
getTrans,getTransTagless :: Q -> E -> S E
getTrans :: Q -> E -> S E
getTrans qIn :: Q
qIn@(Q {preReset :: Q -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post,unQ :: Q -> P
unQ=P
pIn}) E
e = [Char] -> S E -> S E
forall a s. Show a => a -> s -> s
debug ([Char]
">< getTrans "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
case P
pIn of
OneChar Pattern
pat -> [Char] -> [Key] -> Maybe Key -> Pattern -> E -> S E
newTrans [Char]
"getTrans/OneChar" [Key]
resets Maybe Key
pre Pattern
pat (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
P
Empty -> E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
Test TestInfo
ti -> E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> E -> E
addTest TestInfo
ti (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ E
e
P
_ -> E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (E -> E) -> E -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupResets [Key]
resets (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
addTag Maybe Key
pre (E -> S E) -> S E -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTransTagless Q
qIn (Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e)
getTransTagless :: Q -> E -> S E
getTransTagless Q
qIn E
e = [Char] -> S E -> S E
forall a s. Show a => a -> s -> s
debug ([Char]
">< getTransTagless "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$
case Q -> P
unQ Q
qIn of
Seq Q
q1 Q
q2 -> Q -> E -> S E
getTrans Q
q1 (E -> S E) -> S E -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q2 E
e
Or [] -> E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return E
e
Or [Q
q] -> Q -> E -> S E
getTrans Q
q E
e
Or [Q]
qs -> do
[E]
eqts <- if Q -> Bool
usesQNFA Q
qIn
then do
E
eQNFA <- [Char] -> E -> S E
asQNFA [Char]
"getTransTagless/Or/usesQNFA" E
e
[S E] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Q -> E -> S E
getTrans Q
q E
eQNFA | Q
q <- [Q]
qs ]
else [S E] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Q -> E -> S E
getTrans Q
q E
e | Q
q <- [Q]
qs ]
let qts :: [QT]
qts = (E -> QT) -> [E] -> [QT]
forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT [E]
eqts
E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT ((QT -> QT -> QT) -> [QT] -> QT
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts))
Star Maybe Key
mOrbit [Key]
resetTheseOrbits Bool
mayFirstBeNull Q
q ->
let (E
e',Bool
clear) =
if Q -> Bool
notNullable Q
q then (E
e,Bool
True)
else if [Key] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Key -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
Just [] -> (E
e,Bool
True)
Just WinTags
tagList -> (WinTags -> E -> E
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
tagList E
e,Bool
False)
Maybe WinTags
_ -> (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)
else (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit
(QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e,Bool
False)
in if Q -> Bool
cannotAccept Q
q then E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return E
e' else mdo
Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
this
(E
this,E
ans) <- case Maybe QT
mqt of
Maybe QT
Nothing -> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (E, E)
forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/Star: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
Just QT
qt -> do
let qt' :: QT
qt' = [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit (QT -> QT) -> QT -> QT
forall a b. (a -> b) -> a -> b
$ QT
qt
thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
qt' (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit (E -> QT) -> E -> QT
forall a b. (a -> b) -> a -> b
$ E
e
ansE :: E
ansE = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
qt' (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e'
E
thisE <- if Q -> Bool
usesQNFA Q
q
then E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QNFA -> E) -> QNFA -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QNFA -> E
fromQNFA (QNFA -> S E) -> S QNFA -> S E
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> QT -> S QNFA
newQNFA [Char]
"getTransTagless/Star" QT
thisQT
else E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QT -> E) -> QT -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> S E) -> QT -> S E
forall a b. (a -> b) -> a -> b
$ QT
thisQT
(E, E)
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (E, E)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E
thisE,E
ansE)
E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
mayFirstBeNull then (if Bool
clear then E
this
else E
ans)
else E
this)
NonEmpty Q
q -> [Char] -> S E -> S E
forall a. [Char] -> a -> a
ecart ([Char]
"\n> getTransTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn) (S E -> S E) -> S E -> S E
forall a b. (a -> b) -> a -> b
$ do
Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
let e' :: E
e' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
Just [] -> E
e
Just WinTags
_wtags -> E
e
Maybe WinTags
Nothing -> [Char] -> E
forall a. [Char] -> a
err ([Char] -> E) -> [Char] -> E
forall a b. (a -> b) -> a -> b
$ [Char]
"getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn
Maybe QT
mqt <- Q -> E -> S (Maybe QT)
inStar Q
q E
e
E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> E -> S E
forall a b. (a -> b) -> a -> b
$ case Maybe QT
mqt of
Maybe QT
Nothing -> [Char] -> E
forall a. [Char] -> a
err ([Char]
"Weird pattern in getTransTagless/NonEmpty: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
Just QT
qt -> QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT_2nd QT
qt (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
e'
P
_ -> [Char] -> S E
forall a. [Char] -> a
err ([Char]
"This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
inStar,inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStar :: Q -> E -> S (Maybe QT)
inStar qIn :: Q
qIn@(Q {preReset :: Q -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post}) E
eLoop | Q -> Bool
notNullable Q
qIn =
[Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/1 "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QT -> S (Maybe QT)) -> (E -> Maybe QT) -> E -> S (Maybe QT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> Maybe QT
forall a. a -> Maybe a
Just (QT -> Maybe QT) -> (E -> QT) -> E -> Maybe QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> S (Maybe QT)) -> S E -> S (Maybe QT)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn E
eLoop
| Bool
otherwise =
[Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStar/2 "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QT -> S (Maybe QT))
-> (Maybe QT -> Maybe QT) -> Maybe QT -> S (Maybe QT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QT -> QT) -> Maybe QT -> Maybe QT
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Key] -> QT -> QT
prependGroupResets [Key]
resets (QT -> QT) -> (QT -> QT) -> QT -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
prependPreTag Maybe Key
pre) (Maybe QT -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn (Maybe Key -> E -> E
addTag Maybe Key
post (E -> E) -> (E -> E) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> E -> E
forall a. Show a => [Key] -> (TagTasks, a) -> (TagTasks, a)
addGroupSets [Key]
sets (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
eLoop)
inStarNullableTagless :: Q -> E -> S (Maybe QT)
inStarNullableTagless Q
qIn E
eLoop = [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a s. Show a => a -> s -> s
debug ([Char]
">< inStarNullableTagless "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$ do
case Q -> P
unQ Q
qIn of
P
Empty -> Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing
Or [] -> Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing
Or [Q
q] -> Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop
Or [Q]
qs -> do
[Maybe QT]
mqts <- if Q -> Bool
usesQNFA Q
qIn
then do E
eQNFA <- [Char] -> E -> S E
asQNFA [Char]
"inStarNullableTagless/Or/usesQNFA" E
eLoop
[S (Maybe QT)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [Maybe QT]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Q -> E -> S (Maybe QT)
inStar Q
q E
eQNFA | Q
q <- [Q]
qs ]
else [S (Maybe QT)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [Maybe QT]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q -> E -> S (Maybe QT)
inStar Q
q E
eLoop | Q
q <- [Q]
qs ]
let qts :: [QT]
qts = [Maybe QT] -> [QT]
forall a. [Maybe a] -> [a]
catMaybes [Maybe QT]
mqts
mqt :: Maybe QT
mqt = if [QT] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts then Maybe QT
forall a. Maybe a
Nothing else QT -> Maybe QT
forall a. a -> Maybe a
Just ((QT -> QT -> QT) -> [QT] -> QT
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
mqt
Seq Q
q1 Q
q2 -> do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
Star {} -> do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
NonEmpty {} -> [Char] -> S (Maybe QT) -> S (Maybe QT)
forall a. [Char] -> a -> a
ecart ([Char]
"\n> inStarNullableTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn) (S (Maybe QT) -> S (Maybe QT)) -> S (Maybe QT) -> S (Maybe QT)
forall a b. (a -> b) -> a -> b
$
do (E
_,Maybe E
meAcceptingOut,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullableTagless Q
qIn (E
eLoop,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((E -> QT) -> Maybe E -> Maybe QT
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> QT
getQT Maybe E
meAcceptingOut)
Test {} -> Maybe QT -> S (Maybe QT)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QT
forall a. Maybe a
Nothing
OneChar {} -> [Char] -> S (Maybe QT)
forall a. [Char] -> a
err ([Char]
"OneChar cannot have nullable True")
act :: Q -> ActCont -> S (Maybe E)
act :: Q -> ActCont -> S (Maybe E)
act Q
qIn ActCont
c | Q -> Bool
nullable Q
qIn = (ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall a b.
(a -> b)
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
qIn ActCont
c
| Bool
otherwise = [Char] -> S (Maybe E) -> S (Maybe E)
forall a s. Show a => a -> s -> s
debug ([Char]
">< act "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S (Maybe E) -> S (Maybe E)) -> S (Maybe E) -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ do
Maybe E
mqt <- Maybe E -> S (Maybe E)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe E -> S (Maybe E)) -> (E -> Maybe E) -> E -> S (Maybe E)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> Maybe E
forall a. a -> Maybe a
Just (E -> S (Maybe E)) -> S E -> S (Maybe E)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
qIn ( ActCont -> E
getE (ActCont -> E) -> ActCont -> E
forall a b. (a -> b) -> a -> b
$ ActCont
c )
Maybe E -> S (Maybe E)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe E
mqt
actNullable,actNullableTagless :: Q -> ActCont -> S ActCont
actNullable :: Q -> ActCont -> S ActCont
actNullable qIn :: Q
qIn@(Q {preReset :: Q -> [Key]
preReset=[Key]
resets,postSet :: Q -> [Key]
postSet=[Key]
sets,preTag :: Q -> Maybe Key
preTag=Maybe Key
pre,postTag :: Q -> Maybe Key
postTag=Maybe Key
post,unQ :: Q -> P
unQ=P
pIn}) ActCont
ac =
[Char] -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug ([Char]
">< actNullable "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
case P
pIn of
P
Empty -> ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
Test TestInfo
ti -> ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestInfo -> ActCont -> ActCont
addTestAC TestInfo
ti (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> S ActCont) -> ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac
OneChar {} -> [Char] -> S ActCont
forall a. [Char] -> a
err ([Char]
"OneChar cannot have nullable True ")
P
_ -> ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont -> S ActCont)
-> (ActCont -> ActCont) -> ActCont -> S ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupResetsAC [Key]
resets (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
pre (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullableTagless Q
qIn ( Maybe Key -> ActCont -> ActCont
addTagAC Maybe Key
post (ActCont -> ActCont) -> (ActCont -> ActCont) -> ActCont -> ActCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> ActCont -> ActCont
addGroupSetsAC [Key]
sets (ActCont -> ActCont) -> ActCont -> ActCont
forall a b. (a -> b) -> a -> b
$ ActCont
ac )
actNullableTagless :: Q -> ActCont -> S ActCont
actNullableTagless Q
qIn ac :: ActCont
ac@(E
eLoop,Maybe E
mAccepting,Maybe (TagTasks, QNFA)
mQNFA) = [Char] -> S ActCont -> S ActCont
forall a s. Show a => a -> s -> s
debug ([Char]
">< actNullableTagless "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show (Q
qIn)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" <>") (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
case Q -> P
unQ Q
qIn of
Seq Q
q1 Q
q2 -> Q -> ActCont -> S ActCont
actNullable Q
q1 (ActCont -> S ActCont) -> S ActCont -> S ActCont
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> ActCont -> S ActCont
actNullable Q
q2 ActCont
ac
Or [] -> ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac
Or [Q
q] -> Q -> ActCont -> S ActCont
actNullableTagless Q
q ActCont
ac
Or [Q]
qs -> do
[Maybe E]
cqts <- do
if (Q -> Bool) -> [Q] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Q -> Bool
nullable [Q]
qs
then [S (Maybe E)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [Maybe E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [(ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall a b.
(a -> b)
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac | Q
q <- [Q]
qs]
else do
E
e' <- [Char] -> E -> S E
asQNFA [Char]
"qToNFA/actNullableTagless/Or" (E -> S E) -> (ActCont -> E) -> ActCont -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> S E) -> ActCont -> S E
forall a b. (a -> b) -> a -> b
$ ActCont
ac
let act' :: Q -> S (Maybe E)
act' :: Q -> S (Maybe E)
act' Q
q = Maybe E -> S (Maybe E)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe E -> S (Maybe E)) -> (E -> Maybe E) -> E -> S (Maybe E)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> Maybe E
forall a. a -> Maybe a
Just (E -> S (Maybe E)) -> S E -> S (Maybe E)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q -> E -> S E
getTrans Q
q E
e'
[S (Maybe E)]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity [Maybe E]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ if Q -> Bool
nullable Q
q then (ActCont -> Maybe E) -> S ActCont -> S (Maybe E)
forall a b.
(a -> b)
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActCont -> Maybe E
forall a b c. (a, b, c) -> b
snd3 (S ActCont -> S (Maybe E)) -> S ActCont -> S (Maybe E)
forall a b. (a -> b) -> a -> b
$ Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac else Q -> S (Maybe E)
act' Q
q | Q
q <- [Q]
qs ]
let qts :: [QT]
qts = (E -> QT) -> [E] -> [QT]
forall a b. (a -> b) -> [a] -> [b]
map E -> QT
getQT ([Maybe E] -> [E]
forall a. [Maybe a] -> [a]
catMaybes [Maybe E]
cqts)
eLoop' :: E
eLoop' = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
Just WinTags
wtags -> WinTags -> E -> E
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags E
eLoop
Maybe WinTags
Nothing -> QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
qIn) (E -> QT
getQT E
eLoop)
mAccepting' :: Maybe E
mAccepting' = if [QT] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
then (E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
applyNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
qIn) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT) Maybe E
mAccepting
else E -> Maybe E
forall a. a -> Maybe a
Just (QT -> E
fromQT (QT -> E) -> QT -> E
forall a b. (a -> b) -> a -> b
$ (QT -> QT -> QT) -> [QT] -> QT
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 QT -> QT -> QT
mergeAltQT [QT]
qts)
mQNFA' :: Maybe (TagTasks, QNFA)
mQNFA' = if [QT] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QT]
qts
then case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
Just WinTags
wtags -> ((TagTasks, QNFA) -> (TagTasks, QNFA))
-> Maybe (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinTags -> (TagTasks, QNFA) -> (TagTasks, QNFA)
forall a. WinTags -> (TagTasks, a) -> (TagTasks, a)
addWinTags WinTags
wtags) Maybe (TagTasks, QNFA)
mQNFA
Maybe WinTags
Nothing -> Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing
else Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing
ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E
eLoop',Maybe E
mAccepting',Maybe (TagTasks, QNFA)
mQNFA')
Star Maybe Key
mOrbit [Key]
resetTheseOrbits Bool
mayFirstBeNull Q
q -> do
let (ac0 :: ActCont
ac0@(E
_,Maybe E
mAccepting0,Maybe (TagTasks, QNFA)
_),Bool
clear) =
if Q -> Bool
notNullable Q
q
then (ActCont
ac,Bool
True)
else if [Key] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
resetTheseOrbits Bool -> Bool -> Bool
&& Maybe Key -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Key
mOrbit
then case Q -> Maybe WinTags
maybeOnlyEmpty Q
q of
Just [] -> (ActCont
ac,Bool
True)
Just WinTags
wtags -> (WinTags -> ActCont -> ActCont
addWinTagsAC WinTags
wtags ActCont
ac,Bool
False)
Maybe WinTags
_ -> let nQ :: E -> E
nQ = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT
in ((E -> E
nQ E
eLoop,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing),Bool
False)
else let nQ :: E -> E
nQ = QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit
(QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SetTestInfo, WinTags)] -> QT -> QT
preferNullViews (Q -> [(SetTestInfo, WinTags)]
nullQ Q
q) (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (E -> E) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit
in ((E -> E
nQ E
eLoop,(E -> E) -> Maybe E -> Maybe E
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> E
nQ Maybe E
mAccepting,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing),Bool
False)
if Q -> Bool
cannotAccept Q
q then ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ActCont
ac0 else mdo
Maybe E
mChildAccepting <- Q -> ActCont -> S (Maybe E)
act Q
q (E
this,Maybe E
forall a. Maybe a
Nothing,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
(thisAC :: ActCont
thisAC@(E
this,Maybe E
_,Maybe (TagTasks, QNFA)
_),ActCont
ansAC) <-
case Maybe E
mChildAccepting of
Maybe E
Nothing -> [Char]
-> StateT
(Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont)
forall a. [Char] -> a
err ([Char]
-> StateT
(Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont))
-> [Char]
-> StateT
(Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont)
forall a b. (a -> b) -> a -> b
$ [Char]
"Weird pattern in getTransTagless/Star: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
Just E
childAccepting -> do
let childQT :: QT
childQT = [Key] -> QT -> QT
resetOrbitsQT [Key]
resetTheseOrbits (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> QT -> QT
enterOrbitQT Maybe Key
mOrbit (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> E -> QT
forall a b. (a -> b) -> a -> b
$ E
childAccepting
thisQT :: QT
thisQT = QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (ActCont -> QT) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (ActCont -> E) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> E -> E
leaveOrbit Maybe Key
mOrbit (E -> E) -> (ActCont -> E) -> ActCont -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac
thisAccepting :: Maybe E
thisAccepting =
case Maybe E
mAccepting of
Just E
futureAccepting -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting
Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
ActCont
thisAll <- if Q -> Bool
usesQNFA Q
q
then do QNFA
thisQNFA <- [Char] -> QT -> S QNFA
newQNFA [Char]
"actNullableTagless/Star" QT
thisQT
ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> E
fromQNFA QNFA
thisQNFA, Maybe E
thisAccepting, (TagTasks, QNFA) -> Maybe (TagTasks, QNFA)
forall a. a -> Maybe a
Just (TagTasks
forall a. Monoid a => a
mempty,QNFA
thisQNFA))
else ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (QT -> E
fromQT QT
thisQT, Maybe E
thisAccepting, Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
let skipQT :: QT
skipQT = QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (ActCont -> QT) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> QT) -> (ActCont -> E) -> ActCont -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActCont -> E
getE (ActCont -> QT) -> ActCont -> QT
forall a b. (a -> b) -> a -> b
$ ActCont
ac0
skipAccepting :: Maybe E
skipAccepting =
case Maybe E
mAccepting0 of
Just E
futureAccepting0 -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAccepting0
Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
ansAll :: (E, Maybe E, Maybe a)
ansAll = (QT -> E
fromQT QT
skipQT, Maybe E
skipAccepting, Maybe a
forall a. Maybe a
Nothing)
(ActCont, ActCont)
-> StateT
(Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity (ActCont, ActCont)
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ActCont
thisAll,ActCont
forall {a}. (E, Maybe E, Maybe a)
ansAll)
ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
mayFirstBeNull then (if Bool
clear then ActCont
thisAC else ActCont
ansAC)
else ActCont
thisAC)
NonEmpty Q
q -> [Char] -> S ActCont -> S ActCont
forall a. [Char] -> a -> a
ecart ([Char]
"\n> actNullableTagless/NonEmpty"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Q -> [Char]
forall a. Show a => a -> [Char]
show Q
qIn) (S ActCont -> S ActCont) -> S ActCont -> S ActCont
forall a b. (a -> b) -> a -> b
$ do
Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
mustAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
Bool
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q -> Bool
cannotAccept Q
q) ([Char] -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a. [Char] -> a
err ([Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ())
-> [Char]
-> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn))
let (E
clearE,Maybe E
_,Maybe (TagTasks, QNFA)
_) = case Q -> Maybe WinTags
maybeOnlyEmpty Q
qIn of
Just [] -> ActCont
ac
Just WinTags
_wtags -> ActCont
ac
Maybe WinTags
Nothing -> [Char] -> ActCont
forall a. [Char] -> a
err ([Char] -> ActCont) -> [Char] -> ActCont
forall a b. (a -> b) -> a -> b
$ [Char]
"actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
(E
_,Maybe E
mChildAccepting,Maybe (TagTasks, QNFA)
_) <- Q -> ActCont -> S ActCont
actNullable Q
q ActCont
ac
case Maybe E
mChildAccepting of
Maybe E
Nothing -> [Char] -> S ActCont
forall a. [Char] -> a
err ([Char] -> S ActCont) -> [Char] -> S ActCont
forall a b. (a -> b) -> a -> b
$ [Char]
"Weird pattern in actNullableTagless/NonEmpty: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
Just E
childAccepting -> do
let childQT :: QT
childQT = E -> QT
getQT E
childAccepting
thisAccepting :: Maybe E
thisAccepting = case Maybe E
mAccepting of
Maybe E
Nothing -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (QT -> E) -> QT -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> Maybe E) -> QT -> Maybe E
forall a b. (a -> b) -> a -> b
$ QT
childQT
Just E
futureAcceptingE -> E -> Maybe E
forall a. a -> Maybe a
Just (E -> Maybe E) -> (E -> E) -> E -> Maybe E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> E) -> (E -> QT) -> E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> QT -> QT
mergeQT QT
childQT (QT -> QT) -> (E -> QT) -> E -> QT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> QT
getQT (E -> Maybe E) -> E -> Maybe E
forall a b. (a -> b) -> a -> b
$ E
futureAcceptingE
ActCont -> S ActCont
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E
clearE,Maybe E
thisAccepting,Maybe (TagTasks, QNFA)
forall a. Maybe a
Nothing)
P
_ -> [Char] -> S ActCont
forall a. [Char] -> a
err ([Char] -> S ActCont) -> [Char] -> S ActCont
forall a b. (a -> b) -> a -> b
$ [Char]
"This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Q) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Q
qIn)
resetOrbitsQT :: [Tag] -> QT -> QT
resetOrbitsQT :: [Key] -> QT -> QT
resetOrbitsQT | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (QT -> QT) -> [Key] -> QT -> QT
forall a b. a -> b -> a
const QT -> QT
forall a. a -> a
id
| Bool
otherwise = (\[Key]
tags -> WinTags -> QT -> QT
prependTags' [(Key
tag,TagTask -> TagUpdate
PreUpdate TagTask
ResetOrbitTask)|Key
tag<-[Key]
tags])
enterOrbitQT :: Maybe Tag -> QT -> QT
enterOrbitQT :: Maybe Key -> QT -> QT
enterOrbitQT | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (QT -> QT) -> Maybe Key -> QT -> QT
forall a b. a -> b -> a
const QT -> QT
forall a. a -> a
id
| Bool
otherwise = (QT -> QT) -> (Key -> QT -> QT) -> Maybe Key -> QT -> QT
forall b a. b -> (a -> b) -> Maybe a -> b
maybe QT -> QT
forall a. a -> a
id (\Key
tag->WinTags -> QT -> QT
prependTags' [(Key
tag,TagTask -> TagUpdate
PreUpdate TagTask
EnterOrbitTask)])
leaveOrbit :: Maybe Tag -> E -> E
leaveOrbit :: Maybe Key -> E -> E
leaveOrbit | CompOption -> Bool
lastStarGreedy CompOption
compOpt = (E -> E) -> Maybe Key -> E -> E
forall a b. a -> b -> a
const E -> E
forall a. a -> a
id
| Bool
otherwise = (E -> E) -> (Key -> E -> E) -> Maybe Key -> E -> E
forall b a. b -> (a -> b) -> Maybe a -> b
maybe E -> E
forall a. a -> a
id (\Key
tag->(\(TagTasks
tags,Either QNFA QT
cont)->((Key
tag,TagTask
LeaveOrbitTask)(Key, TagTask) -> TagTasks -> TagTasks
forall a. a -> [a] -> [a]
:TagTasks
tags,Either QNFA QT
cont)))
newTrans :: String
-> [Tag]
-> Maybe Tag
-> Pattern
-> E
-> S E
newTrans :: [Char] -> [Key] -> Maybe Key -> Pattern -> E -> S E
newTrans [Char]
s [Key]
resets Maybe Key
mPre Pattern
pat (TagTasks
tags,Either QNFA QT
cont) = do
Key
i <- case Either QNFA QT
cont of
Left QNFA
qnfa -> Key -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity Key
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Key
q_id QNFA
qnfa)
Right QT
qt -> do QNFA
qnfa <- [Char] -> QT -> S QNFA
newQNFA [Char]
s QT
qt
Key -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity Key
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (QNFA -> Key
q_id QNFA
qnfa)
let post :: WinTags
post = (TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PostUpdate TagTasks
tags
pre :: WinTags
pre = (TagTask -> TagUpdate) -> TagTasks -> WinTags
promoteTasks TagTask -> TagUpdate
PreUpdate ([(Key
tag,TagTask
ResetGroupStopTask) | Key
tag<-[Key]
resets] TagTasks -> TagTasks -> TagTasks
forall a. [a] -> [a] -> [a]
++ TagTasks -> (Key -> TagTasks) -> Maybe Key -> TagTasks
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Key
tag -> [(Key
tag,TagTask
TagTask)]) Maybe Key
mPre)
E -> S E
forall a.
a -> StateT (Key, [(Key, QNFA)] -> [(Key, QNFA)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> S E) -> (QT -> E) -> QT -> S E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QT -> E
fromQT (QT -> S E) -> QT -> S E
forall a b. (a -> b) -> a -> b
$ WinTags -> Pattern -> WinTags -> Key -> QT
acceptTrans WinTags
pre Pattern
pat WinTags
post Key
i
acceptTrans :: TagList -> Pattern -> TagList -> Index -> QT
acceptTrans :: WinTags -> Pattern -> WinTags -> Key -> QT
acceptTrans WinTags
pre Pattern
pIn WinTags
post Key
i =
let target :: QTrans
target = Key -> [TagCommand] -> QTrans
forall a. Key -> a -> IntMap a
IMap.singleton Key
i [(Pattern -> DoPa
getDoPa Pattern
pIn,WinTags
preWinTags -> WinTags -> WinTags
forall a. [a] -> [a] -> [a]
++WinTags
post)]
in case Pattern
pIn of
PChar DoPa
_ Char
char ->
let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target [Char
char]
in Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
PEscape DoPa
_ Char
char ->
let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target [Char
char]
in Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
PDot DoPa
_ -> Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
dotTrans, qt_other :: QTrans
qt_other = QTrans
target }
PAny DoPa
_ PatternSet
ps ->
let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
target ([Char] -> CharMap QTrans)
-> (PatternSet -> [Char]) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> [Char]
forall a. Set a -> [a]
S.toAscList (Set Char -> [Char])
-> (PatternSet -> Set Char) -> PatternSet -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet (PatternSet -> CharMap QTrans) -> PatternSet -> CharMap QTrans
forall a b. (a -> b) -> a -> b
$ PatternSet
ps
in Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
forall a. Monoid a => a
mempty }
PAnyNot DoPa
_ PatternSet
ps ->
let trans :: CharMap QTrans
trans = QTrans -> [Char] -> CharMap QTrans
toMap QTrans
forall a. Monoid a => a
mempty ([Char] -> CharMap QTrans)
-> (PatternSet -> [Char]) -> PatternSet -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> [Char]
forall a. Set a -> [a]
S.toAscList (Set Char -> [Char])
-> (PatternSet -> Set Char) -> PatternSet -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> Set Char
addNewline (Set Char -> Set Char)
-> (PatternSet -> Set Char) -> PatternSet -> Set Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternSet -> Set Char
decodePatternSet (PatternSet -> CharMap QTrans) -> PatternSet -> CharMap QTrans
forall a b. (a -> b) -> a -> b
$ PatternSet
ps
in Simple { qt_win :: WinTags
qt_win = WinTags
forall a. Monoid a => a
mempty, qt_trans :: CharMap QTrans
qt_trans = CharMap QTrans
trans, qt_other :: QTrans
qt_other = QTrans
target }
Pattern
_ -> [Char] -> QT
forall a. [Char] -> a
err ([Char]
"Cannot acceptTrans pattern "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Q, Pattern) -> [Char]
forall a. Show a => a -> [Char]
show (Q
qTop,Pattern
pIn))
where
toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]
-> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])])
toMap :: QTrans -> [Char] -> CharMap QTrans
toMap QTrans
dest | CompOption -> Bool
caseSensitive CompOption
compOpt = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> ([Char] -> IntMap QTrans) -> [Char] -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, QTrans)] -> IntMap QTrans
forall a. [(Key, a)] -> IntMap a
IMap.fromDistinctAscList ([(Key, QTrans)] -> IntMap QTrans)
-> ([Char] -> [(Key, QTrans)]) -> [Char] -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Key, QTrans)) -> [Char] -> [(Key, QTrans)]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Char -> Key
ord Char
c,QTrans
dest))
| Bool
otherwise = IntMap QTrans -> CharMap QTrans
forall a. IntMap a -> CharMap a
CharMap (IntMap QTrans -> CharMap QTrans)
-> ([Char] -> IntMap QTrans) -> [Char] -> CharMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, QTrans)] -> IntMap QTrans
forall a. [(Key, a)] -> IntMap a
IMap.fromList ([(Key, QTrans)] -> IntMap QTrans)
-> ([Char] -> [(Key, QTrans)]) -> [Char] -> IntMap QTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)] -> [(Key, QTrans)]
forall a b. (a -> b) -> a -> b
$ [])
(([(Key, QTrans)] -> [(Key, QTrans)]) -> [(Key, QTrans)])
-> ([Char] -> [(Key, QTrans)] -> [(Key, QTrans)])
-> [Char]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [Char]
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c [(Key, QTrans)] -> [(Key, QTrans)]
dl -> if Char -> Bool
isAlpha Char
c
then ([(Key, QTrans)] -> [(Key, QTrans)]
dl([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toUpper Char
c),QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:)
([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord (Char -> Char
toLower Char
c),QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:)
)
else ([(Key, QTrans)] -> [(Key, QTrans)]
dl([(Key, QTrans)] -> [(Key, QTrans)])
-> ([(Key, QTrans)] -> [(Key, QTrans)])
-> [(Key, QTrans)]
-> [(Key, QTrans)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Char -> Key
ord Char
c,QTrans
dest)(Key, QTrans) -> [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> [a] -> [a]
:))
) [(Key, QTrans)] -> [(Key, QTrans)]
forall a. a -> a
id
addNewline :: Set Char -> Set Char
addNewline | CompOption -> Bool
multiline CompOption
compOpt = Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
S.insert Char
'\n'
| Bool
otherwise = Set Char -> Set Char
forall a. a -> a
id
dotTrans :: CharMap QTrans
dotTrans | CompOption -> Bool
multiline CompOption
compOpt = Char -> QTrans -> CharMap QTrans
forall a. Char -> a -> CharMap a
Map.singleton Char
'\n' QTrans
forall a. Monoid a => a
mempty
| Bool
otherwise = CharMap QTrans
forall a. Monoid a => a
Mon.mempty