regex-pderiv 0.0.7 → 0.0.8
raw patch · 10 files changed
+825/−128 lines, 10 filesdep +bitsetdep +deepseqdep ~base
Dependencies added: bitset, deepseq
Dependency ranges changed: base
Files
- Text/Regex/PDeriv/ByteString/LeftToRight.lhs +107/−20
- Text/Regex/PDeriv/ByteString/LeftToRightD.lhs +510/−0
- Text/Regex/PDeriv/ByteString/Posix.lhs +44/−13
- Text/Regex/PDeriv/ByteString/RightToLeft.lhs +10/−10
- Text/Regex/PDeriv/ByteString/TwoPasses.lhs +5/−4
- Text/Regex/PDeriv/Common.lhs +60/−42
- Text/Regex/PDeriv/IntPattern.lhs +79/−27
- Text/Regex/PDeriv/RE.lhs +2/−2
- Text/Regex/PDeriv/Translate.lhs +3/−3
- regex-pderiv.cabal +5/−7
Text/Regex/PDeriv/ByteString/LeftToRight.lhs view
@@ -22,17 +22,20 @@ > import Data.List > import Data.Char (ord)-> import GHC.Int+> -- import GHC.Int > import qualified Data.IntMap as IM > import qualified Data.ByteString.Char8 as S+> import Control.DeepSeq +> import System.IO.Unsafe (unsafePerformIO)+ > import Text.Regex.Base(RegexOptions(..)) > 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)-> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip)+> 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) @@ -75,10 +78,10 @@ > let i = mapping dictionary p > jfs = map (\(q,f) -> (mapping dictionary q, f)) qfs > ]-> hash_table = foldl (\ dict (p,x,q) -> +> hash_table = foldl' (\ dict (p,x,q) -> > let k = my_hash p (fst x) > in case IM.lookup k dict of -> Just ps -> error "Found a duplicate key in the PdPat0Table, this should not happend."+> Just ps -> error "Found a duplicate key in the PdPat0Table, this should not happen." > Nothing -> IM.insert k q dict) IM.empty lists > in (hash_table, sfinal) @@ -112,7 +115,7 @@ > new_states = all_sofar_states `seq` D.nub [ s' | (_,_,sfs) <- new_delta, (s',f) <- sfs > , not (s' `D.isIn` dict) ] > acc_delta_next = (acc_delta ++ new_delta)-> (dict',max_id') = new_states `seq` foldl (\(d,id) p -> (D.insertNotOverwrite (D.hash p) (p,id) d, id + 1) ) (dict,max_id) new_states+> (dict',max_id') = new_states `seq` foldl' (\(d,id) p -> (D.insertNotOverwrite (D.hash p) (p,id) d, id + 1) ) (dict,max_id) new_states > in {- dict' `seq` max_id' `seq` -} builder sig all_sofar_states acc_delta_next new_states dict' max_id' @@ -121,29 +124,98 @@ > lookupPdPat0 :: PdPat0Table -> (Int,Binder) -> Letter -> [(Int,Binder)] > lookupPdPat0 hash_table (i,binder) (l,x) = -> case IM.lookup (my_hash i l) hash_table of-> Just pairs -> -> [ (j, op x binder) | (j, op) <- pairs ]-> Nothing -> []+> -- i `seq` +> -- l `seq` +> -- k `seq` +> let k = {-# SCC "hash" #-} (my_hash i l)+> in k `seq`+> hash_table `seq`+> case {-# SCC "lookup" #-} IM.lookup k hash_table of+> { Just pairs -> +> binder `seq` -- x `seq`+> -- {-# SCC "pair" #-} [ binder' `seq` (j, binder' ) | (j, op) <- {-# SCC "pair_pair" #-} pairs, let binder' = {-# SCC "pair_binder" #-} op x binder ]+> {-# SCC "pair" #-} map (\ (j,op) -> let binder' = {-# SCC "pair_binder" #-} op x binder +> in binder' `seq` +> {-# SCC "pair_pair" #-} (j, binder' ) ) pairs +> ; Nothing -> [] +> } ++> lookupPdPat0' :: PdPat0Table -> (Int, [Binder -> Binder]) -> Letter -> [(Int,[Binder -> Binder])]+> lookupPdPat0' hash_table (i,fs) (l,x) = +> -- i `seq` +> -- l `seq` +> -- k `seq` +> let k = {-# SCC "hash" #-} (my_hash i l)+> in k `seq`+> hash_table `seq`+> case {-# SCC "lookup" #-} IM.lookup k hash_table of+> { Just pairs -> +> let io = unsafePerformIO (print (length pairs))+> in+> x `seq` -- io `seq`+> {-# SCC "pair" #-} map (\ (j,op) -> let f = {-# SCC "op_x" #-} op x +> fs' = {-# SCC "fs'" #-} {- f `seq` fs `seq` -} f:fs+> in {- fs' `seq` -} (j, fs')) pairs +> ; Nothing -> [] +> }++ collection function for binder > collectPatMatchFromBinder :: Word -> Binder -> 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) (reverse rs)):(collectPatMatchFromBinder w xs)+> collectPatMatchFromBinder w b = +> collectPatMatchFromBinder_ w (listifyBinder b) +> 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) (reverse rs)):(collectPatMatchFromBinder_ w xs)+> {-+> (x, f w rs):(collectPatMatchFromBinder_ w xs)+> where f w [] = S.empty+> f w (r:_) = rg_collect w r+> -} > patMatchesIntStatePdPat0 :: Int -> PdPat0Table -> Word -> [(Int,Binder)] -> [(Int,Binder)] > patMatchesIntStatePdPat0 cnt pdStateTable w' eps =-> case S.uncons w' of +> case {-# SCC "uncons" #-} S.uncons w' of > Nothing -> eps > Just (l,w) -> > let -> eps' = nub2 [ ep' | ep <- eps, ep' <- lookupPdPat0 pdStateTable ep (l,cnt) ] +> eps_ = -- l `seq` cnt `seq` +> {-# SCC "listcompred" #-} concatMap (\ep -> lookupPdPat0 pdStateTable ep (l,cnt)) eps+> eps' = -- eps_ `seq`+> nub2 eps_ > cnt' = cnt + 1-> in cnt' `seq` pdStateTable `seq` w `seq` eps' `seq` patMatchesIntStatePdPat0 cnt' pdStateTable w eps'+> in cnt' `seq` {- pdStateTable `seq` -} w `seq` +> eps' `seq` +> patMatchesIntStatePdPat0 cnt' pdStateTable w eps' ++> patMatchesIntStatePdPat0' :: Int -> PdPat0Table -> Word -> [(Int,[Binder -> Binder])] -> [(Int,[Binder -> Binder])]+> patMatchesIntStatePdPat0' cnt pdStateTable w' eps =+> case {-# SCC "uncons" #-} S.uncons w' of +> Nothing -> eps +> Just (l,w) -> +> let +> eps_ = l `seq` cnt `seq` +> {-# SCC "listcompred" #-} concatMap (\ep -> lookupPdPat0' pdStateTable ep (l,cnt)) eps+> eps' = -- eps_ `seq`+> nub2 eps_+> cnt' = cnt + 1+> in cnt' `seq` {- pdStateTable `seq` -} w `seq` +> eps' `seq` +> patMatchesIntStatePdPat0' cnt' pdStateTable w eps'++> concatMap' :: (a -> [b]) -> [a] -> [b]+> concatMap' f x = foldr' ( \ b a -> (++) a (f b) ) [] x++> foldr' :: (a -> b -> b) -> b -> [a] -> b+> foldr' f b [] = b+> foldr' f b (a:as) = let b' = f a b +> in b' `seq` +> foldr' f b' as+ > {- > fast_nub :: [(Binder,Int)] -> [(Binder,Int)] > fast_nub eps = @@ -168,7 +240,10 @@ > b = toBinder p > allbinders' = b `seq` s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0 0 pdStateTable w [(s,b)]) > allbinders = allbinders' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) allbinders' )+> -- all_func' = s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0' 0 pdStateTable w [(s,[])])+> -- all_func = all_func' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) all_func' ) > in map (collectPatMatchFromBinder w) $! allbinders+> -- map (\fs -> collectPatMatchFromBinder w (applyAll (reverse fs) b)) $! all_func @@ -193,11 +268,23 @@ > patMatchIntStateCompiled (pdStateTable,sfinal,b) w = > let > s = 0 -> allbinders' = b `seq` s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0 0 pdStateTable w [(s,b)]) -> allbinders = allbinders' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) allbinders' )-> in map (collectPatMatchFromBinder w) allbinders+> -- allbinders' = b `seq` s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0 0 pdStateTable w [(s,b)]) +> -- allbinders = allbinders' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) allbinders' )+> all_func' = s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0' 0 pdStateTable w [(s,[])])+> all_func = all_func' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) all_func' ) +> in -- map (collectPatMatchFromBinder w) allbinders+> all_func `seq` +> map (\fs -> let fs' = reverse fs+> in fs' `seq` collectPatMatchFromBinder w (applyAll fs' b)) all_func +> applyAll :: [ Binder -> Binder ] -> Binder -> Binder+> -- applyAll _ b = b -- fixme+> applyAll [] b = b+> applyAll (f:fs) b = let b' = f b+> in b' `seq` applyAll fs b'+ + > greedyPatMatchCompiled :: (PdPat0Table, [Int], Binder) -> Word -> Maybe Env > greedyPatMatchCompiled compiled w = > first (patMatchIntStateCompiled compiled w)@@ -266,7 +353,7 @@ > function, and the $ anchor matches the null string before any newline in the > string in addition to its normal function." -} > , rightAssoc :: Bool -- ^ True (and therefore Right associative) in blankCompOpt and defaultCompOpt-> , newSyntax :: Bool -- ^ False in blankCompOpt, True in defaultCompOpt. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+> , newSyntax :: Bool -- ^ False in blankCompOpt, True in defaultCompOpt. > , lastStarGreedy :: Bool -- ^ False by default. This is POSIX correct but it takes space and is slower. > -- Setting this to true will improve performance, and should be done > -- if you plan to set the captureGroups execoption to False.@@ -342,7 +429,7 @@ pattern = <(x :: (0|...|9)+?)*, (y :: (0|...|9)+?)*, (z :: (0|...|9)+?)*> -> digits_re = foldl (\x y -> Choice x y Greedy) (L '0') (map L "12345789")+> digits_re = foldl' (\x y -> Choice x y Greedy) (L '0') (map L "12345789") > 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)))
+ Text/Regex/PDeriv/ByteString/LeftToRightD.lhs view
@@ -0,0 +1,510 @@+> {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009, BSD License -}++A bytestring implementation of reg exp pattern matching using partial derivative+This algorithm exploits the extension of partial derivative of regular expression patterns.+This algorithm proceeds by scanning the input word from left to right until we reach +an emptiable pattern and the input word is fully consumed.++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+> FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.PDeriv.ByteString.LeftToRightD+> ( Regex+> , CompOption(..)+> , ExecOption(..)+> , defaultCompOpt+> , defaultExecOpt+> , compile+> , execute+> , regexec+> ) where ++> import Data.List +> import Data.Char (ord)+> -- import GHC.Int+> import qualified Data.IntMap as IM+> import qualified Data.ByteString.Char8 as S+> import Control.DeepSeq++> import System.IO.Unsafe (unsafePerformIO)++> import Text.Regex.Base(RegexOptions(..))+++> 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)+> 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)++++A word is a byte string.++> type Word = S.ByteString+++----------------------------+-- (greedy) pattern matching++> type Env = [(Int,Word)]++> rg_collect :: S.ByteString -> (Int,Int) -> S.ByteString+> rg_collect w (i,j) = S.take (j' - i' + 1) (S.drop i' w)+> where i' = fromIntegral i+> j' = fromIntegral j++++we compile all the possible partial derivative operation into a table+The table maps key to a set of target integer states and their corresponding+binder update functions. ++> type PdPat0Table = IM.IntMap [(Int, Int -> Binder -> Binder)]++A function that builds the above table from the pattern++> buildPdPat0Table :: Pat -> (PdPat0Table, [Int])+> buildPdPat0Table init = +> let sig = map (\x -> (x,0)) (sigmaRE (strip init)) -- the sigma+> init_dict = D.insertNotOverwrite (D.hash init) (init,0) D.empty -- add init into the initial dictionary+> (all, delta, dictionary) = sig `seq` builder sig [] [] [init] init_dict 1 -- all states and delta+> final = all `seq` [ s | s <- all, isEmpty (strip s)] -- the final states+> sfinal = final `seq` dictionary `seq` map (mapping dictionary) final+> lists = [ (i,l,jfs) | +> (p,l, qfs) <- delta, +> let i = mapping dictionary p+> jfs = map (\(q,f) -> (mapping dictionary q, f)) qfs+> ]+> hash_table = foldl' (\ dict (p,x,q) -> +> let k = my_hash p (fst x)+> in case IM.lookup k dict of +> Just ps -> error "Found a duplicate key in the PdPat0Table, this should not happen."+> Nothing -> IM.insert k q dict) IM.empty lists+> in (hash_table, sfinal)+++ ++Some helper functions used in buildPdPat0Table++> mapping :: D.Dictionary (Pat,Int) -> Pat -> Int+> mapping dictionary x = let candidates = D.lookupAll (D.hash x) dictionary+> in candidates `seq` +> case candidates of+> [(_,i)] -> i+> _ -> +> case lookup x candidates of+> (Just i) -> i+> Nothing -> error ("this should not happen. looking up " ++ (pretty x) ++ " from " ++ (show candidates) )++> builder :: [Letter] +> -> [Pat] +> -> [(Pat,Letter, [(Pat, Int -> Binder -> Binder)] )]+> -> [Pat] +> -> D.Dictionary (Pat,Int)+> -> Int +> -> ([Pat], [(Pat, Letter, [(Pat, Int -> Binder -> Binder)])], D.Dictionary (Pat,Int))+> builder sig acc_states acc_delta curr_states dict max_id +> | null curr_states = (acc_states, acc_delta, dict)+> | otherwise = +> let +> all_sofar_states = acc_states ++ curr_states+> new_delta = [ (s, l, sfs) | s <- curr_states, l <- sig, let sfs = pdPat0 s l]+> new_states = all_sofar_states `seq` D.nub [ s' | (_,_,sfs) <- new_delta, (s',f) <- sfs+> , not (s' `D.isIn` dict) ]+> acc_delta_next = (acc_delta ++ new_delta)+> (dict',max_id') = new_states `seq` foldl' (\(d,id) p -> (D.insertNotOverwrite (D.hash p) (p,id) d, id + 1) ) (dict,max_id) new_states+> in {- dict' `seq` max_id' `seq` -} builder sig all_sofar_states acc_delta_next new_states dict' max_id' +++++Optimizaing lookup pdpat table.+build a hash table that map [ Int ] states + label to [ Int ] states where +the resulting [ Int ] is already nubbed and join, hence there is no need to run the pairing and nubbing on the fly.+This would cause some compile time overhead and trading space with time.++Technical problem, how to hash a [ Int ] in Haskell?++> type NFAStates = [ Int ]++> type DPat0Table = IM.IntMap ( Int -- ^ the next DFA state+> , NFAStates -- ^ the next NFA states+> , IM.IntMap [Int -> Binder -> Binder] -- ^ the transition function : position -> current_binders -> next_binders+> ) -- deterministic: one output state and one update function++> buildDPat0Table :: Pat -> (DPat0Table, [Int])+> buildDPat0Table init = +> let sig = map (\x -> (x,0)) (sigmaRE (strip init)) -- the sigma+> -- building the NFA+> init_dict = D.insertNotOverwrite (D.hash init) (init,0) D.empty -- add init into the initial dictionary+> (all, delta, dictionary) = sig `seq` builder sig [] [] [init] init_dict 1 -- all states and delta+> final = all `seq` [ s | s <- all, isEmpty (strip s)] -- the final states+> sfinal = final `seq` dictionary `seq` map (mapping dictionary) final+> lists = dictionary `seq` +> [ (i,l,jfs) | +> (p,l, qfs) <- delta, +> let i = mapping dictionary p+> jfs = map (\(q,f) -> (mapping dictionary q, f)) qfs+> ]+> hash_table = lists `seq` +> foldl' (\ dict (p,x,q) -> +> let k = my_hash p (fst x)+> in case IM.lookup k dict of +> Just ps -> error "Found a duplicate key in the PdPat0Table, this should not happen."+> Nothing -> IM.insert k q dict) IM.empty lists+> -- building the DFA+> init' = [ 0 ]+> init_dict' = init' `seq` D.insert (D.hash init') (init',0) D.empty+> (all', delta', dictionary') = hash_table `seq` init' `seq` init_dict' `seq`+> builder' hash_table sig [] [] [init'] init_dict' 1+> lists' = delta' `seq` dictionary' `seq` +> map (\(c,l,n,f) -> +> let i = c `seq` mapping' dictionary' c+> j = n `seq` mapping' dictionary' n+> in f `seq` i `seq` j `seq` n `seq` l `seq` (i, l, j, n, f)) delta'+> hash_table' = lists' `seq` +> foldl' (\ dict' (i, l, j, n, f) ->+> let k = my_hash i (fst l)+> in case IM.lookup k dict' of+> Just ps -> error "Found a duplicate key."+> Nothing -> IM.insert k (j,n,f) dict') IM.empty lists'+> in hash_table' `seq` sfinal `seq` (hash_table',sfinal)+++> mapping' :: D.Dictionary (NFAStates,Int) -> NFAStates -> Int+> mapping' dictionary x = let candidates = dictionary `seq` D.lookupAll (D.hash x) dictionary+> in candidates `seq` +> case candidates of+> [(_,i)] -> i+> _ -> +> case lookup x candidates of+> (Just i) -> i+> Nothing -> error ("this should not happen. looking up " ++ (show x) ++ " from " ++ (show candidates) )+++> builder' :: PdPat0Table+> -> [ Letter ]+> -> [ NFAStates ] -- all so far+> -> [ ( NFAStates, Letter, NFAStates, IM.IntMap [Int -> Binder -> Binder] ) ] -- delta+> -> [ NFAStates ] -- maybe new states+> -> D.Dictionary (NFAStates, Int) -- mapping dictionary+> -> Int -- max key+> -> ( [ NFAStates ] -- all states+> , [ (NFAStates, Letter, NFAStates, IM.IntMap [Int -> Binder -> Binder] ) ] -- all delta : book keeping: IntMap, mapping input nfa state to op?+> , D.Dictionary (NFAStates, Int) )+> builder' pdStateTable sig acc_states acc_delta [] dict max_id = (acc_states, acc_delta, dict)+> builder' pdStateTable sig acc_states acc_delta curr_states dict max_id =+> let all_sofar_states = acc_states `seq` curr_states `seq` +> acc_states ++ curr_states +> insert k f im = k `seq` im `seq` +> case IM.lookup k im of +> { Just fs -> IM.update (\_ -> Just (fs ++ [ f ])) k im +> ; Nothing -> IM.insert k [f] im+> }+> {-+> new_delta = [ next_state `seq` f_dict `seq` (curr_state, l, next_state, f_dict) |+> curr_state <- curr_states+> , l <- sig+> , let pairs = curr_state `seq` l `seq` nub2 (concatMap ( \n_state -> lookupPdPat1 pdStateTable n_state l ) curr_state) +> , not (null pairs)+> , let (next_state, curr_state_and_f_pairs) = pairs `seq` unzip pairs+> f_dict = curr_state_and_f_pairs `seq` foldl' (\im (l,f) -> insert l f im) IM.empty curr_state_and_f_pairs+> ] +> -}+> new_delta = pdStateTable `seq` curr_states `seq`+> concatMap ( \curr_state -> +> map (\l -> +> let+> pairs = curr_state `seq` l `seq` nub2 (concatMap' ( \n_state -> lookupPdPat1 pdStateTable n_state l ) curr_state) +> (next_state, curr_state_and_f_pairs) = pairs `seq` unzip pairs+> f_dict = curr_state_and_f_pairs `seq` +> foldl' (\im (l,f) -> insert l f im) IM.empty curr_state_and_f_pairs+> in next_state `seq` f_dict `seq` (curr_state, l, next_state, f_dict) ) sig+> ) curr_states+> new_states = new_delta `seq` +> D.nub [ next_state | +> (_,_,next_state,_) <- new_delta+> , not (next_state `D.isIn` dict) ]+> acc_delta_next = acc_delta `seq` new_delta `seq` +> (acc_delta ++ new_delta)+> (dict',max_id') = new_states `seq` dict `seq` max_id `seq` +> foldl' (\(d,id) p -> (D.insert (D.hash p) (p,id) d, id + 1)) (dict,max_id) new_states +> in all_sofar_states `seq` new_states `seq` dict' `seq` max_id'`seq` sig `seq` acc_delta_next `seq`+> builder' pdStateTable sig all_sofar_states acc_delta_next new_states dict' max_id'+++++++the "partial derivative" operations among integer states + binders+++> lookupPdPat1 :: PdPat0Table -> Int -> Letter -> [ ( Int -- next state+> , ( Int -- current state : used as key to build the hash table+> , Int -> Binder -> Binder)) ]+> lookupPdPat1 hash_table i (l,_) = +> let k = my_hash i l+> in +> k `seq` +> case IM.lookup k hash_table of +> { Just pairs -> +> map (\ (j,op) -> +> (j, (i, op))) pairs +> ; Nothing -> [] +> }++collection function for binder ++> collectPatMatchFromBinder :: Word -> Binder -> Env+> collectPatMatchFromBinder w b = +> collectPatMatchFromBinder_ w (listifyBinder b)++> 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) (reverse rs)):(collectPatMatchFromBinder_ w xs)+> {-+> (x, f w rs):(collectPatMatchFromBinder_ w xs)+> where f w [] = S.empty+> f w (r:_) = rg_collect w r+> -}+++orginally the type was Int -> DPat0Table -> Word -> (Int,[(Int,Binder)]) -> (Int, [(Int,Binder)])+where the first Int is the DFA state, but this leads to a mysterious Stack overflow fiasco, (which I don't have time to investigate why+or able to come out a smallish example)++> patMatchesIntStatePdPat1 :: Int -> DPat0Table -> Word -> [(Int,Int,Binder)] -> [(Int,Int,Binder)]+> patMatchesIntStatePdPat1 cnt dStateTable w' [] = []+> patMatchesIntStatePdPat1 cnt dStateTable w' currNfaStateBinders =+> case {-# SCC "uncons" #-} S.uncons w' of +> Nothing -> currNfaStateBinders+> Just (l,w) -> +> let ((i,_,_):_) = currNfaStateBinders+> k = {-# SCC "k" #-} l `seq` i `seq` my_hash i l+> in+> case k `seq` IM.lookup k dStateTable of+> { Nothing -> [] -- key miss means some letter exists in w but not in r. +> ; Just (j,next_nfaStates,fDict) -> +> let -- +> binders = {-# SCC "binders" #-} -- io `seq`+> currNfaStateBinders `seq` fDict `seq` +> concatMap' ( \ (_,m,b) -> case IM.lookup m fDict of +> Nothing -> []+> Just fs -> b `seq` map (\f -> f cnt b) fs ) currNfaStateBinders +> nextNfaStateBinders = {-# SCC "nextNfaStateBinders" #-} -- io `seq` +> binders `seq` next_nfaStates `seq` j `seq`+> map (\(x,y) -> (j,x,y)) (zip next_nfaStates binders)+> cnt' = {-# SCC "cnt" #-} cnt + 1+> in nextNfaStateBinders `seq` cnt' `seq` w `seq`+> patMatchesIntStatePdPat1 cnt' dStateTable w nextNfaStateBinders } ++> concatMap' :: (a -> [b]) -> [a] -> [b]+> concatMap' f x = foldr' ( \ b a -> (++) a $! (f b) ) [] x++> foldr' :: (a -> b -> b) -> b -> [a] -> b+> foldr' f b [] = b+> foldr' f b (a:as) = let b' = f a b +> in b' `seq` +> foldr' f b' as++++> patMatchIntStatePdPat1 :: Pat -> Word -> [Env]+> patMatchIntStatePdPat1 p w = +> let+> (dStateTable,sfinal) = buildDPat0Table p+> s = 0+> b = toBinder p+> allbinders' = b `seq` s `seq` dStateTable `seq` (patMatchesIntStatePdPat1 0 dStateTable w [(0,s,b)])+> -- allbinders' = b `seq` s `seq` dStateTable `seq` (patMatchesIntStatePdPat1 0 dStateTable w [(s,b)]) +> allbinders = allbinders' `seq` map third (filter (\(_,i,_) -> i `elem` sfinal) allbinders' )+> -- all_func' = s `seq` pdStateTable `seq` (patMatchesIntStatePdPat0' 0 pdStateTable w [(s,[])])+> -- all_func = all_func' `seq` map snd (filter (\(i,_) -> i `elem` sfinal) all_func' ) +> in map (collectPatMatchFromBinder w) $! allbinders+> -- map (\fs -> collectPatMatchFromBinder w (applyAll (reverse fs) b)) $! all_func +++> greedyPatMatch' :: Pat -> Word -> Maybe Env+> greedyPatMatch' p w =+> first (patMatchIntStatePdPat1 p w)+> where+> first (env:_) = return env+> first _ = Nothing+++Compilation+++> compilePat :: Pat -> (DPat0Table, [Int], Binder)+> compilePat p = (dStateTable, sfinal, b)+> where +> (dStateTable,sfinal) = buildDPat0Table p+> b = toBinder p++> patMatchIntStateCompiled :: (DPat0Table, [Int], Binder) -> Word -> [Env]+> patMatchIntStateCompiled (dStateTable,sfinal,b) w = +> let+> s = 0 +> e = [(0,0,b)]+> allbinders' = e `seq` b `seq` s `seq` dStateTable `seq` (patMatchesIntStatePdPat1 0 dStateTable w e ) +> -- allbinders' = b `seq` s `seq` dStateTable `seq` (patMatchesIntStatePdPat1 0 dStateTable w [(s,b)])+> allbinders = allbinders' `seq` map third (filter (\(_,i,_) -> i `elem` sfinal) allbinders' )+> in allbinders `seq` map (collectPatMatchFromBinder w) allbinders++> third :: (a,b,c) -> c+> third (_,_,x) = x++> greedyPatMatchCompiled :: (DPat0Table, [Int], Binder) -> Word -> Maybe Env+> greedyPatMatchCompiled compiled w =+> first (patMatchIntStateCompiled compiled w)+> where+> first (env:_) = return env+> first _ = Nothing++++++> -- | The PDeriv backend spepcific 'Regex' type++> newtype Regex = Regex (DPat0Table, [Int], Binder) +++-- todo: use the CompOption and ExecOption++> compile :: CompOption -- ^ Flags (summed together)+> -> ExecOption -- ^ Flags (summed together) +> -> 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+> Left err -> Left ("parseRegex for Text.Regex.PDeriv.ByteString failed:"++show err)+> Right pat -> Right (patToRegex pat compOpt execOpt)+> where +> patToRegex p _ _ = Regex (compilePat p)++++> execute :: Regex -- ^ Compiled regular expression+> -> S.ByteString -- ^ ByteString to match against+> -> Either String (Maybe Env)+> execute (Regex r) bs = Right (greedyPatMatchCompiled r bs)++> regexec :: Regex -- ^ Compiled regular expression+> -> S.ByteString -- ^ ByteString to match against+> -> Either String (Maybe (S.ByteString, S.ByteString, S.ByteString, [S.ByteString]))+> regexec (Regex r) bs =+> case greedyPatMatchCompiled r bs of+> Nothing -> Right (Nothing)+> Just env ->+> let pre = case lookup (-1) env of { Just w -> w ; Nothing -> S.empty }+> post = case lookup (-2) 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))+++> -- | Control whether the pattern is multiline or case-sensitive like Text.Regex and whether to+> -- capture the subgroups (\1, \2, etc). Controls enabling extra anchor syntax.+> data CompOption = CompOption {+> caseSensitive :: Bool -- ^ True in blankCompOpt and defaultCompOpt+> , multiline :: Bool +> {- ^ False in blankCompOpt, True in defaultCompOpt. Compile for+> newline-sensitive matching. "By default, newline is a completely ordinary+> character with no special meaning in either REs or strings. With this flag,+> inverted bracket expressions and . never match newline, a ^ anchor matches the+> null string after any newline in the string in addition to its normal+> function, and the $ anchor matches the null string before any newline in the+> string in addition to its normal function." -}+> , rightAssoc :: Bool -- ^ True (and therefore Right associative) in blankCompOpt and defaultCompOpt+> , newSyntax :: Bool -- ^ False in blankCompOpt, True in defaultCompOpt. +> , lastStarGreedy :: Bool -- ^ False by default. This is POSIX correct but it takes space and is slower.+> -- Setting this to true will improve performance, and should be done+> -- if you plan to set the captureGroups execoption to False.+> } deriving (Read,Show)++> data ExecOption = ExecOption {+> captureGroups :: Bool -- ^ True by default. Set to False to improve speed (and space).+> } deriving (Read,Show)++> instance RegexOptions Regex CompOption ExecOption where+> blankCompOpt = CompOption { caseSensitive = True+> , multiline = False+> , rightAssoc = True+> , newSyntax = False+> , lastStarGreedy = False+> }+> blankExecOpt = ExecOption { captureGroups = True }+> defaultCompOpt = CompOption { caseSensitive = True+> , multiline = True+> , rightAssoc = True+> , newSyntax = True+> , lastStarGreedy = False+> }+> defaultExecOpt = ExecOption { captureGroups = True }+> setExecOpts e r = undefined+> getExecOpts r = undefined +++-- Kenny's example++> long_pat = PPair (PVar 1 [] (PE (Star (L 'A') Greedy))) (PVar 2 [] (PE (Star (L 'A') Greedy)))+> long_string n = S.pack $ (take 0 (repeat 'A')) ++ (take n (repeat 'B'))++-- p4 = << x : (A|<A,B>), y : (<B,<A,A>>|A) >, z : (<A,C>|C) > ++> p4 = PPair (PPair p_x p_y) p_z+> where p_x = PVar 1 [] (PE (Choice (L 'A') (Seq (L 'A') (L 'B')) Greedy)) +> p_y = PVar 2 [] (PE (Choice (Seq (L 'B') (Seq (L 'A') (L 'A'))) (L 'A') Greedy))+> p_z = PVar 3 [] (PE (Choice (Seq (L 'A') (L 'C')) (L 'C') Greedy))++> input = S.pack "ABAAC" -- long(posix) vs greedy match+++> p5 = PStar (PVar 1 [] (PE (Choice (L 'A') (Choice (L 'B') (L 'C') Greedy) Greedy))) Greedy++pattern = ( x :: (A|C), y :: (B|()) )*++> p6 = PStar (PPair (PVar 1 [] (PE (Choice (L 'A') (L 'C') Greedy))) (PVar 2 [] (PE (Choice (L 'B') Empty Greedy)))) Greedy++pattern = ( x :: ( y :: A, z :: B )* )++> p7 = PVar 1 [] (PStar (PPair (PVar 2 [] (PE (L 'A'))) (PVar 3 [] (PE (L 'B')))) Greedy)++> input7 = S.pack "ABABAB"+++pattern = ( x :: A*?, y :: A*)++> p8 = PPair (PVar 1 [] (PE (Star (L 'A') NotGreedy))) (PVar 2 [] (PE (Star (L 'A') Greedy)))++> input8 = S.pack "AAAAAA"++pattern = ( x :: A*?, y :: A*)++> p9 = PPair (PStar (PVar 1 [] (PE (L 'A'))) NotGreedy) (PVar 2 [] (PE (Star (L 'A') Greedy)))++pattern = ( x :: (A|B)*?, (y :: (B*,A*)))++> p10 = PPair (PVar 1 [] (PE (Star (Choice (L 'A') (L 'B') Greedy) NotGreedy))) (PVar 2 [] (PE (Seq (Star (L 'B') Greedy) (Star (L 'A') Greedy))))++> input10 = S.pack "ABA"+++pattern = <(x :: (0|...|9)+?)*, (y :: (0|...|9)+?)*, (z :: (0|...|9)+?)*>++> digits_re = foldl' (\x y -> Choice x y Greedy) (L '0') (map L "123456789")++> 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-"
Text/Regex/PDeriv/ByteString/Posix.lhs view
@@ -37,7 +37,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)-> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, toBinder, Binder(..), strip)+> 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) @@ -132,10 +132,13 @@ > -- | Function 'collectPatMatchFromBinder' collects match results from binder > collectPatMatchFromBinder :: Word -> Binder -> 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 b = collectPatMatchFromBinder_ w (listifyBinder b) ++> 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)+ > -- | algorithm right to left scanning single pass > -- | the "partial derivative" operations among integer states + binders > lookupPdPat0' :: PdPat0TableRev -> (Int,Binder) -> Letter -> [(Int,Binder,Int,Bool)]@@ -182,8 +185,8 @@ > compareBinderLocal :: Binder -> Binder -> Ordering > compareBinderLocal bs bs' = -> let rs = map snd bs-> rs' = map snd bs'+> let rs = map snd (listifyBinder bs)+> rs' = map snd (listifyBinder bs') > os = map (\ (r,r') -> compareRangeLocal r r') (zip rs rs') > in {- logger (print (show os)) `seq` > logger (print (show bs)) `seq` @@ -278,13 +281,31 @@ a function that updates the binder given an index (that is the pattern var) ASSUMPTION: the var index in the pattern is linear. e.g. no ( 0 :: R1, (1 :: R2, 2 :: R3)) +> updateBinderByIndex :: Int +> -> Int +> -> Binder +> -> Binder+> updateBinderByIndex i pos binder = +> case IM.lookup i binder of+> { Nothing -> IM.insert i [(pos, pos)] binder+> ; Just ranges -> +> case ranges of +> { [] -> IM.update (\_ -> Just [(pos,pos)]) i binder+> ; ((b,e):rs) +> | 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"+> }+> }++> {- > updateBinderByIndex :: Int -- ^ pattern variable index > -> Int -- ^ letter position > -> Binder -> Binder-> updateBinderByIndex i lpos binder =+> updateBinderByIndex i lpos binder = > updateBinderByIndexSub lpos i binder > -> updateBinderByIndexSub :: Int -> Int -> Binder -> Binder+> -- updateBinderByIndexSub :: Int -> Int -> Binder -> Binder > updateBinderByIndexSub pos idx [] = [] > updateBinderByIndexSub pos idx (x@(idx',(b,e):rs):xs) > | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined@@ -296,12 +317,21 @@ > | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined > | idx == idx' = ((idx', [(pos, pos)]):xs) > | otherwise = x:(updateBinderByIndexSub pos idx xs)-+> -} > resetLocalBnd :: Pat -> Binder -> Binder > resetLocalBnd p b = > let vs = getVars p > in aux vs b +> where aux :: [Int] -> Binder -> Binder+> aux is b = foldl (\b' i -> +> 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'+> }) b is+> +> {- > where aux :: [Int] -> Binder -> Binder > aux vs [] = [] > aux vs ((b@(x,r)):bs) | x `elem` vs = @@ -310,6 +340,7 @@ > ; ((s,e):_) -> ((x, (s,(s-1)):r):(aux vs bs)) > } > | otherwise = (b:(aux vs bs))+> -} retrieve all variables appearing in p @@ -327,7 +358,7 @@ > pdPat0 :: Pat -> Letter -> [(Pat, Int -> Binder -> Binder, Bool )] > pdPat0 (PVar x w p) (l,idx) -> | null (toBinder p) = -- p is not nested+> | 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 ) ]@@ -472,9 +503,9 @@ > in io `seq` allbinders `seq` map (binderToMatchArray l) allbinders > binderToMatchArray l b = -> let subPatB = filter (\(x,_) -> x > 0) b-> mbPrefixB = lookup (-1) b-> mbSubfixB = lookup (-2) b+> let subPatB = filter (\(x,_) -> x > 0) (listifyBinder b)+> mbPrefixB = IM.lookup (-1) b+> mbSubfixB = IM.lookup (-2) b > mainB = case (mbPrefixB, mbSubfixB) of > (Just [(_,x)], Just [(y,_)]) -> (x + 1, y - (x + 1)) > (Just [(_,x)], _) -> (x + 1, l - (x + 1))
Text/Regex/PDeriv/ByteString/RightToLeft.lhs view
@@ -32,7 +32,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) -> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip)+> 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) @@ -131,28 +131,28 @@ > -- | Function 'collectPatMatchFromBinder' collects match results from binder > collectPatMatchFromBinder :: Word -> Binder -> 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) (reverse rs)):(collectPatMatchFromBinder w xs)+> collectPatMatchFromBinder w b = collectPatMatchFromBinder_ w (listifyBinder b)+> 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) (reverse rs)):(collectPatMatchFromBinder_ w xs) > -- | algorithm right to left scanning single pass > -- | the "partial derivative" operations among integer states + binders > lookupPdPat0' :: PdPat0TableRev -> Int -> Letter -> [(Int,Int -> Binder -> Binder,Int)] > lookupPdPat0' hash_table i (l,x) = -> case IM.lookup (my_hash i l) hash_table of+> case {-# SCC "lookup" #-} IM.lookup k hash_table of > Just pairs -> pairs > Nothing -> []- -> myuncons = S.uncons+> where k = my_hash i l > patMatchesIntStatePdPat0Rev :: Int -> PdPat0TableRev -> Word -> [(Int, Binder -> Binder, Int)] -> [(Int, Binder -> Binder, Int )] > patMatchesIntStatePdPat0Rev cnt pdStateTableRev w fs =-> case myuncons w of +> case {-# SCC "myuncons" #-} S.uncons w of > Nothing -> fs > Just (l,w') -> > let -> fs' = nub3 [ (j, f . (f' cnt), pri) | (i, f, _) <- fs, (j, f', pri) <- lookupPdPat0' pdStateTableRev i (l,cnt) ]-> cnt' = cnt - 1+> fs' = nub3 [ g `seq` (j, g, pri) | (i, f, _) <- fs, (j, f', pri) <- lookupPdPat0' pdStateTableRev i (l,cnt), let g = f . (f' cnt) ]+> cnt' = {-# SCC "cnt_minus_one" #-} cnt - 1 > in fs' `seq` cnt' `seq` patMatchesIntStatePdPat0Rev cnt' pdStateTableRev w' fs'
Text/Regex/PDeriv/ByteString/TwoPasses.lhs view
@@ -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(..), IsGreedy(..), nub2)-> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip)+> 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) @@ -177,9 +177,10 @@ > -- | function 'collectPatMatchFromBinder' collects match results from binders > collectPatMatchFromBinder :: Word -> Binder -> 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) (reverse rs)):(collectPatMatchFromBinder w xs)+> collectPatMatchFromBinder w b = collectPatMatchFromBinder_ w (listifyBinder b)+> 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) (reverse rs)):(collectPatMatchFromBinder_ w xs) > -- | 'patMAtchIntStatePdPat0' implements the two passes pattern matching algo
Text/Regex/PDeriv/Common.lhs view
@@ -1,8 +1,19 @@ > -- | this module contains the defs of common data types and type classes-> module Text.Regex.PDeriv.Common where+> module Text.Regex.PDeriv.Common +> ( Range+> , Letter+> , IsEmpty (..)+> , my_hash+> , my_lookup+> , GFlag (..)+> , IsGreedy (..)+> , nub2+> , nub3+> ) where > import Data.Char (ord) > import qualified Data.IntMap as IM+> import qualified Data.BitSet as BS > import Data.List (nubBy) > -- | (sub)words represent by range@@ -38,70 +49,77 @@ > isGreedy :: a -> Bool -> -- | remove duplications in a list of pairs whose, using the first components as key.+> -- | remove duplications in a list of pairs, using the first components as key. > nub2 :: [(Int,a)] -> [(Int,a)] > nub2 [] = [] > nub2 [x] = [x] -- optimization-> nub2 ls@[x,y] = nubBy (\ (x,_) (y,_) -> x == y) ls -- optimization+> -- nub2 ls@[x,y] = nubBy (\ (x,_) (y,_) -> x == y) ls -- optimization > nub2 ls = nub2sub IM.empty ls+> -- nub2aux BS.empty ls []++ > nub2sub im [] = [] > nub2sub im (x@(k,_):xs) = -> case IM.lookup k im of-> Just _ -> nub2sub im xs-> Nothing -> let im' = IM.insert k () im -> in x:(nub2sub im' xs)+> -- im `seq` k `seq` +> case IM.lookup k im of+> Just _ -> xs `seq` nub2sub im xs+> Nothing -> let im' = IM.insert k () im +> in im' `seq` xs `seq` x:(nub2sub im' xs) +> {-+> nub2sub im [] = []+> nub2sub im (x@(k,_):xs) = +> -- im `seq` k `seq` +> if not (IM.notMember k im)+> then xs `seq` nub2sub im xs+> else let im' = IM.insert k () im +> in im' `seq` xs `seq` x:(nub2sub im' xs)+> -} +> nub2aux bs [] acc = reverse acc +> nub2aux bs (x@(k,_):xs) acc = +> case bs `seq` k `seq` BS.member k bs of +> True -> xs `seq` nub2aux bs xs acc+> False -> let bs' = BS.insert k bs+> in bs' `seq` xs `seq` (nub2aux bs' xs (x:acc))++ > nub3 :: [(Int,a,Int)] -> [(Int,a,Int)] > nub3 [] = [] > nub3 [x] = [x] -- optimization-> nub3 ls = -> let (_,ls') = nub3sub IM.empty ls-> in ls'+> nub3 ls = nub3subsimple IM.empty ls + let (_,ls') = nub3sub IM.empty ls+ in ls'++> nub3subsimple :: IM.IntMap () -> [(Int,a,Int)] -> [(Int,a,Int)]+> nub3subsimple im [] = []+> nub3subsimple im [ x ] = [ x ]+> nub3subsimple im (x@(k,f,0):xs) = x:(nub3subsimple im xs)+> nub3subsimple im (x@(k,f,1):xs) = let im' = IM.insert k () im+> in x:(nub3subsimple im' xs)+> nub3subsimple im (x@(k,f,n):xs) = case IM.lookup k im of +> Just _ -> nub3subsimple im xs+> Nothing -> let im' = IM.insert k () im+> in im' `seq` xs `seq` x:(nub3subsimple im' xs)++> nub3sub :: IM.IntMap () -> [(Int,a,Int)] -> (IM.IntMap (), [(Int,a,Int)])+> {-# INLINE nub3sub #-} > nub3sub im [] = (im,[])+> nub3sub im [(k,f,0)] = (im, [(k,f,0)]) -- 0 means deterministic+> nub3sub im [(k,f,1)] = let im' = IM.insert k () im -- 1 means greedy+> in (im', [(k,f,1)]) > nub3sub im (x@(k,f,0):xs) = let (im',xs') = nub3sub im xs > in (im',x:xs') > nub3sub im (x@(k,f,1):xs) = let im' = IM.insert k () im > (im'', xs') = nub3sub im' xs > in (im'', x:xs') > nub3sub im (x@(k,f,n):xs) = case IM.lookup k im of -> Just _ -> let (im', xs') = nub3sub im xs-> in (im', xs')+> Just _ -> nub3sub im xs > Nothing -> let (im', xs') = nub3sub im xs > in case IM.lookup k im' of > Just _ -> (im', xs') > Nothing -> (im', x:xs')--> {--> nub3sub im [] = ([],im)-> nub3sub im (x@(k,f,i):xs) = -> case IM.lookup k im of-> Nothing -> let im' = IM.insert k (f,i) im -- we have not seen this key before, insert it into the table-> (ks,im'') = nub3sub im' xs-> in (k:ks, im'')-> Just (g,j) | j <= i -> nub3sub im xs -- we found a duplicate, let's compare the labels.-> | otherwise -> -> let im' = IM.update (\y -> Just (f,i)) k im-> in nub3sub im' xs-> -} -> {--> -- | remove duplications in a list of tripple, using the first components as key.-> -- nub3 = nubBy (\ (x,_,_) (y,_,_) -> x == y)-> nub3 :: [(Int,a,b)] -> [(Int,a,b)]-> nub3 [] = []-> nub3 [x] = [x] -- optimization-> nub3 ls@[x,y] = nubBy (\ (x,_,_) (y,_,_) -> x == y) ls -- optimization-> nub3 ls = nub3sub IM.empty ls-> nub3sub im [] = []-> nub3sub im (x@(k,_,_):xs) = -> case IM.lookup k im of-> Just _ -> nub3sub im xs-> Nothing -> let im' = IM.insert k () im -> in x:(nub3sub im' xs)-> -}--
Text/Regex/PDeriv/IntPattern.lhs view
@@ -1,9 +1,20 @@ > -- | This module defines the data type of internal regular expression pattern, > -- | as well as the partial derivative operations for regular expression patterns.-> module Text.Regex.PDeriv.IntPattern where+> module Text.Regex.PDeriv.IntPattern +> ( Pat(..)+> , strip+> , pdPat+> , Binder+> , toBinder+> , listifyBinder+> -- , updateBinderByIndex+> , pdPat0+> , nub2+> )+> where > import Data.List-+> import qualified Data.IntMap as IM > import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), GFlag(..), IsGreedy(..) ) > import Text.Regex.PDeriv.RE > import Text.Regex.PDeriv.Dictionary (Key(..), primeL, primeR)@@ -163,7 +174,7 @@ > getBindingsFrom p1 p2 = let b = toBinder p2 > in assign p1 b > where assign :: Pat -> Binder -> Pat-> assign (PVar x w p) b = case lookup x b of+> 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@@ -187,43 +198,83 @@ > -- | The 'Binder' type denotes a set of (pattern var * range) pairs-> type Binder = [(Int, [Range])]+> -- type Binder = [(Int, [Range])]+> type Binder = IM.IntMap [Range] > -- | Function 'toBinder' turns a pattern into a binder > toBinder :: Pat -> Binder-> toBinder (PVar i rs p) = [(i,rs)] ++ (toBinder p)-> toBinder (PPair p1 p2) = (toBinder p1) ++ (toBinder p2)-> toBinder (PPlus p1 p2) = (toBinder p1) -> toBinder (PStar p1 g) = (toBinder p1) -> toBinder (PE r) = []-> toBinder (PChoice p1 p2 g) = (toBinder p1) ++ (toBinder p2)-> toBinder (PEmpty p) = toBinder p+> toBinder p = IM.fromList (toBinderList p) +> toBinderList :: Pat -> [(Int, [Range])]+> 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) +> toBinderList (PE r) = []+> toBinderList (PChoice p1 p2 g) = (toBinderList p1) ++ (toBinderList p2)+> toBinderList (PEmpty p) = toBinderList p +> listifyBinder :: Binder -> [(Int, [Range])]+> listifyBinder b = sortBy (\ x y -> compare (fst x) (fst y)) (IM.toList b)+> > {-| Function 'updateBinderByIndex' updates a binder given an index to a pattern var > ASSUMPTION: the var index in the pattern is linear. e.g. no ( 0 :: R1, (1 :: R2, 2 :a: R3)) > -}++> updateBinderByIndex :: Int +> -> Int +> -> Binder +> -> 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)]+> ; ((b,e):rs)+> | pos == e + 1 -> Just ((b,e+1):rs)+> | pos > e + 1 -> Just ((pos,pos):(b,e):rs)+> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter" +> } ) i binder +> {-+> updateBinderByIndex i pos binder = +> case IM.lookup i binder of+> { Nothing -> IM.insert i [(pos, pos)] binder+> ; Just ranges -> +> case ranges of +> { [] -> IM.update (\_ -> Just [(pos,pos)]) i binder+> ; ((b,e):rs)+> | pos == e + 1 -> IM.update (\_ -> Just ((b,e+1):rs)) i binder +> | pos > e + 1 -> IM.update (\_ -> Just ((pos,pos):(b,e):rs)) i binder+> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter" +> }+> }+> -}+> {-+> {-# INLINE updateBinderByIndex #-} > updateBinderByIndex :: Int -- ^ the indext of the pattern variable > -> Int -- ^ the letter position > -> Binder -> Binder > updateBinderByIndex i lpos binder =-> updateBinderByIndexSub lpos i binder +> updateBinderByIndexSub i lpos binder > +> {-# INLINE updateBinderByIndexSub #-} > updateBinderByIndexSub :: Int -> Int -> Binder -> Binder-> updateBinderByIndexSub pos idx [] = []-> updateBinderByIndexSub pos idx (x@(idx',(b,e):rs):xs)-> | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined-> | idx == idx' && pos == (e + 1) = (idx', (b, e+ 1):rs):xs-> | idx == idx' && pos > (e + 1) = (idx', (pos,pos):(b, e):rs):xs-> | idx == idx' && pos < (e + 1) = error "impossible, the current letter position is smaller than the last recorded letter"-> | otherwise = x:(updateBinderByIndexSub pos idx xs)-> updateBinderByIndexSub pos idx (x@(idx',[]):xs)-> | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined+> updateBinderByIndexSub idx pos [] = []+> updateBinderByIndexSub idx pos (x@(idx',(b,e):rs):xs)+> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined+> | idx == idx' = if pos == (e + 1)+> then (idx', (b, e+ 1):rs):xs+> else if pos > (e + 1) +> then (idx', (pos,pos):(b, e):rs):xs+> else error "impossible, the current letter position is smaller than the last recorded letter"+> | otherwise = -- idx `seq` pos `seq` xs `seq` +> x:(updateBinderByIndexSub idx pos xs)+> updateBinderByIndexSub idx pos (x@(idx',[]):xs)+> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined > | idx == idx' = ((idx', [(pos, pos)]):xs)-> | otherwise = x:(updateBinderByIndexSub pos idx xs)-+> | otherwise = -- idx `seq` pos `seq` xs `seq` +> x:(updateBinderByIndexSub idx pos xs)+> -} > {-| Function 'pdPat0' is the 'abstracted' form of the 'pdPat' function > It computes a set of pairs. Each pair consists a 'shape' of the partial derivative, and@@ -233,13 +284,14 @@ > -> Letter -- ^ the letter to be "consumed" > -> [(Pat, Int -> Binder -> Binder)] > pdPat0 (PVar x w p) (l,idx) -> | null (toBinder p) = -- p is not nested+> | IM.null (toBinder p) = -- p is not nested > let pds = partDeriv (strip p) l-> in pds `seq` if null pds then []-> else [ (PVar x [] (PE (resToRE pds)), (\i -> (updateBinderByIndex x i))) ]+> in g `seq` pds `seq` if null pds then []+> else [ (PVar x [] (PE (resToRE pds)), g) ] > | otherwise = > let pfs = pdPat0 p (l,idx)-> in pfs `seq` [ (PVar x [] pd, (\i -> (updateBinderByIndex x i) . (f i) ) ) | (pd,f) <- pfs ]+> in g `seq` pfs `seq` [ (PVar x [] pd, (\i -> (g i) . (f i) )) | (pd,f) <- pfs ]+> where g = updateBinderByIndex x > pdPat0 (PE r) (l,idx) = > let pds = partDeriv r l > in pds `seq` if null pds then []
Text/Regex/PDeriv/RE.lhs view
@@ -138,8 +138,8 @@ > in s `seq` nub s > sigmaREsub (L l) = [l]-> sigmaREsub Any = map chr [0 .. 255]-> sigmaREsub (Not cs) = filter (\c -> not (c `elem` cs)) (map chr [0 .. 255])+> sigmaREsub Any = map chr [32 .. 127]+> sigmaREsub (Not cs) = filter (\c -> not (c `elem` cs)) (map chr [32 .. 127]) > sigmaREsub (Seq r1 r2) = (sigmaREsub r1) ++ (sigmaREsub r2) > sigmaREsub (Choice r1 r2 g) = (sigmaREsub r1) ++ (sigmaREsub r2) > sigmaREsub (Star r g) = sigmaREsub r
Text/Regex/PDeriv/Translate.lhs view
@@ -268,7 +268,7 @@ > -- . ~> a :: \Sigma > -- we might not need this rule > do { i <- getIncNGI-> ; let r = anychar+> ; let r = Any > p = PVar i [] (PE r) > ; return p > }@@ -276,8 +276,8 @@ > -- [ abc ] ~> a :: 'a'|'b'|'c' > -- we might not need this rule > do { i <- getIncNGI-> ; let -- r = char_list_to_re cs-> r = Any+> ; let r = char_list_to_re cs+> -- r = Any > p = PVar i [] (PE r) > ; return p > }
regex-pderiv.cabal view
@@ -1,8 +1,8 @@ Name: regex-pderiv-Version: 0.0.7+Version: 0.0.8 License: BSD3 License-File: LICENSE-Copyright: Copyright (c) 2009, Kenny Zhuo Ming Lu and Martin Sulzmann+Copyright: Copyright (c) 2010, Kenny Zhuo Ming Lu and Martin Sulzmann Author: Kenny Zhuo Ming Lu and Martin Sulzmann Maintainer: luzhuomi@gmail.com, martin.sulzmann@gmail.com Stability: Alpha@@ -18,15 +18,13 @@ flag base4 library - Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, bytestring- if flag(base4)- Build-Depends: base >= 4.0 && <= 4.1, ghc-prim- else- Build-Depends: base < 4.0 && >= 3.0+ Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, bytestring, deepseq, bitset+ Build-Depends: base >= 4.0 && < 5.0, ghc-prim Exposed-Modules: Text.Regex.PDeriv.ByteString Text.Regex.PDeriv.ByteString.TwoPasses Text.Regex.PDeriv.ByteString.RightToLeft Text.Regex.PDeriv.ByteString.LeftToRight+ Text.Regex.PDeriv.ByteString.LeftToRightD Text.Regex.PDeriv.ByteString.Posix Text.Regex.PDeriv.Common Text.Regex.PDeriv.Word