{-# OPTIONS_GHC -fno-warn-orphans #-} -- XXX design uncertainty: should preResets be inserted into nullView? -- if not, why not? ADDED -- XXX design uncertainty: what does act -> actNullable -> -- actNullableTagless not use nullQ and same for inStar, etc? -- TODO : try rewriting whole qToNFA in terms of "act" -- (That will require re-organizing the continuation data a bit) -- | "Text.Regex.TDFA.TNFA" converts the CorePattern Q/P data (and its -- Pattern leafs) to a QNFA tagged non-deterministic finite automata. -- -- This holds every possible way to follow one state by another, while -- in the DFA these will be reduced by picking a single best -- transition for each (soure,destination) pair. The transitions are -- heavily and often redundantly annotated with tasks to perform, and -- this redundancy is reduced when picking the best transition. So -- far, keeping all this information has helped fix bugs in both the -- design and implementation. -- -- The QNFA for a Pattern with a starTraned Q/P form with N one -- character accepting leaves has at most N+1 nodes. These nodes -- repesent the future choices after accepting a leaf. The processing -- of Or nodes often reduces this number by sharing at the end of the -- different paths. Turning off capturing while compiling the pattern -- may (future extension) reduce this further for some patterns by -- processing Star with optimizations. This compact design also means -- that tags are assigned not just to be updated before taking a -- transition (PreUpdate) but also after the transition (PostUpdate). -- -- Uses recursive do notation. module Text.Regex.TDFA.TNFA(patternToNFA ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} import Control.Monad.State import Data.Array.IArray(Array,array) import Data.Char(toLower,toUpper,isAlpha,ord) import Data.List(foldl') import Data.IntMap.CharMap(CharMap(..)) import qualified Data.IntMap.CharMap as Map(null,toAscList,singleton,map) import Data.IntMap (IntMap) import qualified Data.IntMap as IMap(size,toList,toAscList,null,unionWith,singleton,fromList,fromDistinctAscList) import Data.Maybe(catMaybes,isNothing) import Data.Monoid(mempty,mappend) import Data.IntSet.EnumSet(EnumSet) import qualified Data.IntSet.EnumSet as Set(singleton,toList,insert) import qualified Data.IntMap.EnumMap as EMap(null,keysSet,assocs) import qualified Data.Set(insert,toAscList) import Text.Regex.TDFA.Common import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView ,SetTestInfo(..),Wanted(..),TestInfo ,mustAccept,cannotAccept,patternToQ) import Text.Regex.TDFA.Pattern(Pattern(..)) import Text.Regex.TDFA.ReadRegex(decodePatternSet) import Debug.Trace ecart :: String -> a -> a ecart _ = id err :: String -> a err t = common_error "Text.Regex.TDFA.TNFA" t debug :: (Show a) => a -> s -> s debug _ s = s instance Show QNFA where show (QNFA {q_id = i, q_qt = qt}) = "QNFA {q_id = "++show i ++"\n ,q_qt = "++ show qt ++"\n}" instance Show QT where show = showQT showQT :: QT -> String showQT (Simple win trans other) = "{qt_win=" ++ show win ++ "\n, qt_trans=" ++ show (foo trans) ++ "\n, qt_other=" ++ show (foo' other) ++ "}" showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas) ++"\n"++indent a ++"\n"++indent b++"}" where indent = init . unlines . map (spaces++) . lines . showQT spaces = replicate 9 ' ' foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])] foo = mapSnd foo' . Map.toAscList foo' :: QTrans -> [(Index,[TagCommand])] foo' = IMap.toList instance Eq QT where t1@(Testing {}) == t2@(Testing {}) = (qt_test t1) == (qt_test t2) && (qt_a t1) == (qt_a t2) && (qt_b t1) == (qt_b t2) (Simple w1 (CharMap t1) o1) == (Simple w2 (CharMap t2) o2) = w1 == w2 && eqTrans && eqQTrans o1 o2 where eqTrans :: Bool eqTrans = (IMap.size t1 == IMap.size t2) && and (zipWith together (IMap.toAscList t1) (IMap.toAscList t2)) where together (c1,qtrans1) (c2,qtrans2) = (c1 == c2) && eqQTrans qtrans1 qtrans2 eqQTrans :: QTrans -> QTrans -> Bool eqQTrans = (==) _ == _ = False -- This uses the Eq QT instace above -- ZZZ mkTesting :: QT -> QT mkTesting t@(Testing {qt_a=a,qt_b=b}) = if a==b then a else t -- Move to nfsToDFA XXX mkTesting t = t qtwin,qtlose :: QT qtwin = Simple {qt_win=[(1,PreUpdate TagTask)],qt_trans=mempty,qt_other=mempty} qtlose = Simple {qt_win=mempty,qt_trans=mempty,qt_other=mempty} patternToNFA :: CompOption -> (Text.Regex.TDFA.Pattern.Pattern,(GroupIndex, DoPa)) -> ((Index,Array Index QNFA) ,Array Tag OP ,Array GroupIndex [GroupInfo]) patternToNFA compOpt pattern = let (q,tags,groups) = patternToQ compOpt pattern msg = unlines [ show q ] in debug msg (qToNFA compOpt q,tags,groups) -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- dumb smart constructor used by qToQNFA -- could replace with something that is -- (*) Monadic, using uniq to auto generate the new i -- (*) Puts the new QNFA into the State's (list->list) (so it is ascending in order) -- (*) Actually creates a simple DFA instead? mkQNFA :: Int -> QT -> QNFA mkQNFA i qt = debug ("\n>QNFA id="++show i) $ -- XXX Go through the qt and keep only the best tagged transition(s) to each state. QNFA i (debug ("\ngetting QT for "++show i) qt) nullable :: Q -> Bool nullable = not . null . nullQ notNullable :: Q -> Bool notNullable = null . nullQ -- This asks if the preferred (i.e. first) NullView has no tests. maybeOnlyEmpty :: Q -> Maybe WinTags maybeOnlyEmpty (Q {nullQ = ((SetTestInfo sti,tags):_)}) = if EMap.null sti then Just tags else Nothing maybeOnlyEmpty _ = Nothing usesQNFA :: Q -> Bool usesQNFA (Q {wants=WantsBoth}) = True usesQNFA (Q {wants=WantsQNFA}) = True usesQNFA _ = False nullQT :: QT -> Bool nullQT (Simple {qt_win=w,qt_trans=t,qt_other=o}) = noWin w && Map.null t && IMap.null o nullQT _ = False listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest listTestInfo qt s = execState (helper qt) s where helper (Simple {}) = return () helper (Testing {qt_test = wt, qt_a = a, qt_b = b}) = do modify (Set.insert wt) helper a helper b -- This is used to view "win" only through NullView applyNullViews :: NullView -> QT -> QT applyNullViews [] win = win applyNullViews nvs win = foldl' (dominate win winTests) qtlose (reverse $ cleanNullView nvs) where winTests = listTestInfo win $ mempty -- This is used to prefer to view "win" through NullView. Losing is -- replaced by the plain win. This is employed by Star patterns to -- express that the first iteration is allowed to match null, but -- skipping the NullView occurs if the match fails. preferNullViews :: NullView -> QT -> QT preferNullViews [] win = win preferNullViews nvs win = foldl' (dominate win winTests) win (reverse $ cleanNullView nvs) where winTests = listTestInfo win $ mempty dominate :: QT -> EnumSet WhichTest -> QT -> (SetTestInfo,WinTags) -> QT dominate win winTests lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $ let -- The winning states are reached through the SetTag win' = prependTags' tags win -- get the SetTestInfo allTests = (listTestInfo lose $ EMap.keysSet sti) `mappend` winTests useTest _ [] w _ = w -- no more dominating tests to fail to choose lose, so just choose win useTest (aTest:tests) allD@((dTest,dopas):ds) w l = let (wA,wB,wD) = branches w (lA,lB,lD) = branches l branches qt@(Testing {}) | aTest==qt_test qt = (qt_a qt,qt_b qt,qt_dopas qt) branches qt = (qt,qt,mempty) in if aTest == dTest then Testing {qt_test = aTest ,qt_dopas = (dopas `mappend` wD) `mappend` lD ,qt_a = useTest tests ds wA lA ,qt_b = lB} else Testing {qt_test = aTest ,qt_dopas = wD `mappend` lD ,qt_a = useTest tests allD wA lA ,qt_b = useTest tests allD wB lB} useTest [] _ _ _ = err "This case in applyNullViews.useText cannot happen" in useTest (Set.toList allTests) (EMap.assocs sti) win' lose applyTest :: TestInfo -> QT -> QT applyTest (wt,dopa) qt | nullQT qt = qt | otherwise = applyTest' qt where applyTest' :: QT -> QT applyTest' q@(Simple {}) = mkTesting $ Testing {qt_test = wt ,qt_dopas = Set.singleton dopa ,qt_a = q ,qt_b = qtlose} applyTest' q@(Testing {qt_test=wt'}) = case compare wt wt' of LT -> Testing {qt_test = wt ,qt_dopas = Set.singleton dopa ,qt_a = q ,qt_b = qtlose} EQ -> q {qt_dopas = Set.insert dopa (qt_dopas q) ,qt_b = qtlose} GT -> q {qt_a = applyTest' (qt_a q) ,qt_b = applyTest' (qt_b q)} -- Three ways to merge a pair of QT's varying how winning transitions -- are handled. -- -- mergeQT_2nd is used by the NonEmpty case -- -- mergeAltQT is used by the Or cases -- -- mergeQT_2nd,mergeAltQT,mergeQT :: QT -> QT -> QT mergeQT_2nd q1 q2 | nullQT q1 = q2 -- prefer winning with w1 then with w2 | otherwise = mergeQTWith (\_ w2 -> w2) q1 q2 mergeAltQT q1 q2 | nullQT q1 = q2 -- prefer winning with w1 then with w2 | otherwise = mergeQTWith (\w1 w2 -> if noWin w1 then w2 else w1) q1 q2 mergeQT q1 q2 | nullQT q1 = q2 -- union wins | nullQT q2 = q1 -- union wins | otherwise = mergeQTWith mappend q1 q2 -- no preference, win with combined SetTag XXX is the wrong thing! "(.?)*" -- This takes a function which implements a policy on mergining -- winning transitions and then merges all the transitions. It opens -- the CharMap newtype for more efficient operation, then rewraps it. mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT mergeQTWith mergeWins = merge where merge :: QT -> QT -> QT merge (Simple w1 t1 o1) (Simple w2 t2 o2) = let w' = mergeWins w1 w2 t' = fuseQTrans t1 o1 t2 o2 o' = mergeQTrans o1 o2 in Simple w' t' o' merge s@(Simple {}) t@(Testing _ _ a b) = mkTesting $ t {qt_a=(merge s a), qt_b=(merge s b)} merge t@(Testing _ _ a b) s@(Simple {}) = mkTesting $ t {qt_a=(merge a s), qt_b=(merge b s)} merge t1@(Testing wt1 ds1 a1 b1) t2@(Testing wt2 ds2 a2 b2) = mkTesting $ case compare wt1 wt2 of LT -> t1 {qt_a=(merge a1 t2), qt_b=(merge b1 t2)} EQ -> Testing {qt_test = wt1 -- same as wt2 ,qt_dopas = mappend ds1 ds2 ,qt_a = merge a1 a2 ,qt_b = merge b1 b2} GT -> t2 {qt_a=(merge t1 a2), qt_b=(merge t1 b2)} fuseQTrans :: (CharMap QTrans) -> QTrans -> (CharMap QTrans) -> QTrans -> CharMap QTrans fuseQTrans (CharMap t1) o1 (CharMap t2) o2 = CharMap (IMap.fromDistinctAscList (fuse l1 l2)) where l1 = IMap.toAscList t1 l2 = IMap.toAscList t2 fuse [] y = mapSnd (mergeQTrans o1) y fuse x [] = mapSnd (mergeQTrans o2) x fuse x@((xc,xa):xs) y@((yc,ya):ys) = case compare xc yc of LT -> (xc,mergeQTrans xa o2) : fuse xs y EQ -> (xc,mergeQTrans xa ya) : fuse xs ys GT -> (yc,mergeQTrans o1 ya) : fuse x ys mergeQTrans :: QTrans -> QTrans -> QTrans mergeQTrans = IMap.unionWith mappend -- Type of State monad used inside qToNFA type S = State (Index -- Next available QNFA index ,[(Index,QNFA)]->[(Index,QNFA)]) -- DList of previous QNFAs -- Type of continuation of the NFA, not much more complicated type E = (TagTasks -- Things to de before the Either QNFA QT ,Either QNFA QT) -- The future, packged in the best way type ActCont = (E, Maybe E, Maybe (TagTasks,QNFA)) newQNFA :: String -> QT -> S QNFA newQNFA s qt = do (thisI,oldQs) <- get let futureI = succ thisI in seq futureI $ debug (">newQNFA< "++s++" : "++show thisI) $ do let qnfa = mkQNFA thisI qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ put (futureI, oldQs . ((thisI,qnfa):)) return qnfa -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == fromQNFA :: QNFA -> E fromQNFA qnfa = (mempty,Left qnfa) fromQT :: QT -> E fromQT qt = (mempty,Right qt) -- Promises (Left qnfa) asQNFA :: String -> E -> S E asQNFA _ x@(_,Left _) = return x asQNFA s (tags,Right qt) = do qnfa <- newQNFA s qt -- YYY Policy choice: leave the tags return (tags, Left qnfa) getQNFA :: String -> E -> S QNFA getQNFA _ ([],Left qnfa) = return qnfa getQNFA s (tags,Left qnfa) = newQNFA s (prependTags' (promoteTasks PreUpdate tags) (q_qt qnfa)) getQNFA s (tags,Right qt) = newQNFA s (prependTags' (promoteTasks PreUpdate tags) qt) getQT :: E -> QT getQT (tags,cont) = prependTags' (promoteTasks PreUpdate tags) (either q_qt id cont) addTest :: TestInfo -> E -> E addTest ti (tags,Left qnfa) = (tags, Right $ applyTest ti (q_qt qnfa)) addTest ti (tags,Right qt) = (tags, Right $ applyTest ti qt) promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList promoteTasks promote tags = map (\(tag,task) -> (tag,promote task)) tags demoteTags :: TagList -> TagTasks demoteTags = map helper where helper (tag,PreUpdate tt) = (tag,tt) helper (tag,PostUpdate tt) = (tag,tt) {-# INLINE addWinTags #-} addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a) addWinTags wtags (tags,cont) = (demoteTags wtags `mappend` tags,cont) {-# INLINE addTag' #-} addTag' :: Tag -> (TagTasks,a) -> (TagTasks,a) addTag' tag (tags,cont) = ((tag,TagTask):tags,cont) {-# INLINE addGroupResets #-} addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a) addGroupResets [] x = x addGroupResets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,ResetGroupStopTask)) $ tags,cont) addTag :: Maybe Tag -> E -> E addTag Nothing e = e addTag (Just tag) e = addTag' tag e {- XXX use QT form instead enterOrbit :: Maybe Tag -> E -> E enterOrbit Nothing e = e enterOrbit (Just tag) (tags,cont) = ((tag,EnterOrbitTask):tags,cont) -} addTestAC :: TestInfo -> ActCont -> ActCont addTestAC ti (e,mE,_) = (addTest ti e ,fmap (addTest ti) mE ,Nothing) addTagAC :: Maybe Tag -> ActCont -> ActCont addTagAC Nothing ac = ac addTagAC (Just tag) (e,mE,mQNFA) = (addTag' tag e ,fmap (addTag' tag) mE ,fmap (addTag' tag) mQNFA) addGroupResetsAC :: [Tag] -> ActCont -> ActCont addGroupResetsAC [] ac = ac addGroupResetsAC tags (e,mE,mQNFA) = (addGroupResets tags e ,fmap (addGroupResets tags) mE ,fmap (addGroupResets tags) mQNFA) addWinTagsAC :: WinTags -> ActCont -> ActCont addWinTagsAC wtags (e,mE,mQNFA) = (addWinTags wtags e ,fmap (addWinTags wtags) mE ,fmap (addWinTags wtags) mQNFA) getE :: ActCont -> E getE (_,_,Just (tags,qnfa)) = (tags, Left qnfa) -- consume optimized mQNFA value returned by Star getE (eLoop,Just accepting,_) = mergeE eLoop accepting getE (eLoop,Nothing,_) = eLoop mergeE :: E -> E -> E mergeE e1 e2 = fromQT (mergeQT (getQT e1) (getQT e2)) prependTag :: Maybe Tag -> QT -> QT prependTag Nothing qt = qt prependTag (Just tag) qt = prependTags' [(tag,PreUpdate TagTask)] qt prependGroupResets :: [Tag] -> QT -> QT prependGroupResets [] qt = qt prependGroupResets tags qt = prependTags' [(tag,PreUpdate ResetGroupStopTask)|tag<-tags] qt prependTags' :: TagList -> QT -> QT prependTags' tcs' qt@(Testing {}) = qt { qt_a = prependTags' tcs' (qt_a qt) , qt_b = prependTags' tcs' (qt_b qt) } prependTags' tcs' (Simple {qt_win=w,qt_trans=t,qt_other=o}) = Simple { qt_win = if noWin w then w else tcs' `mappend` w , qt_trans = Map.map prependQTrans t , qt_other = prependQTrans o } where prependQTrans = fmap (map (\(d,tcs) -> (d,tcs' `mappend` tcs))) -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Initial preTag of 0th tag is implied -- No other general pre-tags would be expected qToNFA :: CompOption -> Q -> (Index,Array Index QNFA) qToNFA compOpt qTop = (q_id startingQNFA ,array (0,pred lastIndex) (table [])) where (startingQNFA,(lastIndex,table)) = runState (getTrans qTop (fromQT $ qtwin) >>= getQNFA "top level") startState startState = (0,id) -- This is the only place where PostUpdate is used newTrans :: String -> [Tag] -> Maybe Tag -> Pattern -> E -> S E newTrans s resets mPre pat (tags,cont) = do i <- case cont of Left qnfa -> return (q_id qnfa) -- strictQNFA ZZZ no help Right qt -> do qnfa <- newQNFA s qt -- strictQT ZZZ no help return (q_id qnfa) let post = promoteTasks PostUpdate tags pre = promoteTasks PreUpdate ([(tag,ResetGroupStopTask) | tag<-resets] ++ maybe [] (\tag -> [(tag,TagTask)]) mPre) return . fromQT $ acceptTrans pre pat post i -- fromQT $ strictQT no help getTrans,getTransTagless :: Q -> E -> S E getTrans qIn@(Q {preReset=resets,preTag=pre,postTag=post,unQ=pIn}) e = debug (">< getTrans "++show qIn++" <>") $ -- liftM strictE $ -- ZZZ causes stack overflow in test (1,36) case pIn of OneChar pat -> newTrans "getTrans/OneChar" resets pre pat . addTag post $ e Empty -> return . addGroupResets resets . addTag pre . addTag post $ e Test ti -> return . addGroupResets resets . addTag pre . addTest ti . addTag post $ e _ -> return . addGroupResets resets . addTag pre =<< getTransTagless qIn (addTag post $ e) getTransTagless qIn e = debug (">< getTransTagless "++show qIn++" <>") $ case unQ qIn of Seq q1 q2 -> getTrans q1 =<< getTrans q2 e Or [] -> return e Or [q] -> getTrans q e Or qs -> do eqts <- if usesQNFA qIn then do eQNFA <- asQNFA "getTransTagless/Or/usesQNFA" e sequence [ getTrans q eQNFA | q <- qs ] else sequence [ getTrans q e | q <- qs ] let qts = map getQT eqts return (fromQT (foldr1 mergeAltQT qts)) Star mOrbit resetTheseOrbits mayFirstBeNull q -> let (e',clear) = -- debug ("\n>"++show e++"\n"++show q++"\n<") $ if notNullable q then (e,True) -- subpattern cannot be null else if null resetTheseOrbits && isNothing mOrbit then case maybeOnlyEmpty q of Just [] -> (e,True) -- True because null of subpattern is same as skipping subpattern Just tagList -> (addWinTags tagList e,False) -- null of subpattern NOT same as skipping _ -> (fromQT . preferNullViews (nullQ q) . getQT $ e,False) -- is NOT same as skipping else (fromQT . resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit . preferNullViews (nullQ q) . getQT . leaveOrbit mOrbit $ e,False) -- perform resets when accepting 0 characters in if cannotAccept q then return e' else mdo mqt <- inStar q this (this,ans) <- case mqt of Nothing -> err ("Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn)) Just qt -> do let qt' = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit $ qt thisQT = mergeQT qt' . getQT . leaveOrbit mOrbit $ e -- capture of subpattern or leave via next pattern (avoid null of subpattern on way out) ansE = fromQT . mergeQT qt' . getQT $ e' -- capture of subpattern or leave via null of subpattern thisE <- if usesQNFA q then return . fromQNFA =<< newQNFA "getTransTagless/Star" thisQT else return . fromQT $ thisQT return (thisE,ansE) return (if mayFirstBeNull then (if clear then this -- optimization to possibly preserve QNFA else ans) else this) {- NonEmpty is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -} NonEmpty q -> ecart ("\n> getTransTagless/NonEmpty"++show qIn) $ do -- Assertion to check than Pattern.starTrans did its job right: when (cannotAccept q) (err $ "getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn)) when (mustAccept q) (err $ "getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn)) let e' = case maybeOnlyEmpty qIn of Just [] -> e Just _wtags -> e -- addWinTags wtags e XXX was duplicating tags Nothing -> err $ "getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "++show qIn mqt <- inStar q e return $ case mqt of Nothing -> err ("Weird pattern in getTransTagless/NonEmpty: " ++ show (qTop,qIn)) Just qt -> fromQT . mergeQT_2nd qt . getQT $ e' -- ...and then this sets qt_win to exactly that of e' _ -> err ("This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" ++ show (qTop,qIn)) inStar,inStarNullableTagless :: Q -> E -> S (Maybe QT) inStar qIn@(Q {preReset=resets,preTag=pre,postTag=post}) eLoop | notNullable qIn = debug (">< inStar/1 "++show qIn++" <>") $ return . Just . getQT =<< getTrans qIn eLoop | otherwise = debug (">< inStar/2 "++show qIn++" <>") $ return . fmap (prependGroupResets resets . prependTag pre) =<< inStarNullableTagless qIn (addTag post $ eLoop) inStarNullableTagless qIn eLoop = debug (">< inStarNullableTagless "++show qIn++" <>") $ do case unQ qIn of Empty -> return Nothing -- with Or this discards () branch in "(^|foo|())*" Or [] -> return Nothing Or [q] -> inStar q eLoop Or qs -> do mqts <- if usesQNFA qIn then do eQNFA <- asQNFA "inStarNullableTagless/Or/usesQNFA" eLoop sequence [ inStar q eQNFA | q <- qs ] else sequence [inStar q eLoop | q <- qs ] let qts = catMaybes mqts mqt = if null qts then Nothing else Just (foldr1 mergeAltQT qts) return mqt Seq q1 q2 -> do (_,meAcceptingOut,_) <- actNullable q1 =<< actNullable q2 (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut) Star {} -> do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut) NonEmpty {} -> ecart ("\n> inStarNullableTagless/NonEmpty"++show qIn) $ do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut) Test {} -> return Nothing -- with Or this discards ^ branch in "(^|foo|())*" OneChar {} -> err ("OneChar cannot have nullable True") {- act* functions These have a very complicated state that they receive and return as "the continuation". (E, Maybe E,Maybe (SetTag,QNFA)) The first E is the source of the danger that must be avoided. It starts out a reference to the QNFA/QT state that will be created by the most recent parent Star node. Thus it is a recursive reference from the MonadFix machinery. In particular, this value cannot be returned to the parent Star to be included in itself or we get a "let x = y; y=x" style infinite loop. As act* progresses the first E is actually modified to be the parent QNFA/QT as "seen" when all the elements to the right have accepted 0 characters. Thus it acquires tags and tests+tags (the NullView data is used for this purpose). The second item in the 3-tuple is a Maybe E. This will be used as the source of the QT for this contents of the Star QNFA/QT. It will be merged with the Star's own continuation data. It starts out Nothing and stays that way as long as there are no accepting transitions in the Star's pattern. This is value (via getQT) returned by inStar. The third item is a special optimization I added to remove a source of orphaned QNFAs. A Star within Act will often have to create a QNFA node. This cannot go into the second Maybe E item as Just (SetTag,Left QNFA) because this QNFA can have pulled values from the recursive parent Star's QNFA/QT in the first E value. Thus pulling with getQT from the QNFA and using that as the Maybe E would likely cause an infinite loop. This extra QNFA is stored in the thd3 location for use by getE. To improve it further it can accumulate Tag information after being formed. When a non nullable Q is handled by act it checks to see if the third value is there, in which case it uses that QNFA as the total continuation (subsumed in getE). Otherwise it merges the first E with any (Just E) in the second value to form the continuation. -} act :: Q -> ActCont -> S (Maybe E) act qIn c | nullable qIn = fmap snd3 $ actNullable qIn c | otherwise = debug (">< act "++show qIn++" <>") $ do mqt <- return . Just =<< getTrans qIn ( getE $ c ) return mqt -- or "return (fromQT qtlose,mqt,Nothing)" actNullable,actNullableTagless :: Q -> ActCont -> S ActCont actNullable qIn@(Q {preReset=resets,preTag=pre,postTag=post,unQ=pIn}) ac = debug (">< actNullable "++show qIn++" <>") $ do case pIn of Empty -> return . addGroupResetsAC resets . addTagAC pre . addTagAC post $ ac Test ti -> return . addGroupResetsAC resets . addTagAC pre . addTestAC ti . addTagAC post $ ac OneChar {} -> err ("OneChar cannot have nullable True ") _ -> return . addGroupResetsAC resets . addTagAC pre =<< actNullableTagless qIn ( addTagAC post $ ac ) actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = debug (">< actNullableTagless "++show (qIn)++" <>") $ do case unQ qIn of Seq q1 q2 -> actNullable q1 =<< actNullable q2 ac -- We know q1 and q2 are nullable Or [] -> return ac Or [q] -> actNullableTagless q ac Or qs -> do cqts <- do if all nullable qs then sequence [fmap snd3 $ actNullable q ac | q <- qs] else do e' <- asQNFA "qToNFA/actNullableTagless/Or" . getE $ ac let act' :: Q -> S (Maybe E) act' q = return . Just =<< getTrans q e' sequence [ if nullable q then fmap snd3 $ actNullable q ac else act' q | q <- qs ] let qts = map getQT (catMaybes cqts) eLoop' = case maybeOnlyEmpty qIn of Just wtags -> addWinTags wtags eLoop -- nullable without tests; avoid getQT Nothing -> fromQT $ applyNullViews (nullQ qIn) (getQT eLoop) -- suspect this of duplicating some tags with nullQ qIn mAccepting' = if null qts then fmap (fromQT . applyNullViews (nullQ qIn) . getQT) mAccepting -- suspect this of duplicating some tags with nullQ qIn else Just (fromQT $ foldr1 mergeAltQT qts) mQNFA' = if null qts then case maybeOnlyEmpty qIn of Just wtags -> fmap (addWinTags wtags) mQNFA Nothing -> Nothing else Nothing return (eLoop',mAccepting',mQNFA') Star mOrbit resetTheseOrbits mayFirstBeNull q -> do let (ac0@(_,mAccepting0,_),clear) = if notNullable q then (ac,True) else if null resetTheseOrbits && isNothing mOrbit then case maybeOnlyEmpty q of Just [] -> (ac,True) Just wtags -> (addWinTagsAC wtags ac,False) _ -> let nQ = fromQT . preferNullViews (nullQ q) . getQT in ((nQ eLoop,fmap nQ mAccepting,Nothing),False) else let nQ = fromQT . resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit . preferNullViews (nullQ q) . getQT . leaveOrbit mOrbit in ((nQ eLoop,fmap nQ mAccepting,Nothing),False) if cannotAccept q then return ac0 else mdo mChildAccepting <- act q (this,Nothing,Nothing) (thisAC@(this,_,_),ansAC) <- case mChildAccepting of Nothing -> err $ "Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn) Just childAccepting -> do let childQT = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit . getQT $ childAccepting thisQT = mergeQT childQT . getQT . leaveOrbit mOrbit . getE $ ac thisAccepting = case mAccepting of Just futureAccepting -> Just . fromQT . mergeQT childQT . getQT $ futureAccepting Nothing -> Just . fromQT $ childQT thisAll <- if usesQNFA q then do thisQNFA <- newQNFA "actNullableTagless/Star" thisQT return (fromQNFA thisQNFA, thisAccepting, Just (mempty,thisQNFA)) else return (fromQT thisQT, thisAccepting, Nothing) let skipQT = mergeQT childQT . getQT . getE $ ac0 -- for first iteration the continuation uses NullView skipAccepting = case mAccepting0 of Just futureAccepting0 -> Just . fromQT . mergeQT childQT . getQT $ futureAccepting0 Nothing -> Just . fromQT $ childQT ansAll = (fromQT skipQT, skipAccepting, Nothing) return (thisAll,ansAll) return (if mayFirstBeNull then (if clear then thisAC else ansAC) else thisAC) NonEmpty q -> ecart ("\n> actNullableTagless/NonEmpty"++show qIn) $ do -- We *know* that q is nullable from Pattern and CorePattern checks, but assert here anyway when (mustAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn)) when (cannotAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn)) {- This is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -} let (clearE,_,_) = case maybeOnlyEmpty qIn of Just [] -> ac Just _wtags -> ac -- addWinTagsAC wtags ac XXX was duplicating tags Nothing -> err $ "actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "++show (qTop,qIn) (_,mChildAccepting,_) <- actNullable q ac case mChildAccepting of Nothing -> err $ "Weird pattern in actNullableTagless/NonEmpty: " ++ show (qTop,qIn) -- cannotAccept q checked for and excluded the above condition (and starTrans!) Just childAccepting -> do let childQT = getQT childAccepting thisAccepting = case mAccepting of Nothing -> Just . fromQT $ childQT Just futureAcceptingE -> Just . fromQT . mergeQT childQT . getQT $ futureAcceptingE -- I _think_ there is no need for mergeQT_2nd in the above. return (clearE,thisAccepting,Nothing) _ -> err $ "This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "++show (qTop,qIn) -- This is applied directly to any qt immediately before passing to mergeQT resetOrbitsQT :: [Tag] -> QT -> QT resetOrbitsQT | lastStarGreedy compOpt = const id | otherwise = (\tags -> prependTags' [(tag,PreUpdate ResetOrbitTask)|tag<-tags]) enterOrbitQT :: Maybe Tag -> QT -> QT enterOrbitQT | lastStarGreedy compOpt = const id | otherwise = maybe id (\tag->prependTags' [(tag,PreUpdate EnterOrbitTask)]) leaveOrbit :: Maybe Tag -> E -> E leaveOrbit | lastStarGreedy compOpt = const id | otherwise = maybe id (\tag->(\(tags,cont)->((tag,LeaveOrbitTask):tags,cont))) acceptTrans :: TagList -> Pattern -> TagList -> Index -> QT acceptTrans pre pIn post i = let target = IMap.singleton i [(getDoPa pIn,pre++post)] in case pIn of PChar _ char -> let trans = toMap target [char] in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty } PEscape _ char -> let trans = toMap target [char] in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty } PDot _ -> Simple { qt_win = mempty, qt_trans = dotTrans, qt_other = target } PAny _ ps -> let trans = toMap target . Data.Set.toAscList . decodePatternSet $ ps in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty } PAnyNot _ ps -> let trans = toMap mempty . Data.Set.toAscList . addNewline . decodePatternSet $ ps in Simple { qt_win = mempty, qt_trans = trans, qt_other = target } _ -> err ("Cannot acceptTrans pattern "++show (qTop,pIn)) where -- Take a common destination and a sorted list of unique chraceters -- and create a map from those characters to the common destination toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char] -> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])]) toMap dest | caseSensitive compOpt = CharMap . IMap.fromDistinctAscList . map (\c -> (ord c,dest)) | otherwise = CharMap . IMap.fromList . ($ []) . foldr (\c dl -> if isAlpha c then (dl.((ord (toUpper c),dest):) .((ord (toLower c),dest):) ) else (dl.((ord c,dest):)) ) id addNewline | multiline compOpt = Data.Set.insert '\n' | otherwise = id dotTrans | multiline compOpt = Map.singleton '\n' mempty | otherwise = mempty