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 @@ -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))) diff --git a/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs b/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs new file mode 100644 --- /dev/null +++ b/Text/Regex/PDeriv/ByteString/LeftToRightD.lhs @@ -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|), y : (>|A) >, z : (|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-" 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 @@ -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)) 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 @@ -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' 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 @@ -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 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 @@ -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) -> -} - - 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 @@ -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 [] diff --git a/Text/Regex/PDeriv/RE.lhs b/Text/Regex/PDeriv/RE.lhs --- a/Text/Regex/PDeriv/RE.lhs +++ b/Text/Regex/PDeriv/RE.lhs @@ -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 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 @@ -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 > } diff --git a/regex-pderiv.cabal b/regex-pderiv.cabal --- a/regex-pderiv.cabal +++ b/regex-pderiv.cabal @@ -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