diff --git a/Text/Regex/PDeriv/ByteString/LeftToRight.lhs b/Text/Regex/PDeriv/ByteString/LeftToRight.lhs --- a/Text/Regex/PDeriv/ByteString/LeftToRight.lhs +++ b/Text/Regex/PDeriv/ByteString/LeftToRight.lhs @@ -34,7 +34,7 @@ > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Pretty (Pretty(..)) -> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), nub2, minBinder, maxBinder) +> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), nub2, preBinder, mainBinder, subBinder) > import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.PDeriv.Parse > import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub) @@ -328,14 +328,15 @@ > case greedyPatMatchCompiled r bs of > Nothing -> Right (Nothing) > Just env -> -> let pre = case lookup minBinder env of { Just w -> w ; Nothing -> S.empty } -> post = case lookup maxBinder env of { Just w -> w ; Nothing -> S.empty } -> full_len = S.length bs +> let pre = case lookup preBinder env of { Just w -> w ; Nothing -> S.empty } +> post = case lookup subBinder env of { Just w -> w ; Nothing -> S.empty } +> {- full_len = S.length bs > pre_len = S.length pre > post_len = S.length post > main_len = full_len - pre_len - post_len > main_and_post = S.drop pre_len bs -> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post +> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post -} +> main = case lookup mainBinder env of { Just w -> w ; Nothing -> S.empty } > matched = map snd (filter (\(v,w) -> v > 0) env) > in Right (Just (pre,main,post,matched)) diff --git a/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs b/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs --- a/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs +++ b/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs @@ -34,7 +34,7 @@ > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Pretty (Pretty(..)) -> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), nub2, minBinder, maxBinder) +> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), nub2, preBinder, mainBinder, subBinder) > import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.PDeriv.Parse > import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insert, insertNotOverwrite, lookupAll, empty, isIn, nub) @@ -402,14 +402,15 @@ > case greedyPatMatchCompiled r bs of > Nothing -> Right (Nothing) > Just env -> -> let pre = case lookup minBinder env of { Just w -> w ; Nothing -> S.empty } -> post = case lookup maxBinder env of { Just w -> w ; Nothing -> S.empty } -> full_len = S.length bs +> let pre = case lookup preBinder env of { Just w -> w ; Nothing -> S.empty } +> post = case lookup subBinder env of { Just w -> w ; Nothing -> S.empty } +> {- full_len = S.length bs > pre_len = S.length pre > post_len = S.length post > main_len = full_len - pre_len - post_len > main_and_post = S.drop pre_len bs -> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post +> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post -} +> main = case lookup mainBinder env of { Just w -> w ; Nothing -> S.empty } > matched = map snd (filter (\(v,w) -> v > 0) env) > in Right (Just (pre,main,post,matched)) @@ -508,3 +509,8 @@ > p11 = PPair (PStar (PVar 1 [] (PE (Seq digits_re (Star digits_re Greedy)))) Greedy) (PPair (PStar (PVar 2 [] (PE (Seq digits_re (Star digits_re Greedy)))) Greedy) (PPair (PStar (PVar 3 [] (PE (Seq digits_re (Star digits_re Greedy)))) Greedy) (PStar (PVar 4 [] (PE (Seq digits_re (Star digits_re Greedy)))) Greedy))) > input11 = S.pack "1234567890123456789-" + + +> Right up34 = compile defaultCompOpt defaultExecOpt (S.pack "(Ab|cD)*") + +> s34 = S.pack "aBcD" diff --git a/Text/Regex/PDeriv/ByteString/Posix.lhs b/Text/Regex/PDeriv/ByteString/Posix.lhs --- a/Text/Regex/PDeriv/ByteString/Posix.lhs +++ b/Text/Regex/PDeriv/ByteString/Posix.lhs @@ -4,6 +4,13 @@ This algorithm exploits the extension of partial derivative of regular expression patterns. This algorithm implements the POSIX matching policy proceeds by scanning the input word from right to left. +The binding scheme for posix is slightly different from the other algos such as LeftToRight, etc. +say given input "ab" pattern "(x :: a), (y :: b)" +the match result is { x -> (1,2) , y -> (2,3) } instead of +{ x -> (1,1), y -> (2,2) } (which was used in LeftToRight). +In Posix matching we need to use (n,n) to denote zero-length match which is used in resetting. +See resetLocalBnd below. Todo: we might want to update other algos to make it consistent + > {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies, > FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} @@ -36,7 +43,7 @@ > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Pretty (Pretty(..)) -> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), IsGreedy(..), nub2, minBinder, maxBinder) +> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsEmpty(..), IsGreedy(..), preBinder, subBinder, mainBinder) > import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.PDeriv.Parse > import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub) @@ -51,7 +58,7 @@ > type Word = S.ByteString > rg_collect :: S.ByteString -> (Int,Int) -> S.ByteString -> rg_collect w (i,j) = S.take (j' - i' + 1) (S.drop i' w) +> rg_collect w (i,j) = S.take (j' - i') (S.drop i' w) > where i' = fromIntegral i > j' = fromIntegral j @@ -114,7 +121,7 @@ > | otherwise = > let > all_sofar_states = acc_states ++ curr_states -> new_delta = [ (s, l, f, s', flag, gf ) | s <- curr_states, l <- sig, ((s',f,gf),flag) <- pdPat0Flag s l] +> new_delta = [ (s, l, f, s', flag, gf) | s <- curr_states, l <- sig, ((s',f, gf),flag) <- pdPat0Flag s l] > new_states = all_sofar_states `seq` D.nub [ s' | (_,_,_,s',_,_) <- new_delta > , not (s' `D.isIn` dict) ] > acc_delta_next = (acc_delta ++ new_delta) @@ -131,14 +138,17 @@ > -- | Function 'collectPatMatchFromBinder' collects match results from binder -> collectPatMatchFromBinder :: Word -> Binder -> Env -> collectPatMatchFromBinder w b = collectPatMatchFromBinder_ w (listifyBinder b) - +> collectPatMatchFromBinder :: Word -> IM.IntMap () -> Binder -> Env +> collectPatMatchFromBinder w posixBnd b = collectPatMatchFromBinder_ w (filter ( \(i,r) -> IM.notMember i posixBnd) (listifyBinder b)) +> collectPatMatchFromBinder_ :: Word -> [(Int,[Range])] -> Env > collectPatMatchFromBinder_ w [] = [] -> collectPatMatchFromBinder_ w ((x,[]):xs) = (x,S.empty):(collectPatMatchFromBinder_ w xs) -> collectPatMatchFromBinder_ w ((x,rs):xs) = (x,foldl S.append S.empty $ map (rg_collect w) (id rs)):(collectPatMatchFromBinder_ w xs) +> collectPatMatchFromBinder_ w ((x,rs):xrs) = +> case rs of +> [] -> (x,S.empty):(collectPatMatchFromBinder_ w xrs) +> rs -> (x,foldl S.append S.empty $ map (rg_collect w) (id rs)):(collectPatMatchFromBinder_ w xrs) + > -- | algorithm right to left scanning single pass > -- | the "partial derivative" operations among integer states + binders > lookupPdPat0' :: PdPat0TableRev -> (Int,Binder) -> Letter -> [(Int,Binder,Int,Bool)] @@ -147,8 +157,21 @@ > Just quatripples -> [ (j, op x b, p, gf) | (j, op, p, gf) <- quatripples ] > Nothing -> [] +> {- | map pattern variable to greedy flag +> type GreedyFlagMap = IM.IntMap Bool -> patMatchesIntStatePdPat0Rev :: Int -> PdPat0TableRev -> Word -> [(Int, Binder, Int, Bool)] -> [(Int, Binder, Int, Bool )] +> buildGFM :: Pat -> GreedyFlagMap +> buildGFM p = IM.fromList (aux p) +> where aux :: Pat -> [(Int,Bool)] +> aux (PVar i rs p) = [(i, isGreedy p)] ++ (aux p) +> aux (PPair p1 p2) = (aux p1) ++ (aux p2) +> aux (PPlus p1 p2) = (aux p1) +> aux (PStar p1 g) = (aux p1) +> aux (PE r) = [] +> aux (PChoice p1 p2 g) = (aux p1) ++ (aux p2) +> aux (PEmpty p) = aux p -} + +> patMatchesIntStatePdPat0Rev :: Int -> PdPat0TableRev -> Word -> [(Int, Binder, Int, Bool)] -> [(Int, Binder, Int, Bool)] > patMatchesIntStatePdPat0Rev cnt pdStateTableRev w fs = > case S.uncons w of > Nothing -> fs @@ -172,9 +195,9 @@ > in (x:xs') > nubPosixSub a@(x@(k,b,n,vs):xs) = > let cmp (k1,b1,_,gf1) (k2,b2,_,gf2) = -> case compare gf1 gf2 of +> case compare gf1 gf2 of > EQ -> compareBinderLocal b1 b2 -- compare (b1,v1) (b2,v2) -> ordering -> ordering +> ordering -> ordering > ys = [ (k',b',n',gf') | (k',b',n',gf') <- a, k == k' ] > zs = [ (k',b',n',gf') | (k',b',n',gf') <- a, not (k == k') ] > y = maximumBy cmp ys @@ -183,16 +206,26 @@ > else nubPosixSub xs -> compareBinderLocal :: Binder -> Binder -> Ordering +> compareBinderLocal :: Binder -> Binder -> Ordering > compareBinderLocal bs bs' = -> let rs = map snd (listifyBinder bs) -> rs' = map snd (listifyBinder bs') +> -- When comparing local binders, we should disregard the preBinder and subBinder in case of unanchored match. +> -- If we include preBinder and subBinder in the local binders comparison, it leads to non-posix result. +> -- Suppose we have unanchored p = (Ab|cD)*, transforming it into an anchored pattern (.*) (Ab|cD)* (.*) where the first (.*) is not greedy. +> -- Since we have only pair constructor, we need to put paranthesis around sub binders, let say ((.*) (Ab|cD)*) (.*) +> -- let input be AbCd, the first (.*) will consume the entire input in order to optimize ((.*) (Ab|cD)*). +> -- similarly, we could construct another counter example "aBcD", if we put paranthesis around the 2nd and 3rd sub binders. +> let rs = map snd (listifyBinder bs) -- map snd (filter (\(x,_) -> x > preBinder && x < subBinder) (listifyBinder bs)) +> rs' = map snd (listifyBinder bs') -- map snd (filter (\(x,_) -> x > preBinder && x < subBinder) (listifyBinder bs')) > os = map (\ (r,r') -> compareRangeLocal r r') (zip rs rs') > in {- logger (print (show os)) `seq` > logger (print (show bs)) `seq` > logger (print (show bs')) `seq` -} > firstNonEQ os +> +> + + > compareRangeLocal :: [Range] -> [Range] -> Ordering > compareRangeLocal [] [] = EQ > compareRangeLocal (x:xs) (y:ys) @@ -229,10 +262,10 @@ > l = S.length w > w' = S.reverse w > fs = [ (i, b, 0, True) | i <- fins ] -> fs' = w' `seq` fins `seq` l `seq` pdStateTableRev `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTableRev w' fs) +> fs' = w' `seq` fins `seq` l `seq` pdStateTableRev `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTableRev w' fs) > -- fs'' = my_sort fs' -> allbinders = [ b | (s,b,_, _) <- fs', s == 0 ] -> in map (collectPatMatchFromBinder w) allbinders +> allbinders = [ b | (s,b,_,_) <- fs', s == 0 ] +> in map (collectPatMatchFromBinder w IM.empty ) allbinders -- todo: fix me > > -- my_sort = sortBy (\ (_,_,ps) (_,_,ps') -> compare ps ps') @@ -248,26 +281,27 @@ > first _ = Nothing -> compilePat :: Pat -> (PdPat0TableRev, [Int], Binder) -> compilePat p = {- pdStateTable `seq` b `seq` -} (pdStateTable, fins, b) +> compilePat :: (Pat,IM.IntMap ()) -> (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap ()) +> compilePat (p,posixBnd) = {- pdStateTable `seq` b `seq` -} (pdStateTable, fins, b, fb, posixBnd) > where > (pdStateTable,fins) = buildPdPat0Table p > b = toBinder p +> fb = followBy p -> patMatchIntStateCompiled :: (PdPat0TableRev, [Int], Binder) -> Word -> [Env] -> patMatchIntStateCompiled (pdStateTable, fins ,b) w = +> patMatchIntStateCompiled :: (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap ()) -> Word -> [Env] +> patMatchIntStateCompiled (pdStateTable, fins, b, fb, posixBinder) w = > let > l = S.length w > w' = S.reverse w > fs = [ (i, b, i, True) | i <- fins ] > fs' = w' `seq` fs `seq` l `seq` pdStateTable `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTable w' fs) > -- fs'' = fs' `seq` my_sort fs' -> allbinders = fs' `seq` [ b' | (s,b',_, _) <- fs', s == 0 ] -> in allbinders `seq` map (collectPatMatchFromBinder w) allbinders +> allbinders = fs' `seq` [ b' | (s,b',_,_) <- fs', s == 0 ] +> in allbinders `seq` map (collectPatMatchFromBinder w posixBinder) allbinders > -> posixPatMatchCompiled :: (PdPat0TableRev, [Int], Binder) -> Word -> Maybe Env +> posixPatMatchCompiled :: (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap ()) -> Word -> Maybe Env > posixPatMatchCompiled compiled w = > first (patMatchIntStateCompiled compiled w) > where @@ -287,14 +321,15 @@ > -> Binder > updateBinderByIndex i pos binder = > case IM.lookup i binder of -> { Nothing -> IM.insert i [(pos, pos)] binder +> { Nothing -> IM.insert i [(pos,pos+1)] binder > ; Just ranges -> > case ranges of -> { [] -> IM.update (\_ -> Just [(pos,pos)]) i binder +> { [] -> IM.update (\_ -> Just [(pos,pos+1)]) i binder > ; ((b,e):rs) +> | b == e -> IM.update (\_ -> Just ((pos,pos+1):(b,e):rs)) i binder -- preserve the reset points (i,i) > | pos == b - 1 -> IM.update (\_ -> Just ((b-1,e):rs)) i binder -> | pos < (b - 1) -> IM.update (\_ -> Just ((pos,pos):(b,e):rs)) i binder -> | otherwise -> error "impossible, the current letter position is greater than the last recorded letter" +> | pos < (b - 1) -> IM.update (\_ -> Just ((pos,pos+1):(b,e):rs)) i binder +> | otherwise -> error ("impossible, the current letter position is greater than the last recorded letter" ++ show i ++ show pos ++ show (b,e)) > } > } @@ -319,6 +354,7 @@ > | otherwise = x:(updateBinderByIndexSub pos idx xs) > -} +> {- > resetLocalBnd :: Pat -> Binder -> Binder > resetLocalBnd p b = > let vs = getVars p @@ -328,20 +364,29 @@ > case IM.lookup i b' of > { Nothing -> b' > ; Just [] -> IM.update (\r -> Just r) i b' -> ; Just ((s,e):_) -> IM.update (\r -> Just ((s,(s-1)):r)) i b' +> ; Just ((s,e):_) -> IM.update (\r -> Just ((s, s-1):r)) i b' > }) b is > -> {- -> where aux :: [Int] -> Binder -> Binder -> aux vs [] = [] -> aux vs ((b@(x,r)):bs) | x `elem` vs = -> case r of -> { [] -> (b:(aux vs bs)) -> ; ((s,e):_) -> ((x, (s,(s-1)):r):(aux vs bs)) -> } -> | otherwise = (b:(aux vs bs)) > -} + +> resetLocalBnd :: Pat -> Int -> Binder -> Binder +> resetLocalBnd p j b = +> let vs = getVars p +> x = aux vs b +> io = logger (print j) `seq` logger (print b) `seq` logger (print x) +> in -- io `seq` +> x +> where aux :: [Int] -> Binder -> Binder +> aux is b = foldl (\b' i -> +> case IM.lookup i b' of +> { Nothing -> b' +> ; Just [] -> IM.update (\r -> Just [(j, j)]) i b' +> ; Just ((s,e):ses) -> IM.update (\r -> Just ((j,j):(s,e):ses)) i b' +> }) b is +> + + retrieve all variables appearing in p > getVars :: Pat -> [Int] @@ -356,22 +401,23 @@ An specialized version of pdPat0 specially designed for the Posix match In case of p* we reset in the local binding. -> pdPat0 :: Pat -> Letter -> [(Pat, Int -> Binder -> Binder, Bool )] +> pdPat0 :: Pat -> Letter -> [(Pat, Int -> Binder -> Binder, Bool)] > pdPat0 (PVar x w p) (l,idx) > | IM.null (toBinder p) = -- p is not nested > let pds = partDeriv (strip p) l > in if null pds then [] -> else [ (PVar x [] (PE (resToRE pds)), (\i -> (updateBinderByIndex x i)), True ) ] +> else [ (PVar x [] (PE (resToRE pds)), (\i -> (updateBinderByIndex x i)), True) ] > | otherwise = > let pfs = pdPat0 p (l,idx) -> in [ (PVar x [] pd, (\i -> (f i) . (updateBinderByIndex x i) ), True ) | (pd,f, _) <- pfs ] +> in [ (PVar x [] pd, (\i -> (f i) . (updateBinderByIndex x i) ), True) | (pd,f,_) <- pfs ] > pdPat0 (PE r) (l,idx) = > let pds = partDeriv r l > in if null pds then [] -> else [ (PE (resToRE pds), ( \_ -> id ), True ) ] +> else [ (PE (resToRE pds), ( \_ -> id ), True) ] > pdPat0 (PStar p g) l = let pfs = pdPat0 p l -> reset = resetLocalBnd p -- restart all local binder in variables in p -> in [ (PPair p' (PStar p g), (\ i -> reset . (f i) ), True) | (p', f, _) <- pfs ] +> reset = resetLocalBnd p -- restart all local binder in variables in p +> in [ (PPair p' (PStar p g), (\ i -> (reset i) . (f i) ) , True) | (p', f, _) <- pfs ] +> -- in [ (PPair p' (PStar p g), (\ i -> reset . (f i) ), True) | (p', f, _) <- pfs ] > -- in [ (PPlus p' (PStar p), f) | (p', f) <- pfs ] > {- > pdPat0 (PPlus p1 p2@(PStar _)) l -- we drop this case since it make difference with the PPair @@ -381,20 +427,22 @@ > pdPat0 (PPair p1 p2) l = > if (isEmpty (strip p1)) > then if isGreedy p1 -> then nub3 ([ (PPair p1' p2, f, True) | (p1' , f, _) <- pdPat0 p1 l ] ++ (pdPat0 p2 l)) +> then nub3 ([ (PPair p1' p2, f, True) | (p1' , f, _ ) <- pdPat0 p1 l ] ++ (pdPat0 p2 l)) > else nub3 ((pdPat0 p2 l) ++ [ (PPair p1' p2, f, False) | (p1' , f, _) <- pdPat0 p1 l ]) > else [ (PPair p1' p2, f, True) | (p1',f, _) <- pdPat0 p1 l ] > pdPat0 (PChoice p1 p2 _) l = > nub3 ((pdPat0 p1 l) ++ (pdPat0 p2 l)) -- nub doesn't seem to be essential +> > nub3 :: Eq a => [(a,b,c)] -> [(a,b,c)] -> nub3 = nubBy (\(p1,_,_) (p2, _, _) -> p1 == p2) - +> nub3 = nubBy (\(p1,_,_) (p2,_,_) -> p1 == p2) +> > -- | The PDeriv backend spepcific 'Regex' type - -> type Regex = (PdPat0TableRev, [Int], Binder) +> -- | the IntMap keeps track of the auxillary binder generated because of posix matching, i.e. all sub expressions need to be tag +> -- | the FollowBy keeps track of the order of the pattern binder +> type Regex = (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap ()) -- todo: use the CompOption and ExecOption @@ -404,11 +452,11 @@ > -> S.ByteString -- ^ The regular expression to compile > -> Either String Regex -- ^ Returns: the compiled regular expression > compile compOpt execOpt bs = -> case parsePat (S.unpack bs) of +> case parsePatPosix (S.unpack bs) of > Left err -> Left ("parseRegex for Text.Regex.PDeriv.ByteString failed:"++show err) > Right pat -> Right (patToRegex pat compOpt execOpt) > where -> patToRegex p _ _ = (compilePat p) +> patToRegex p _ _ = compilePat p @@ -422,18 +470,19 @@ > -> Either String (Maybe (S.ByteString, S.ByteString, S.ByteString, [S.ByteString])) > regexec r bs = > case posixPatMatchCompiled r bs of -> Nothing -> Right (Nothing) +> Nothing -> Right Nothing > Just env -> -> let pre = case lookup minBinder env of { Just w -> w ; Nothing -> S.empty } -> post = case lookup maxBinder env of { Just w -> w ; Nothing -> S.empty } +> let pre = case lookup preBinder env of { Just w -> w ; Nothing -> S.empty } +> post = case lookup subBinder env of { Just w -> w ; Nothing -> S.empty } > full_len = S.length bs > pre_len = S.length pre > post_len = S.length post > main_len = full_len - pre_len - post_len > main_and_post = S.drop pre_len bs > main = main_and_post `seq` main_len `seq` S.take main_len main_and_post -> matched = map snd (filter (\(v,w) -> v > 0) env) -> in Right (Just (pre,main,post,matched)) +> matched = map snd (filter (\(v,w) -> v > mainBinder && v < subBinder ) env) +> in -- logger (print (show env)) `seq` +> Right (Just (pre,main,post,matched)) > -- | Control whether the pattern is multiline or case-sensitive like Text.Regex and whether to @@ -490,35 +539,58 @@ -> patMatchIntStateCompiledMatchArray :: (PdPat0TableRev, [Int], Binder) -> Word -> [MatchArray] -> patMatchIntStateCompiledMatchArray (pdStateTable, fins ,b) w = +> patMatchIntStateCompiledMatchArray :: (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap ()) -> Word -> [MatchArray] +> patMatchIntStateCompiledMatchArray (pdStateTable, fins, b, fb, posixBnd) w = > let > l = S.length w > w' = S.reverse w > fs = [ (i, b, i, True) | i <- fins ] > fs' = w' `seq` fs `seq` l `seq` pdStateTable `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTable w' fs) > -- fs'' = fs' `seq` my_sort fs' -> allbinders = fs' `seq` [ b' | (s,b',_, _) <- fs', s == 0 ] -> io = logger (print $ show allbinders) -> in io `seq` allbinders `seq` map (binderToMatchArray l) allbinders +> allbinders = fs' `seq` [ b' | (s,b',_,_) <- fs', s == 0 ] +> io = logger (print $ show b) `seq` logger (print $ show allbinders) +> in -- io `seq` +> allbinders `seq` map (binderToMatchArray l fb posixBnd) allbinders -> binderToMatchArray l b = -> let subPatB = filter (\(x,_) -> x > minBinder && x < maxBinder) (listifyBinder b) -> mbPrefixB = IM.lookup minBinder b -> mbSubfixB = IM.lookup maxBinder b + +> updateEmptyBinder b fb = +> let +> up b (x,y) = case IM.lookup x b of +> { Just (_:_) -> -- non-empty, nothing to do +> b +> ; Just [] -> -- lookup the predecessor +> case IM.lookup y b of +> { Just r@(_:_) -> let i = snd (last r) +> in IM.update (\_ -> Just [(i,i)]) x b +> ; _ -> b } +> ; Nothing -> b } +> in foldl up b fb + +> binderToMatchArray l fb posixBnd b = +> let -- b' = updateEmptyBinder b fb +> subPatB = filter (\(x,_) -> x > mainBinder && x < subBinder && x `IM.notMember` posixBnd ) (listifyBinder b) +> mbPrefixB = IM.lookup preBinder b +> mbSubfixB = IM.lookup subBinder b > mainB = case (mbPrefixB, mbSubfixB) of -> (Just [(_,x)], Just [(y,_)]) -> (x + 1, y - (x + 1)) -> (Just [(_,x)], _) -> (x + 1, l - (x + 1)) +> (Just [(_,x)], Just [(y,_)]) -> (x, y - x) +> (Just [(_,x)], _) -> (x, l - x) > (_, Just [(y,_)]) -> (0, y) > (_, _) -> (0, l) -> _ -> error (show (mbPrefixB, mbSubfixB) ) -> rs = map snd subPatB -> in listToArray (mainB:(map (\r -> case r of { (_:_) -> fromRange (last r) ; [] -> (-1,0) } ) rs)) -> where fromRange (b,e) = (b, e-b+1) +> _ -> error (show (mbPrefixB, mbSubfixB) ) +> rs = map snd subPatB +> rs' = map lastNonEmpty rs +> io = logger (print $ "\n" ++ show rs ++ " || " ++ show rs' ++ "\n") +> in -- io `seq` +> listToArray (mainB:rs') +> where fromRange (b,e) = (b, e-b) +> -- chris' test cases requires us to get the last result even if it is a reset point, +> -- e.g. input:"aaa" pattern:"((..)|(.))*" expected match:"(0,3)(2,3)(-1,-1)(2,3)" note that (..) matches with [(0,2),(2,2)], we return [(2,2)] +> lastNonEmpty [] = (-1,0) +> lastNonEmpty rs = fromRange (last rs) > listToArray l = listArray (0,length l-1) l -> posixPatMatchCompiledMatchArray :: (PdPat0TableRev, [Int], Binder) -> Word -> Maybe MatchArray +> posixPatMatchCompiledMatchArray :: (PdPat0TableRev, [Int], Binder, FollowBy, IM.IntMap () ) -> Word -> Maybe MatchArray > posixPatMatchCompiledMatchArray compiled w = > first (patMatchIntStateCompiledMatchArray compiled w) > where @@ -526,6 +598,28 @@ > first _ = Nothing +> -- | from FollowBy, we recover the right result of the variable that bound (-1,-1) to fit Chris' test case +> + +> type FollowBy = [(Int,Int)] + +> followBy :: Pat -> FollowBy +> followBy p = map (\p -> (snd p, fst p)) (fst $ buildFollowBy p ([],[])) + +> -- | describe the "followedBy" relation between two pattern variable +> buildFollowBy :: Pat -> ([(Int,Int)], [Int]) -> ([(Int,Int)], [Int]) +> buildFollowBy (PVar x w p) (acc, lefts) = let (acc', lefts') = buildFollowBy p (acc,lefts) +> in ([ (l,x) | l <- lefts] ++ acc', [x]) +> buildFollowBy (PE r) x = x +> buildFollowBy (PStar p g) (acc, lefts) = buildFollowBy p (acc,lefts) +> buildFollowBy (PPair p1 p2) (acc, lefts) = let (acc',lefts') = buildFollowBy p1 (acc,lefts) +> in buildFollowBy p2 (acc',lefts') +> buildFollowBy (PChoice p1 p2 _) (acc, lefts) = let (acc1, lefts1) = buildFollowBy p1 (acc,lefts) +> (acc2, lefts2) = buildFollowBy p2 (acc1,lefts) +> in (acc2, lefts1 ++ lefts2) + + + > Right r0 = compile defaultCompOpt defaultExecOpt (S.pack "(ab|a)(bc|c)") > s0 = S.pack "abc" @@ -607,6 +701,51 @@ > Right r64 = compile defaultCompOpt defaultExecOpt (S.pack "^(a*?)(a*)(a*?)$") -> Right up25 = compile defaultCompOpt defaultExecOpt (S.pack "^(.*?)(a|ab|ba)(.*)$") -> Right up26 = compile defaultCompOpt defaultExecOpt (S.pack "(a|ab|ba)") +Right up25 = compile defaultCompOpt defaultExecOpt (S.pack "^(.*?)(a|ab|ba)(.*)$") + +> Right up25 = compile defaultCompOpt defaultExecOpt (S.pack "(a|ab|ba)") > s25 = S.pack "aba" + + +> Right up112 = compile defaultCompOpt defaultExecOpt (S.pack "a+(b|c)*d+") + +Right up112 = compile defaultCompOpt defaultExecOpt (S.pack "^(.*?)(a+(b|c)*d+)(.*)$") + +> s112 = S.pack "aabcdd" + +Right up34 = compile defaultCompOpt defaultExecOpt (S.pack "^((.*?)((Ab|cD)*))(.*)$") + +> Right up34 = compile defaultCompOpt defaultExecOpt (S.pack "(Ab|cD)*") + +> s34 = S.pack "aBcD" + +> Right up17 = compile defaultCompOpt defaultExecOpt (S.pack "a*(a.|aa)") + +> s17 = S.pack "aaaa" + +Right up27 = compile defaultCompOpt defaultExecOpt (S.pack "^(.*?)((ab|abab)(.*))$") + +> Right up27 = compile defaultCompOpt defaultExecOpt (S.pack "ab|abab") + + +> s27 = S.pack "abbabab" + + +> Right up11 = compile defaultCompOpt defaultExecOpt (S.pack ".*(.*)") + +> s11 = S.pack "ab" + +> Right up8' = compile defaultCompOpt defaultExecOpt (S.pack "((..)|(.))*") + +> s8' = S.pack "aaa" + + +> Right up8'' = compile defaultCompOpt defaultExecOpt (S.pack "^((a)|(b))*$") + +> s8'' = S.pack "aba" + + +> Right up0' = compile defaultCompOpt defaultExecOpt (S.pack "(a|ab|c|bcd)*(d*)") + +> s0' = S.pack "ababcd" + diff --git a/Text/Regex/PDeriv/ByteString/RightToLeft.lhs b/Text/Regex/PDeriv/ByteString/RightToLeft.lhs --- a/Text/Regex/PDeriv/ByteString/RightToLeft.lhs +++ b/Text/Regex/PDeriv/ByteString/RightToLeft.lhs @@ -31,7 +31,7 @@ > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Pretty (Pretty(..)) -> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), nub3, minBinder, maxBinder) +> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), nub3, preBinder, mainBinder, subBinder) > import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.PDeriv.Parse > import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub) @@ -246,14 +246,15 @@ > case greedyPatMatchCompiled r bs of > Nothing -> Right Nothing > Just env -> -> let pre = case lookup minBinder env of { Just w -> w ; Nothing -> S.empty } -> post = case lookup maxBinder env of { Just w -> w ; Nothing -> S.empty } -> full_len = S.length bs +> let pre = case lookup preBinder env of { Just w -> w ; Nothing -> S.empty } +> post = case lookup subBinder env of { Just w -> w ; Nothing -> S.empty } +> {- full_len = S.length bs > pre_len = S.length pre > post_len = S.length post > main_len = full_len - pre_len - post_len > main_and_post = S.drop pre_len bs -> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post +> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post -} +> main = case lookup mainBinder env of { Just w -> w ; Nothing -> S.empty } > matched = map snd (filter (\(v,w) -> v > 0) env) > in Right (Just (pre,main,post,matched)) diff --git a/Text/Regex/PDeriv/ByteString/TwoPasses.lhs b/Text/Regex/PDeriv/ByteString/TwoPasses.lhs --- a/Text/Regex/PDeriv/ByteString/TwoPasses.lhs +++ b/Text/Regex/PDeriv/ByteString/TwoPasses.lhs @@ -33,7 +33,7 @@ > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Pretty (Pretty(..)) -> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), nub2, minBinder, maxBinder) +> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), nub2, preBinder, mainBinder, subBinder) > import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.PDeriv.Parse > import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub) @@ -275,14 +275,15 @@ > case greedyPatMatchCompiled r bs of > Nothing -> Right (Nothing) > Just env -> -> let pre = case lookup minBinder env of { Just w -> w ; Nothing -> S.empty } -> post = case lookup maxBinder env of { Just w -> w ; Nothing -> S.empty } -> full_len = S.length bs +> let pre = case lookup preBinder env of { Just w -> w ; Nothing -> S.empty } +> post = case lookup subBinder env of { Just w -> w ; Nothing -> S.empty } +> {- full_len = S.length bs > pre_len = S.length pre > post_len = S.length post > main_len = full_len - pre_len - post_len > main_and_post = S.drop pre_len bs -> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post +> main = main_and_post `seq` main_len `seq` S.take main_len main_and_post -} +> main = case lookup mainBinder env of { Just w -> w ; Nothing -> S.empty } > matched = map snd (filter (\(v,w) -> v > 0) env) > in Right (Just (pre,main,post,matched)) diff --git a/Text/Regex/PDeriv/Common.lhs b/Text/Regex/PDeriv/Common.lhs --- a/Text/Regex/PDeriv/Common.lhs +++ b/Text/Regex/PDeriv/Common.lhs @@ -9,8 +9,10 @@ > , IsGreedy (..) > , nub2 > , nub3 -> , minBinder -> , maxBinder +> , preBinder +> , preBinder_ +> , subBinder +> , mainBinder > ) where > import Data.Char (ord) @@ -126,10 +128,19 @@ The smallest binder index capturing the prefix of the unanchored regex -> minBinder :: Int -> minBinder = 0 +> preBinder :: Int +> preBinder = -1 +> preBinder_ :: Int +> preBinder_ = -2 + The largest binder index capturing for the suffix of the unanchored regex -> maxBinder :: Int -> maxBinder = 2147483647 +> subBinder :: Int +> subBinder = 2147483647 + + +The binder index capturing substring which matches by the unanchored regex + +> mainBinder :: Int +> mainBinder = 0 diff --git a/Text/Regex/PDeriv/IntPattern.lhs b/Text/Regex/PDeriv/IntPattern.lhs --- a/Text/Regex/PDeriv/IntPattern.lhs +++ b/Text/Regex/PDeriv/IntPattern.lhs @@ -174,9 +174,12 @@ > getBindingsFrom p1 p2 = let b = toBinder p2 > in assign p1 b > where assign :: Pat -> Binder -> Pat -> assign (PVar x w p) b = case IM.lookup x b of -> Nothing -> let p' = assign p b in PVar x w p' -> Just rs -> let p' = assign p b in PVar x (w ++ rs) p' +> assign (PVar x w p) b = +> case IM.lookup x b of +> Nothing -> let p' = assign p b in PVar x w p' +> Just rs -> let +> p' = assign p b +> in PVar x (w ++ rs) p' > assign (PE r) _ = PE r > assign (PPlus p1 p2) b = PPlus (assign p1 b) p2 -- we don't need to care about p2 since it is a p* > assign (PPair p1 p2) b = PPair (assign p1 b) (assign p2 b) @@ -207,7 +210,7 @@ > toBinder p = IM.fromList (toBinderList p) > toBinderList :: Pat -> [(Int, [Range])] -> toBinderList (PVar i rs p) = [(i,rs)] ++ (toBinderList p) +> toBinderList (PVar i rs p) = [(i, rs)] ++ (toBinderList p) > toBinderList (PPair p1 p2) = (toBinderList p1) ++ (toBinderList p2) > toBinderList (PPlus p1 p2) = (toBinderList p1) > toBinderList (PStar p1 g) = (toBinderList p1) @@ -229,7 +232,7 @@ > -> Binder > updateBinderByIndex i pos binder = -- binder > IM.update (\ r -> case r of -- we always initialize to [], we don't need to handle the key miss case -> { [] -> Just [(pos,pos)] +> { [] -> Just [(pos,pos)] > ; ((b,e):rs) > | pos == e + 1 -> Just ((b,e+1):rs) > | pos > e + 1 -> Just ((pos,pos):(b,e):rs) diff --git a/Text/Regex/PDeriv/Parse.lhs b/Text/Regex/PDeriv/Parse.lhs --- a/Text/Regex/PDeriv/Parse.lhs +++ b/Text/Regex/PDeriv/Parse.lhs @@ -1,5 +1,5 @@ > {-# LANGUAGE FlexibleContexts #-} -> module Text.Regex.PDeriv.Parse (parsePat) where +> module Text.Regex.PDeriv.Parse (parsePat, parsePatPosix) where > {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009. BSD3 -} @@ -13,12 +13,13 @@ > string, noneOf, digit, char, anyChar) > import Control.Monad(liftM, when, guard) > import Data.List (sort,nub) +> import qualified Data.IntMap as IM > import qualified Data.ByteString.Char8 as S > import Text.Regex.PDeriv.ExtPattern (EPat(..)) > import Text.Regex.PDeriv.IntPattern (Pat(..)) > import Text.Regex.PDeriv.RE (RE(..)) -> import Text.Regex.PDeriv.Translate (translate) +> import Text.Regex.PDeriv.Translate (translate, translatePosix) > type EState = () > initEState = () @@ -36,6 +37,15 @@ > { Left error -> Left error > ; Right (epat, estate) -> Right (translate epat) > } + +posix pattern parsing: we need to add binders everywhere + +> parsePatPosix :: String -> Either ParseError (Pat,IM.IntMap ()) +> parsePatPosix x = case parseEPat x of +> { Left error -> Left error +> ; Right (epat, estate) -> Right (translatePosix epat) +> } + > p_ere :: CharParser EState EPat > p_ere = liftM EOr $ sepBy1 p_branch (char '|') diff --git a/Text/Regex/PDeriv/Translate.lhs b/Text/Regex/PDeriv/Translate.lhs --- a/Text/Regex/PDeriv/Translate.lhs +++ b/Text/Regex/PDeriv/Translate.lhs @@ -1,9 +1,10 @@ > -- | A translation schema from the external syntax (ERE) to our interal syntax (xhaskell style pattern) > module Text.Regex.PDeriv.Translate -> ( translate ) where +> ( translate, translatePosix ) where > import Control.Monad.State -- needed for the translation scheme > import Data.Char (chr) +> import qualified Data.IntMap as IM > import Text.Regex.PDeriv.ExtPattern > import Text.Regex.PDeriv.IntPattern @@ -15,13 +16,20 @@ > data TState = TState { ngi :: NGI -- ^ negative group index > , gi :: GI -- ^ (positive) group index > , anchorStart :: Bool -> , anchorEnd :: Bool } -- the state for trasslation +> , anchorEnd :: Bool +> , posix :: Bool -- ^ if posix, add binders to non-groups +> , posix_binder :: IM.IntMap () -- ^ keep tracks of posix binder +> } -- the state for trasslation > deriving Show > -- variables 0,-1,-2 are reserved for pre, main and post! -> initTState = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False } +> initTState = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False, posix = False, posix_binder = IM.empty } + +> initTStatePosix = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False, posix = True, posix_binder = IM.empty } + + > type NGI = Int -- the non group index > type GI = Int -- the group index @@ -72,7 +80,18 @@ > ; put st{anchorEnd=True} > } +> isPosix :: State TState Bool +> isPosix = do { st <- get +> ; return (posix st) +> } +> addPosixBinder :: Int -> State TState () +> addPosixBinder i = do { st <- get +> ; let bs = posix_binder st +> bs' = IM.insert i () bs +> ; put st{posix_binder=bs'} +> } + > -- | Translating external pattern to internal pattern > translate :: EPat -> Pat > translate epat = case runState (trans epat) initTState of @@ -80,12 +99,31 @@ > let hasAnchorS = anchorStart state > hasAnchorE = anchorEnd state > in case (hasAnchorS, hasAnchorE) of -> (True, True) -> pat -- PVar 0 [] pat -> (True, False) -> PPair pat (PVar maxBinder [] (PE (Star Any NotGreedy))) -> (False, True) -> PPair (PVar minBinder [] (PE (Star Any NotGreedy))) pat -> (False, False) -> PPair (PVar minBinder [] (PE (Star Any NotGreedy))) (PPair pat (PVar maxBinder [] (PE (Star Any NotGreedy)))) -> -- (False, False) -> (PPair (PPair (PVar (-1) [] (PE (Star Any NotGreedy))) pat) (PVar (-2) [] (PE (Star Any Greedy)))) +> (True, True) -> PVar mainBinder [] pat +> (True, False) -> PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE (Star Any NotGreedy))) +> (False, True) -> PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat) +> -- (False, False) -> PPair (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat)) (PVar subBinder [] (PE (Star Any NotGreedy))) +> -- (False, False) -> PPair (PVar preBinder_ [] (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat))) (PVar subBinder [] (PE (Star Any NotGreedy))) +> (False, False) -> (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar preBinder_ [] (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE (Star Any NotGreedy)))))) + +> -- | for posix +> translatePosix :: EPat -> (Pat,IM.IntMap ()) +> translatePosix epat = case runState (trans epat) initTStatePosix of +> (pat, state) -> +> let hasAnchorS = anchorStart state +> hasAnchorE = anchorEnd state +> posixBnd = posix_binder state +> in case (hasAnchorS, hasAnchorE) of +> (True, True) -> (PVar mainBinder [] pat, posixBnd) +> (True, False) -> (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE (Star Any NotGreedy))), posixBnd) +> (False, True) -> (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat), posixBnd) +> -- (False, False) -> PPair (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat)) (PVar subBinder [] (PE (Star Any NotGreedy))) +> -- (False, False) -> PPair (PVar preBinder_ [] (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat))) (PVar subBinder [] (PE (Star Any NotGreedy))) +> (False, False) -> ((PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar preBinder_ [] (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE (Star Any NotGreedy)))))), posixBnd) + + + > {-| 'trans' The top level translation scheme e ~> p > There are two sub rules. > e ~>_p p @@ -94,10 +132,45 @@ > which are fired depending on whether e has Group pattern (...) (i.e. pattern variable) > -} > trans :: EPat -> State TState Pat -> trans epat | hasGroup epat = p_trans epat -> | otherwise = do { r <- r_trans epat +> trans epat = +> do { is_posix <- isPosix -- if it is posix, we need to aggresively "tag" every sub expression with a binder +> ; if is_posix +> then do +> { gi <- getIncGI +> ; ipat <- trans' epat +> ; addPosixBinder gi +> ; return (PVar gi [] ipat) +> } +> else trans' epat +> } +> where trans' :: EPat -> State TState Pat +> trans' epat +> | hasGroup epat = p_trans epat +> | otherwise = do +> { r <- r_trans epat > ; return (PE r) > } + +> {- +> trans :: EPat -> State TState Pat +> trans epat | hasGroup epat = p_trans epat +> | otherwise = +> do +> { is_posix <- isPosix +> ; if is_posix +> then do +> { gi <- getIncGI +> ; r <- r_trans epat +> ; addPosixBinder gi +> ; return (PVar gi [] (PE r)) +> } +> else do +> { r <- r_trans epat +> ; return (PE r) +> } +> } +> -} + > {-| 'p_trans' implementes the rule 'e ~>_p p' diff --git a/regex-pderiv.cabal b/regex-pderiv.cabal --- a/regex-pderiv.cabal +++ b/regex-pderiv.cabal @@ -1,5 +1,5 @@ Name: regex-pderiv -Version: 0.0.8.2 +Version: 0.0.9 License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2010, Kenny Zhuo Ming Lu and Martin Sulzmann