packages feed

xhaskell-library (empty) → 0.0.2

raw patch · 18 files changed

+3036/−0 lines, 18 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, ghc-prim, mtl, parsec, regex-base

Files

+ LICENSE view
@@ -0,0 +1,12 @@+This modile is under this "3 clause" BSD license:++Copyright (c) 2009, Kenny Zhuo Ming Lu and Martin Sulzmann+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell+++> import Distribution.Simple(defaultMain)+> main = defaultMain
+ Text/Regex/PDeriv/ByteString.lhs view
@@ -0,0 +1,31 @@+> {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009, BSD License -}++A bytestring implementation of reg exp pattern matching using partial derivative++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.PDeriv.ByteString +>     ( Regex+>     , CompOption(..)+>     , ExecOption(..)+>     , defaultCompOpt+>     , defaultExecOpt+>     , compile+>     , execute+>     , regexec+>     ) where ++The re-exports++> import Text.Regex.PDeriv.ByteString.RightToLeft ( Regex+>                                                 , CompOption(..)+>                                                 , ExecOption(..)+>                                                 , defaultCompOpt+>                                                 , defaultExecOpt+>                                                 , compile+>                                                 , execute+>                                                 , regexec+>                                                 ) +
+ Text/Regex/PDeriv/ByteString/LeftToRight.lhs view
@@ -0,0 +1,349 @@+> {- 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.LeftToRight+>     ( 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 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.Parse+> import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), 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 happend."+>                                       Nothing -> IM.insert k q dict) IM.empty lists+>     in (hash_table, sfinal)++Some helper functions used in buildPdPat0Table++> myLookup = lookup++> 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 myLookup 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' ++++the "partial derivative" operations among integer states + binders++> 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 -> []++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)+++> patMatchesIntStatePdPat0 :: Int -> PdPat0Table -> Word -> [(Int,Binder)] -> [(Int,Binder)]+> patMatchesIntStatePdPat0 cnt pdStateTable  w' eps =+>     case S.uncons w' of +>       Nothing -> eps +>       Just (l,w) -> +>           let +>               eps' = nub2 [ ep' | ep <- eps, ep' <- lookupPdPat0 pdStateTable ep (l,cnt) ] +>               cnt' = cnt + 1+>           in  cnt' `seq` pdStateTable `seq` w `seq` eps' `seq` patMatchesIntStatePdPat0 cnt'  pdStateTable  w eps'++> {- +> fast_nub :: [(Binder,Int)] -> [(Binder,Int)]+> fast_nub eps = +>     let im = IM.empty +>     in fast_nub' im eps+>     where fast_nub' :: IM.IntMap () -> [(Binder,Int)] -> [(Binder,Int)]+>           fast_nub' im [] = []+>           fast_nub' im ((e,p):eps) = +>               let mb_r = IM.lookup p im+>               in case mb_r of+>                  Just _ ->  fast_nub' im eps+>                  Nothing -> let im' = IM.insert p () im+>                             in (e,p):(fast_nub' im' eps)+> -}+++> patMatchIntStatePdPat0 :: Pat -> Word -> [Env]+> patMatchIntStatePdPat0 p w = +>   let+>     (pdStateTable,sfinal) = buildPdPat0Table p+>     s = 0+>     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' )+>   in map (collectPatMatchFromBinder w) $! allbinders+++++> greedyPatMatch :: Pat -> Word -> Maybe Env+> greedyPatMatch p w =+>      first (patMatchIntStatePdPat0 p w)+>   where+>     first (env:_) = return env+>     first _ = Nothing++Compilation+++> compilePat :: Pat -> (PdPat0Table, [Int], Binder)+> compilePat p =  (pdStateTable, sfinal, b)+>     where +>           (pdStateTable,sfinal) = buildPdPat0Table p+>           b = toBinder p++> patMatchIntStateCompiled :: (PdPat0Table, [Int], Binder) -> Word -> [Env]+> 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+++> greedyPatMatchCompiled :: (PdPat0Table, [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 (PdPat0Table, [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. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+>     , 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 "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)))++> input11 = S.pack "1234567890123456789-"
+ Text/Regex/PDeriv/ByteString/Posix.lhs view
@@ -0,0 +1,420 @@+> {- 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 implements the POSIX matching policy proceeds by scanning the input word from right to left.++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.PDeriv.ByteString.Posix+>     ( 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 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(..), IsGreedy(..), nub2)+> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, toBinder, Binder(..), strip)+> import Text.Regex.PDeriv.Parse+> import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub)++++A word is a byte string.++> type Word = S.ByteString++> rg_collect :: S.ByteString -> (Int,Int) -> S.ByteString+> rg_collect w (i,j) = S.take (j' - i' + 1) (S.drop i' w)+>	       where i' = fromIntegral i+>	             j' = fromIntegral j+++----------------------------+-- (greedy) pattern matching++> type Env = [(Int,Word)]+++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 PdPat0TableRev = IM.IntMap [(Int, Int -> Binder -> Binder, Int, [Int])]++A function that builds the above table from the input pattern++> buildPdPat0Table :: Pat -> (PdPat0TableRev, [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 = delta `seq` dictionary `seq` [ (j, l, (i,f,flag,vs)) | (p,l,f,q,flag,vs) <- delta, +>                                                let i = mapping dictionary p  +>                                                    j = mapping dictionary q+>                                               {- , i `seq` j `seq` True -} ]+>         -- lists_with_pri =  lists `seq` zip lists [0..]+>         hash_table =  {-lists_with_pri `seq`-}+>                      foldl (\ dict (q,x,pf@(p,f,flag,vs)) -> +>                                  let k = my_hash q (fst x)+>                                  in k `seq` case IM.lookup k dict of +>                                       Just pfs -> IM.update (\x -> Just (pfs ++ [(p,f,flag,vs)])) k dict+>                                       Nothing -> IM.insert k [(p,f,flag,vs)] dict) IM.empty lists+>     in sfinal `seq` (hash_table, sfinal)++++> 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, Int -> Binder -> Binder, Pat, Int, [Int])] +>         -> [Pat] +>         -> D.Dictionary (Pat,Int)+>         -> Int +>         -> ([Pat], [(Pat, Letter, Int -> Binder -> Binder, Pat, Int, [Int])], 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, f, s', flag, vs ) | s <- curr_states, l <- sig, ((s',f,vs),flag) <- pdPat0Flag s l]+>             new_states = all_sofar_states `seq` D.nub [ s' | (_,_,_,s',_,_) <- new_delta+>                                                       , not (s' `D.isIn` dict) ]+>             acc_delta_next  = (acc_delta ++ new_delta)+>             (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' +++> pdPat0Flag p l = let qfs = pdPat0 p l+>                  in case qfs of +>                       []        -> []+>                       [ (q,f,vs) ] -> [ ((q,f,vs),0) ] +>                       qfs       -> zip qfs [1..]++++> -- | 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)++> -- | algorithm right to left scanning single pass+> -- | the "partial derivative" operations among integer states + binders+> lookupPdPat0' :: PdPat0TableRev -> (Int,Binder) -> Letter -> [(Int,Binder,Int,[Int])]+> lookupPdPat0' hash_table (i,b) (l,x) = +>     case IM.lookup (my_hash i l) hash_table of+>     Just quatripples -> [ (j, op x b, p, vs) | (j, op, p, vs) <- quatripples ]+>     Nothing -> []+ ++> patMatchesIntStatePdPat0Rev  :: Int -> PdPat0TableRev -> Word -> [(Int, Binder, Int, [Int])] -> [(Int, Binder, Int,[Int] )]+> patMatchesIntStatePdPat0Rev  cnt pdStateTableRev w fs =+>     case S.uncons w of +>       Nothing -> fs+>       Just (l,w') -> +>           let +>               fs' = nubPosix [ (j, b', pri, vs ) | (i, b, _, _) <- fs, (j, b', pri, vs) <- lookupPdPat0' pdStateTableRev (i,b) (l,cnt) ]+>               cnt' = cnt - 1+>           in fs' `seq` cnt' `seq` patMatchesIntStatePdPat0Rev cnt' pdStateTableRev w' fs'+++> nubPosix :: [(Int,Binder,Int,[Int])] -> [(Int,Binder,Int,[Int])]+> nubPosix [] = []+> nubPosix [x] = [x]                                            -- optimization+> nubPosix ls = +>     let ls' = nubPosixSub ls+>     in ls'++> nubPosixSub [] = []+> nubPosixSub (x@(k,b,0,_):xs) = +>     let xs' = nubPosixSub xs+>     in (x:xs')+> nubPosixSub a@(x@(k,b,n,vs):xs) = +>     let cmp (k1,b1,_,v1) (k2,b2,_,v2) = compareBinderLocal b1 b2 --  compare (b1,v1) (b2,v2)+>         ys = [ (k',b',n',vs') | (k',b',n',vs') <- a, k == k' ]+>         zs = [ (k',b',n',vs') | (k',b',n',vs') <- a, not (k == k') ]+>         y = maximumBy cmp ys+>     in if x == y +>        then y:(nubPosixSub zs)+>        else nubPosixSub xs+++> compareBinderLocal :: Binder -> Binder -> Ordering +> compareBinderLocal bs bs' = +>     let rs  = map snd bs+>         rs' = map snd bs'+>         os  = map (\ (r,r') -> compareRangeLocal r r')  (zip rs rs')+>     in firstNonEQ os++> compareRangeLocal :: [Range] -> [Range] -> Ordering+> compareRangeLocal [] _ = LT+> compareRangeLocal _ [] = GT+> compareRangeLocal (x:_) (y:_) = +>    -- local, only the most recent is needed+>    compare (len x) (len y)+++> firstNonEQ :: [Ordering] -> Ordering+> firstNonEQ [] = EQ+> firstNonEQ (EQ:os) = firstNonEQ os+> firstNonEQ (o:_) = o++> len :: Range -> Int+> len (b,e) = e - b + 1+++> patMatchIntStatePdPat0Rev :: Pat -> Word -> [Env]+> patMatchIntStatePdPat0Rev p w = +>     let+>         (pdStateTableRev, fins) = buildPdPat0Table p+>         b = toBinder p+>         l = S.length w+>         w' = S.reverse w+>         fs = [ (i, b, 0, []) | i <- fins ]+>         fs' =  w' `seq` fins `seq` l `seq` pdStateTableRev `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTableRev w' fs)+>         -- fs'' = my_sort fs'+>         allbinders = [ b | (s,b,_, _) <- fs', s == 0 ]+>     in map (collectPatMatchFromBinder w) allbinders+>                      ++> -- my_sort = sortBy (\ (_,_,ps) (_,_,ps') -> compare ps ps')++ pat = S.pack "^.*foo=([0-9]+).*bar=([0-9]+).*$"+++> posixPatMatch :: Pat -> Word -> Maybe Env+> posixPatMatch p w =+>     first ( patMatchIntStatePdPat0Rev p w )+>     where+>     first (env:_) = return env+>     first _ = Nothing+++> compilePat :: Pat -> (PdPat0TableRev, [Int], Binder)+> compilePat p = {- pdStateTable `seq` b `seq` -} (pdStateTable, fins, b)+>     where +>           (pdStateTable,fins) = buildPdPat0Table p+>           b = toBinder p+++> patMatchIntStateCompiled ::  (PdPat0TableRev, [Int], Binder) -> Word -> [Env]+> patMatchIntStateCompiled (pdStateTable, fins ,b)  w =+>     let+>         l = S.length w+>         w' = S.reverse w+>         fs = [ (i, b, i, []) | i <- fins ]+>         fs' = w' `seq` fs `seq`  l `seq` pdStateTable `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTable w' fs)+>         -- fs'' = fs' `seq` my_sort fs'+>         allbinders = fs' `seq` [  b' | (s,b',_, _) <- fs', s == 0 ]+>     in allbinders `seq` map (collectPatMatchFromBinder w) allbinders+>       ++> posixPatMatchCompiled :: (PdPat0TableRev, [Int], Binder) -> Word -> Maybe Env+> posixPatMatchCompiled compiled w =+>      first (patMatchIntStateCompiled compiled w)+>   where+>     first (env:_) = return env+>     first _ = Nothing++++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    -- ^ pattern variable index+>                        -> Int -- ^ letter position+>                        -> Binder -> Binder+> updateBinderByIndex i lpos binder =+>     updateBinderByIndexSub lpos i 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+>     | idx == idx' && pos == (b - 1) = (idx', (b - 1, e):rs):xs+>     | idx == idx' && pos < (b - 1)  = (idx', (pos,pos):(b, e):rs):xs+>     | idx == idx' && pos > (b - 1)  = error "impossible, the current letter position is greater 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+>     | idx == idx' = ((idx', [(pos, pos)]):xs)+>     | otherwise = x:(updateBinderByIndexSub pos idx xs)+++> restartLocalBnd :: Pat -> Binder -> Binder+> restartLocalBnd p b = +>   let vs = getVars p+>   in aux vs b +>     where aux :: [Int] -> Binder -> Binder+>           aux vs [] = []+>           aux vs ((b@(x,r)):bs) | x `elem` vs = +>                                     case r of +>                                       { []        -> (b:(aux vs bs))+>                                       ; ((s,e):_) -> ((x, (s,(s-1)):r):(aux vs bs))+>                                       } +>                                 | otherwise   =  (b:(aux vs bs))++retrieve all variables appearing in p++> getVars :: Pat -> [Int] +> getVars (PVar  x _ p) = x:(getVars p)+> getVars (PPair p1 p2) = (getVars p1) ++ (getVars p2)+> getVars (PPlus p1 p2) = (getVars p1)+> getVars (PStar p1 g)  = (getVars p1)+> getVars (PE r)        = []+> getVars (PChoice p1 p2 _) = (getVars p1) ++ (getVars p2)+> getVars (PEmpty p) = (getVars p)++An specialized version of pdPat0 specially designed for the Posix match+In case of p* we reset in the local binding.++> pdPat0 :: Pat -> Letter -> [(Pat, Int -> Binder -> Binder, [Int] )]+> pdPat0 (PVar x w p) (l,idx) +>     | 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)), [x] ) ]+>     | otherwise = +>         let pfs = pdPat0 p (l,idx)+>         in [ (PVar x [] pd, (\i -> (updateBinderByIndex x i) . (f i) ), (x:vs) ) | (pd,f,vs) <- pfs ]+> pdPat0 (PE r) (l,idx) = +>     let pds = partDeriv r l+>     in if null pds then []+>        else [ (PE (resToRE pds), ( \_ -> id ), [] ) ]+> pdPat0 (PStar p g) l = let pfs = pdPat0 p l+>                            f'  = restartLocalBnd p -- restart all local binder in variables in p+>                        in [ (PPair p' (PStar p g), (\ i -> (f i) . f'), vs) | (p', f, vs) <- pfs ]+>                      -- in [ (PPlus p' (PStar p), f) | (p', f) <- pfs ]+> {-+> pdPat0 (PPlus p1 p2@(PStar _)) l  -- we drop this case since it make difference with the PPair+>        | isEmpty (strip p1) = [ (PPlus p3 p2, f) | (p3,f) <- pdPat0 p1 l ] ++ (pdPat0 p2 l) -- simply drop p1 since it is empty+>        | otherwise = [ (PPlus p3 p2, f) | (p3,f) <- pdPat0 p1 l ] +> -}+> pdPat0 (PPair p1 p2) l = +>     if (isEmpty (strip p1))+>     then if isGreedy p1+>          then nub3 ([ (PPair p1' p2, f, vs) | (p1' , f, vs) <- pdPat0 p1 l ] ++ (pdPat0 p2 l))+>          else nub3 ((pdPat0 p2 l) ++ [ (PPair p1' p2, f, vs) | (p1' , f, vs) <- pdPat0 p1 l ])+>     else [ (PPair p1' p2, f, vs) | (p1',f,vs) <- pdPat0 p1 l ]+> pdPat0 (PChoice p1 p2 _) l = +>     nub3 ((pdPat0 p1 l) ++ (pdPat0 p2 l)) -- nub doesn't seem to be essential+++> nub3 :: Eq a => [(a,b,c)] -> [(a,b,c)]+> nub3 = nubBy (\(p1,_,_) (p2, _, _) -> p1 == p2) +++> -- | The PDeriv backend spepcific 'Regex' type++> newtype Regex = Regex (PdPat0TableRev, [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 (posixPatMatchCompiled 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 posixPatMatchCompiled 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. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+>     , 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 +
+ Text/Regex/PDeriv/ByteString/RightToLeft.lhs view
@@ -0,0 +1,355 @@+> {- 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 starts from all the emptiable partial derivatives (AKA final states of the NFA)+and proceeds by scanning the input word from right to left, until the orginal pattern +is reached (AKA init state of the NFA) and the input word is fully consumed.++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.PDeriv.ByteString.RightToLeft+>     ( 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 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(..), IsGreedy(..), nub3) +> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip)+> import Text.Regex.PDeriv.Parse+> import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), 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 -> Range -> 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. ++The reverse pdPat0 table, in addtion, we store the priority of the transition.++> type PdPat0TableRev = IM.IntMap [(Int, Int -> Binder -> Binder, Int)]++A function that builds the above table from the input pattern++> buildPdPat0Table :: Pat -> (PdPat0TableRev, [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 = delta `seq` dictionary `seq` [ (j, l, (i,f,flag)) | (p,l,f,q,flag) <- delta, +>                                                let i = mapping dictionary p  +>                                                    j = mapping dictionary q+>                                               {- , i `seq` j `seq` True -} ]+>         -- lists_with_pri =  lists `seq` zip lists [0..]+>         hash_table =  {-lists_with_pri `seq`-}+>                      foldl (\ dict (q,x,pf@(p,f,flag)) -> +>                                  let k = my_hash q (fst x)+>                                  in k `seq` case IM.lookup k dict of +>                                       Just pfs -> IM.update (\x -> Just (pfs ++ [(p,f,flag)])) k dict+>                                       Nothing -> IM.insert k [(p,f,flag)] dict) IM.empty lists+>     in sfinal `seq` (hash_table, sfinal)++Some helper functions used in buildPdPat0Table++-- > myElem = elem++> myLookup = lookup++> 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 myLookup x candidates of+>                                 (Just i) -> i+>                                 Nothing -> error ("this should not happen. looking up " ++ (pretty x) ++ " from " ++ (show candidates) )++> builder :: [Letter] +>         -> [Pat] +>         -> [(Pat,Letter, Int -> Binder -> Binder, Pat, Int)] +>         -> [Pat] +>         -> D.Dictionary (Pat,Int)+>         -> Int +>         -> ([Pat], [(Pat, Letter, Int -> Binder -> Binder, Pat, Int)], 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, f, s', flag) | s <- curr_states, l <- sig, ((s',f),flag) <- pdPat0Flag s l]+>             new_states = all_sofar_states `seq` D.nub [ s' | (_,_,_,s',_) <- new_delta+>                                                       , not (s' `D.isIn` dict) ]+>             acc_delta_next  = (acc_delta ++ new_delta)+>             (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' ++> pdPat0Flag p l = let qfs = pdPat0 p l+>                  in case qfs of +>                       []        -> []+>                       [ (q,f) ] -> [ ((q,f),0) ] +>                       qfs       -> zip qfs [1..]++++++> -- | 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)++> -- | 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+>     Just pairs -> pairs+>     Nothing -> []+ +> myuncons = S.uncons++> patMatchesIntStatePdPat0Rev  :: Int -> PdPat0TableRev -> Word -> [(Int, Binder -> Binder, Int)] -> [(Int, Binder -> Binder, Int )]+> patMatchesIntStatePdPat0Rev  cnt pdStateTableRev w fs =+>     case myuncons 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+>           in fs' `seq` cnt' `seq` patMatchesIntStatePdPat0Rev cnt' pdStateTableRev w' fs'++++> patMatchIntStatePdPat0Rev :: Pat -> Word -> [Env]+> patMatchIntStatePdPat0Rev p w = +>     let+>         (pdStateTableRev, fins) = buildPdPat0Table p+>         b = toBinder p+>         l = S.length w+>         w' = S.reverse w+>         fs = [ (i, id, 0) | i <- fins ]+>         fs' =  w' `seq` fins `seq` l `seq` pdStateTableRev `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTableRev w' fs)+>         -- fs'' = my_sort fs'+>         allbinders = b `seq` [ (f b) | (s,f,_) <- fs', s == 0 ]+>     in map (collectPatMatchFromBinder w) allbinders+>                      ++> -- my_sort = sortBy (\ (_,_,ps) (_,_,ps') -> compare ps ps')++ pat = S.pack "^.*foo=([0-9]+).*bar=([0-9]+).*$"+++> greedyPatMatch :: Pat -> Word -> Maybe Env+> greedyPatMatch p w =+>     first ( patMatchIntStatePdPat0Rev p w )+>     where+>     first (env:_) = return env+>     first _ = Nothing+++> compilePat :: Pat -> (PdPat0TableRev, [Int], Binder)+> compilePat p = {- pdStateTable `seq` b `seq` -} (pdStateTable, fins, b)+>     where +>           (pdStateTable,fins) = buildPdPat0Table p+>           b = toBinder p+++> patMatchIntStateCompiled ::  (PdPat0TableRev, [Int], Binder) -> Word -> [Env]+> patMatchIntStateCompiled (pdStateTable, fins ,b)  w =+>     let+>         l = S.length w+>         w' = S.reverse w+>         fs = [ (i, id, i) | i <- fins ]+>         fs' = w' `seq` fs `seq`  l `seq` pdStateTable `seq` (patMatchesIntStatePdPat0Rev (l-1) pdStateTable w' fs)+>         -- fs'' = fs' `seq` my_sort fs'+>         allbinders = fs' `seq` b `seq` [ (f b) | (s,f,_) <- fs', s == 0 ]+>     in allbinders `seq` map (collectPatMatchFromBinder w) allbinders+>       ++> greedyPatMatchCompiled :: (PdPat0TableRev, [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 (PdPat0TableRev, SNFA Pat Letter, Binder) ++> newtype Regex = Regex (PdPat0TableRev, [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. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+>     , 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 "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)))++> input11 = S.pack "1234567890123456789-"
+ Text/Regex/PDeriv/ByteString/TwoPasses.lhs view
@@ -0,0 +1,383 @@+> {- 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 starts by scanning the input words from right to left. The goal is +for each prefix of the input word, we keep track of the set of "successful" states that lead to +a successful match. Then We perform the actual matching by scanning the words+from left to right. Making use of the sets of "successful" states, we prune away +failures states as long as we cannot find them in the sets.++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.PDeriv.ByteString.TwoPasses+>     ( 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 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(..), IsGreedy(..), nub2)+> import Text.Regex.PDeriv.IntPattern (Pat(..), pdPat, pdPat0, toBinder, Binder(..), strip)+> import Text.Regex.PDeriv.Parse+> import qualified Text.Regex.PDeriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub)++A word is a byte string.++> type Word = S.ByteString++++version using the SNFA++In addtion, we pass in a lookup table that maps+target_state * letter to source_state.++> rev_scanIntState :: [Int] -- ^ the final states+>                     -> PdPat0TableRev -- ^ the reverse mapping table+>                     -> Word +>                     -> [[Int]]+> rev_scanIntState sfinal table w = table `seq` rev_scan_helperIntState (S.reverse w) table sfinal []++> rev_scan_helperIntState w table curr_states chain = +>     case S.uncons w of +>     Just (l,w') ->+>           let +>                 pairs  =     [ (p_s,p_t) | p_t <- curr_states, +>                                p_s <- my_lookup p_t l table ]+>                 (next_states', curr_states') = unzip pairs+>                 next_states'' =  nub next_states'+>                 curr_states'' =  nub curr_states'+>                 next_chain = curr_states'':chain+>           in (rev_scan_helperIntState w' table $! next_states'') $! next_chain+>     _ -> curr_states:chain+++++----------------------------+-- (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++++actual pattern matcher++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)]++we also record the reverse transition in another hash table, which will be used in the reverse scanning process++> type PdPat0TableRev = IM.IntMap [Int] ++> -- | function 'buildPdPat0Table' builds the above tables from the pattern+++> buildPdPat0Table :: Pat ->  (PdPat0Table, [Int], PdPat0TableRev)+> 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+>         sdelta = [ (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 happend."+>                                       Nothing -> IM.insert k q dict) IM.empty sdelta+>         sdelta_rev = [ (j,l,i) | +>                        (p,l, qfs) <- delta, +>                        let i = mapping dictionary p+>                            jfs = map (\(q,f) -> (mapping dictionary q, f)) qfs,+>                        (j,f) <- jfs+>                      ]+>         hash_table_rev = foldl (\ dict (p,x,q) -> +>                                  let k = my_hash p (fst x)+>                                  in case IM.lookup k dict of +>                                       Just ps -> IM.update (\ _ -> Just (q:ps)) k dict+>                                       Nothing -> IM.insert k [q] dict) IM.empty sdelta_rev+>     in (hash_table, sfinal, hash_table_rev)++Some helper functions used in buildPdPat0Table++> myLookup = lookup++> 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 myLookup 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' +++++> -- | function 'lookupPdPat0' looks up the "partial derivative" operations given an integer state and apply the update function to the binder.++> 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 -> []++> -- | 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)+++> -- | 'patMAtchIntStatePdPat0' implements the two passes pattern matching algo+> patMatchIntStatePdPat0 :: Pat -> Word -> [Env]+> patMatchIntStatePdPat0 p w = +>   let+>     (pdStateTable,sfinals,pdStateTableRev) = buildPdPat0Table p+>     filters = pdStateTableRev `seq` sfinals `seq` rev_scanIntState sfinals pdStateTableRev w+>     s = 0+>     b = toBinder p+>     allbinders' = b `seq` s `seq` pdStateTable `seq` filters `seq` (patMatchesIntStatePdPat0 0 pdStateTable w [(s,b)]) filters+>     allbinders = allbinders' `seq` map snd allbinders'+>   in map (collectPatMatchFromBinder w) $! allbinders++> patMatchesIntStatePdPat0 :: Int -> PdPat0Table -> Word -> [(Int,Binder)] -> [[Int]] -> [(Int,Binder)]+> patMatchesIntStatePdPat0 cnt pdStateTable  w' ps fps' =+>     case (S.uncons w', fps') of +>       (Nothing,_) -> ps +>       (Just (l,w),(fp:fps)) -> +>           let +>               reachable_ps = ps `seq` fp `seq` nub2 [ p | p@(s,_) <- ps, elem s fp ]+>               next_ps = l `seq` cnt `seq` pdStateTable `seq` reachable_ps `seq` concat [ lookupPdPat0 pdStateTable  p (l,cnt) | p <- reachable_ps ]+>               cnt' = cnt + 1+>          in cnt' `seq` pdStateTable `seq` w `seq` next_ps `seq` fps `seq` patMatchesIntStatePdPat0 cnt'  pdStateTable  w  next_ps fps+>       (Just (l,w),[]) ->+>           error "patMatchesIntStatePdPat0 failed with empty fps and non empty input word!"+++> greedyPatMatch :: Pat -> Word -> Maybe Env+> greedyPatMatch p w =+>      first (patMatchIntStatePdPat0 p w)+>   where+>     first (env:_) = return env+>     first _ = Nothing+>  ++> -- | Compilation+> compilePat :: Pat -> (PdPat0Table, [Int], PdPat0TableRev, Binder)+> compilePat p =  pdStateTable `seq` pdStateTableRev `seq` sfinal `seq` (pdStateTable, sfinal, pdStateTableRev, b)+>     where +>           (pdStateTable,sfinal,pdStateTableRev) = buildPdPat0Table p+>           b = toBinder p++> patMatchIntStateCompiled :: (PdPat0Table, [Int], PdPat0TableRev, Binder) -> Word -> [Env]+> patMatchIntStateCompiled (pdStateTable,sfinals, pdStateTableRev, b) w = +>   let+>     filters = sfinals `seq` pdStateTableRev `seq` rev_scanIntState sfinals pdStateTableRev $! w +>     s = 0 +>     allbinders' = b `seq` s `seq` pdStateTable `seq` filters `seq` (patMatchesIntStatePdPat0 0 pdStateTable w [(s,b)]) filters+>     allbinders =  map snd allbinders'+>   in map (collectPatMatchFromBinder w) allbinders++++> greedyPatMatchCompiled :: (PdPat0Table, [Int], PdPat0TableRev, Binder)  -> Word -> Maybe Env+> greedyPatMatchCompiled compiled w =+>      first (patMatchIntStateCompiled compiled w)+>   where+>     first (env:_) = return env+>     first _ = Nothing+++++> newtype Regex = Regex (PdPat0Table, [Int], PdPat0TableRev, 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. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+>     , 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 "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)))++> input11 = S.pack "1234567890123456789-"
+ Text/Regex/PDeriv/Common.lhs view
@@ -0,0 +1,105 @@+> -- | this module contains the defs of common data types and type classes+> module Text.Regex.PDeriv.Common where++> import Data.Char (ord)+> import qualified Data.IntMap as IM+> import Data.List (nubBy)++> type Range  = (Int,Int)      -- ^ (sub)words represent by range+> type Letter = (Char,Int)     -- ^ a character and its index (position)++> class IsEmpty a where+>     isEmpty :: a -> Bool++> my_hash :: Int -> Char -> Int+> my_hash i x = (ord x) + 256 * i++the lookup function++> my_lookup :: Int -> Char -> IM.IntMap [Int] -> [Int]+> my_lookup i x dict = case IM.lookup (my_hash i x) dict of+>                      Just ys -> ys+>                      Nothing -> []++++> -- | The greediness flag+> data GFlag = Greedy    -- ^ greedy+>            | NotGreedy -- ^ not greedy+>              deriving Eq++> instance Show GFlag where+>     show Greedy = ""+>     show NotGreedy = "?"++> class IsGreedy a where+>     isGreedy :: a -> Bool+++> -- | remove duplications in a list of pairs whose, 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 = nub2sub IM.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)+++> nub3 :: [(Int,a,Int)] -> [(Int,a,Int)]+> nub3 [] = []+> nub3 [x] = [x]                                            -- optimization+> nub3 ls = +>     let (_,ls') = nub3sub IM.empty ls+>     in ls'++> nub3sub im [] = (im,[])+> 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')+>                               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/Dictionary.hs view
@@ -0,0 +1,156 @@+-- | A module that implements a dictionary/hash table++module Text.Regex.PDeriv.Dictionary where+++import qualified Data.IntMap as IM+import Data.Char++class Key a where+    hash :: a -> [Int]+++instance Key Int where+    hash i = [i]++instance Key Char where+    hash c = [(ord c)]++instance (Key a, Key b) => Key (a,b) where+    hash (a,b) = hash a ++ hash b++instance (Key a, Key b, Key c) => Key (a,b,c) where+    hash (a,b,c) = hash a ++ hash b ++ hash c+++instance Key a => Key [a] where+    hash as = concatMap hash as+++-- an immutable dictionary+newtype Dictionary a = Dictionary (Trie a)++primeL :: Int+primeL = 757+primeR :: Int+primeR = 577++empty :: Dictionary a+empty = Dictionary emptyTrie ++-- insert and overwrite+insert :: Key k => k -> a -> Dictionary a -> Dictionary a+insert key val (Dictionary trie) = +    let key_hash = hash key+    in key_hash `seq` Dictionary (insertTrie True key_hash val trie)++-- insert not overwrite+insertNotOverwrite :: Key k => k -> a -> Dictionary a -> Dictionary a+insertNotOverwrite key val (Dictionary trie) = +    let key_hash = hash key+    in key_hash `seq` Dictionary (insertTrie False key_hash val trie)++++lookup :: Key k => k -> Dictionary a -> Maybe a+lookup key (Dictionary trie) = +    let key_hash = hash key+    in key_hash `seq` +       case lookupTrie key_hash trie of+        Just (Trie (x:_) _) -> Just x+	_		    -> Nothing++lookupAll :: Key k => k -> Dictionary a -> [a]+lookupAll key (Dictionary trie) = +    let key_hash = hash key+    in key_hash `seq` +       case lookupTrie key_hash trie of+        Just (Trie xs _) -> xs+	_		 -> [] ++++fromList :: Key k => [(k,a)] -> Dictionary a +fromList l = foldl (\d (key,val) -> insert key val d) empty l++fromListNotOverwrite :: Key k => [(k,a)] -> Dictionary a +fromListNotOverwrite l = foldl (\d (key,val) -> insertNotOverwrite key val d) empty l++update :: Key k => k -> a -> Dictionary a -> Dictionary a+update key val (Dictionary trie) = +    let key_hash = hash key+        trie'     = key_hash `seq` updateTrie key_hash val trie+    in Dictionary trie'+++-- The following are some special functions we implemented for+-- an special instance of the dictionary 'Dictionary (k,a)' +-- in which we store both the key k together with the actual value a, +-- i.e. we map (hash k) to list of (k,a) value pairs++-- ^ the dictionary (k,a) version of elem+isIn :: (Key k, Eq k) => k -> Dictionary (k,a) -> Bool+isIn k dict = +    let all = lookupAll (hash k) dict+    in k `elem` (map fst all)++nub :: (Key k, Eq k) => [k] -> [k]+nub ks = nubSub ks empty++nubSub :: (Key k, Eq k) => [k] -> Dictionary (k,()) -> [k]+nubSub [] d = []+nubSub (x:xs) d +    | x `isIn` d = nubSub xs d+    | otherwise = let d' = insertNotOverwrite x (x,()) d +                  in x:(nubSub xs d')+++++-- An internal trie which we use to implement the dictoinar ++data Trie a = Trie ![a] !(IM.IntMap (Trie a))++emptyTrie = Trie [] (IM.empty)+++insertTrie :: Bool -> [Int] -> a -> Trie a -> Trie a+insertTrie overwrite [] i (Trie is maps) +    | overwrite  =  Trie [i] maps+    | otherwise  =  Trie (i:is) maps+insertTrie overwrite (word:words) i (Trie is maps) = +    let key = word+    in key `seq` case IM.lookup key maps of +	 { Just trie -> let trie' = insertTrie overwrite words i trie+			    maps' = trie' `seq` IM.update (\x -> Just trie') key maps+			in maps' `seq` Trie is maps'+	 ; Nothing -> let trie = emptyTrie+			  trie' = insertTrie overwrite words i trie+			  maps' = trie' `seq` IM.insert key trie' maps+		      in maps' `seq` Trie is maps'+	 }+++++lookupTrie :: [Int] -> Trie a -> Maybe (Trie a) +lookupTrie [] trie = Just trie+lookupTrie (word:words) (Trie is maps) = +    let key = word+    in case IM.lookup key maps of+	   Just trie -> lookupTrie words trie+	   Nothing   -> Nothing++-- we only update the first one, not the collided ones+updateTrie :: [Int] -> a -> Trie a -> Trie a+updateTrie [] y (Trie (x:xs) maps) = Trie (y:xs) maps+updateTrie (word:words) v  (Trie is maps) =+    let key = word+    in case IM.lookup key maps of+	   Just trie -> let trie' = updateTrie words v trie+			    maps'  = IM.update (\x -> Just trie') key maps+			in Trie is maps'+	   Nothing   -> Trie is maps+++
+ Text/Regex/PDeriv/ExtPattern.lhs view
@@ -0,0 +1,37 @@+> module Text.Regex.PDeriv.ExtPattern where++> -- | The external pattern syntax (ERE syntax)+> data EPat = EEmpty +>          | EGroup EPat    -- ^ the group ( re )+>          | EOr [EPat]     -- ^ the union re|re+>          | EConcat [EPat] -- ^ the concantenation rere+>          | EOpt EPat Bool -- ^ the option re?, the last boolean flag indicates whether it is greedy+>          | EPlus EPat Bool -- ^ the plus re++>          | EStar EPat Bool -- ^ the star re*+>          | EBound EPat Int (Maybe Int) Bool -- ^ re{1:10}+>          | ECarat         -- ^ the ^ NOTE:shouldn't this must be top level?+>          | EDollar        -- ^ the $+>          | EDot           -- ^ the any char .+>          | EAny [Char]    -- ^ the character class [ a-z ] +>          | ENoneOf [Char] -- ^ the negative character class [^a-z]+>          | EEscape Char   -- ^ backslash char+>          | EChar Char     -- ^ the non-escaped char+>           deriving Show++> -- | Function 'hasGroup' tests whether an external pattern has ( ... ) (i.e. variable patterns in the internal pattern)+> hasGroup :: EPat -> Bool+> hasGroup EEmpty = False+> hasGroup (EGroup _) = True+> hasGroup (EOr eps) = any hasGroup eps+> hasGroup (EConcat eps) = any hasGroup eps+> hasGroup (EOpt ep _) = hasGroup ep+> hasGroup (EPlus ep _) = hasGroup ep+> hasGroup (EStar ep _) = hasGroup ep+> hasGroup (EBound ep _ _ _) = hasGroup ep+> hasGroup ECarat = False+> hasGroup EDollar = False+> hasGroup EDot = False+> hasGroup (EAny _) = False+> hasGroup (ENoneOf _) = False+> hasGroup (EEscape _) = False+> hasGroup (EChar _) = False
+ Text/Regex/PDeriv/IntPattern.lhs view
@@ -0,0 +1,260 @@+> -- | 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++> import Data.List++> import Text.Regex.PDeriv.Common (Range, Letter, IsEmpty(..), GFlag(..), IsGreedy(..) )+> import Text.Regex.PDeriv.RE+> import Text.Regex.PDeriv.Dictionary (Key(..), primeL, primeR)+> import Text.Regex.PDeriv.Pretty+++> -- | regular expression patterns+> data Pat = PVar Int [Range] Pat       -- ^ variable pattern +>   | PE RE                             -- ^ pattern without binder+>   | PPair Pat Pat                     -- ^ pair pattern+>   | PChoice Pat Pat GFlag             -- ^ choice pattern +>   | PStar Pat GFlag                   -- ^ star pattern +>   | PPlus Pat Pat                     -- ^ plus pattern, it is used internally to indicate that it is unrolled from a PStar+>   | PEmpty Pat                        -- ^ empty pattern, it is used intermally to indicate that mkEmpty function has been applied.+++> {-| The Eq instance for Pat data type+>     NOTE: We ignore the 'consumed word' when comparing patterns+>     (ie we only compare the pattern structure).+>     Essential for later comparisons among patterns. -}++> instance Eq Pat where+>   (==) (PVar x1 _ p1) (PVar x2 _ p2) = (x1 == x2) && (p1 == p2) +>   (==) (PPair p1 p2) (PPair p1' p2') = (p1 == p1') && (p2 == p2')+>   (==) (PChoice p1 p2 g1) (PChoice p1' p2' g2) = (g1 == g2) && (p2 == p2') && (p1 == p1') -- more efficient, because choices are constructed in left-nested+>   (==) (PPlus p1 p2) (PPlus p1' p2') = (p1 == p1') && (p2 == p2')+>   (==) (PStar p1 g1) (PStar p2 g2) =  (g1 == g2) && (p1 == p2)+>   (==) (PE r1) (PE r2) = r1 == r2+>   (==) _ _ = False+> ++> instance Pretty Pat where+>     pretty (PVar x1 _ p1) = "(" ++ show x1 ++ ":" ++ pretty p1 ++ ")"+>     pretty (PPair p1 p2) = "<" ++ pretty p1 ++ "," ++ pretty p2 ++ ">"+>     pretty (PChoice p1 p2 g) = "(" ++ pretty p1 ++ "|" ++ pretty p2 ++ ")" ++ (show g)+>     pretty (PE r) = show r+>     pretty (PPlus p1 p2 ) = "(" ++ pretty p1 ++ "," ++ pretty p2 ++ ")"+>     pretty (PStar p g) = (pretty p) ++ "*" ++ (show g)+>     pretty (PEmpty p) = "[" ++ pretty p ++ "]"++> instance Show Pat where+>     show pat = pretty pat++> instance Key Pat where+>     hash (PVar x1 _ p1) = let y1 = head (hash x1) +>                               y2 = head (hash p1)+>                           in y1 `seq` y2 `seq` [ 1 + y1 * primeL + y2 * primeR ] +>     hash (PPair p1 p2) = let x1 = head (hash p1)+>                              x2 = head (hash p2)+>                          in x1 `seq` x2 `seq` [ 2 + x1 * primeL + x2 * primeR ] +>     hash (PChoice p1 p2 Greedy) = let x1 = head (hash p1)+>                                       x2 = head (hash p2)+>                                   in x1 `seq` x2 `seq`  [ 4 + x1 * primeL + x2 * primeR ] +>     hash (PChoice p1 p2 NotGreedy) = let x1 = head (hash p1)+>                                          x2 = head (hash p2)+>                                      in x1 `seq` x2 `seq` [ 5 + x1 * primeL + x2 * primeR ]+>     hash (PPlus p1 p2) = let x1 = head (hash p1)+>                              x2 = head (hash p2)+>                          in x1 `seq` x2 `seq` [ 6 + x1 * primeL + x2 * primeR ]+>     hash (PStar p Greedy) = let x = head (hash p)+>                             in x `seq` [ 7 + x * primeL ]+>     hash (PStar p NotGreedy) = let x = head (hash p)+>                             in x `seq` [ 8 + x * primeL ]+>     hash (PE r) = let x = head (hash r)+>                   in x `seq` [ 9 + x * primeL ]+>     hash (PEmpty p) = let x = head (hash p)+>                       in x `seq` [ 3 + x * primeL ]+>++> -- | function 'strip' strips away the bindings from a pattern+> strip :: Pat -> RE +> strip (PVar _ w p) = strip p+> strip (PE r) = r+> strip (PStar p g) = Star (strip p) g+> strip (PPair p1 p2) = Seq (strip p1) (strip p2)+> strip (PPlus p1 p2) = Seq (strip p1) (strip p2)+> strip (PChoice p1 p2 g) = Choice (strip p1) (strip p2) g+> strip (PEmpty p) = strip p+++> -- | function 'mkEmpPat' makes an empty pattern+> mkEmpPat :: Pat -> Pat+> mkEmpPat (PVar x w p) = PVar x w (mkEmpPat p)+> mkEmpPat (PE r) +>   | isEmpty r = PE Empty+>   | otherwise = PE Phi+> mkEmpPat (PStar p g) = PE Empty -- problematic?! we are losing binding (x,()) from  ( x : a*) ~> PE <>+> mkEmpPat (PPlus p1 p2) = mkEmpPat p1 -- since p2 must be pstar we drop it. If we mkEmpPat p2, we need to deal with pdPat (PPlus (x :<>) (PE <>)) l+> mkEmpPat (PPair p1 p2) = PPair (mkEmpPat p1) (mkEmpPat p2)+> mkEmpPat (PChoice p1 p2 g) = PChoice (mkEmpPat p1) (mkEmpPat p2) g++> {-| function 'pdPat' computes the partial derivatives of a pattern w.r.t. a letter.+>    Integrating non-greedy operator with PStar+>    For p*, we need to unroll it into a special construct+>    say PPlus p' p* where p' \in p/l.+>    When we push another label, say l' to PPlus p' p*, and+>    p' is emptiable, naively, we would do +>    [ PPlus p'' p* | p'' <- p' / l ] ++ [ PPlus (mkE p') (PPlus p''' p*) | (PPlus p''' p*) <- p*/l ]+>    Now the problem here is the shape of the pdpat are infinite, which +>    breaks the requirement of getting a compilation scheme.+>    The fix here is to simplify the second component, by combining the binding, of (mkE p') and p'''+>    since they share the same set of variables.+>    [ PPlus p'' p* | p'' <- p' / l ] ++ [ PPlus p4 p* | (PPlus p''' p*) <- p*/l ] +>    where p4 = combineBinding (mkE p') p'''+>    For pdPat0 approach, we do not need to do this explicitly, we simply drop +>    (mkE p') even in the PPair case. see the definitely of pdPat0 below+> -}+> pdPat :: Pat -> Letter -> [Pat]+> pdPat (PVar x w p) (l,idx) = +>          let pds = pdPat p (l,idx)+>          in if null pds then []+>             else case w of+>		  [] -> [ PVar x [ (idx,idx) ] pd | pd <- pds ]+>		  ((b,e):rs)      --  ranges are stored in the reversed manner, the first pair the right most segment+>                     | idx == (e + 1) -> -- it is consecutive+>                         [ PVar x ((b,idx):rs) pd | pd <- pds ]+>                     | otherwise ->      -- it is NOT consecutive+>                         [ PVar x ((idx,idx):(b,e):rs) pd | pd <- pds ]+> pdPat (PE r) (l,idx) = let pds = partDeriv r l +>                  in if null pds then []+>                     else [ PE $ resToRE pds ]+> {-| The non-greedy operator has impact to a sequence pattern if the +>     first sub pattern is non-greedy. We simply swap the order of the +>     'choices' in the resulting pds. -} +> pdPat (PPair p1 p2) l = +>   if (isEmpty (strip p1))+>   then  if isGreedy p1+>         then nub ([ PPair p1' p2 | p1' <- pdPat p1 l] ++ +>                   [ PPair (mkEmpPat p1) p2' | p2' <- pdPat p2 l])+>         else nub ( [ PPair (mkEmpPat p1) p2' | p2' <- pdPat p2 l] ++ [ PPair p1' p2 | p1' <- pdPat p1 l] )+>   else [ PPair p1' p2 | p1' <- pdPat p1 l ]+> {-| Integrating non-greedy operator with pstar requires more cares.+>     We have two questions to consider.+>      1) When we unfold p*, do we need to take the non-greediness in p into consideration?+>         The answer is no. +>         What happens is that when we unfold p* into p and p*, if we were considering p is non-greedy and apply pdpat to p*+>         again, i.e. mkE(p),p*/l we will run into non-terminating problem. This seems to be bug with python re library. -} +> pdPat (PStar p g) l = let pds = pdPat p l+>                       in [ PPlus pd (PStar p g) | pd <- pds ]+> {-| 2) After we unfold p* and 'advance' to (PPlus p' p*) say p' \in p / l for some l+>        we are in the position of 'pushing' another label l' into  (PPlus p' p*). +>     Shall we swap the order of the alternatives when p' is non-greedy?+>     Why not? This seems harmless since we have already made some progress by pushing l into p*. -}+> pdPat (PPlus p1 p2@(PStar _ _)) l -- ^ p2 must be pStar+>     | isEmpty (strip p1) = +>         if isGreedy p1 +>         then [ PPlus p3 p2 | p3  <- pdPat p1 l ] ++ [ PPlus p3 p2' | (PPlus p1' p2') <- pdPat p2 l, let p3 =  p1' `getBindingsFrom` p1 ]+>         else [ PPlus p3 p2' | (PPlus p1' p2') <- pdPat p2 l, let p3 =  p1' `getBindingsFrom` p1 ] ++ [ PPlus p3 p2 | p3  <- pdPat p1 l ]+>     | otherwise          = [ PPlus p3 p2 | p3  <- pdPat p1 l ]+> pdPat (PChoice p1 p2 g) l = +>    nub ((pdPat p1 l)  ++ (pdPat p2 l)) -- nub doesn't seem to be essential+> pdPat p l = error ((show p) ++ (show l))++> -- | function 'getBindingsFrom' transfer bindings from p2 to p1+> getBindingsFrom :: Pat  -- ^ the source of the  +>                    -> Pat -> Pat+> 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+>                                     Nothing -> let p' = assign p b in PVar x w p'+>                                     Just rs -> let p' = assign p b in PVar x (w ++ rs) p'+>           assign (PE r) _ = PE r+>           assign (PPlus p1 p2) b = PPlus (assign p1 b) p2 -- we don't need to care about p2 since it is a p*+>           assign (PPair p1 p2) b = PPair (assign p1 b) (assign p2 b)+>           assign (PChoice p1 p2 g) b = PChoice (assign p1 b) (assign p2 b) g++++> -- | Function 'isGreedy' checks whether a pattern is greedy+> instance IsGreedy Pat where+>     isGreedy (PVar _ _ p) = isGreedy p+>     isGreedy (PE r) = isGreedy r+>     isGreedy (PPair p1 p2) = isGreedy p1 || isGreedy p2+>     isGreedy (PChoice p1 p2 Greedy) = True+>     isGreedy (PChoice p1 p2 NotGreedy) = False -- isGreedy p1 || isGreedy p2+>     isGreedy (PEmpty p) = False+>     isGreedy (PStar p Greedy) = True+>     isGreedy (PStar p NotGreedy) = False+>     isGreedy (PPlus p p') = isGreedy p || isGreedy p'+++> -- | The 'Binder' type denotes a set of (pattern var * range) pairs+> type Binder = [(Int, [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++++> {-| 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    -- ^ the indext of the pattern variable+>                        -> Int -- ^ the letter position+>                        -> Binder -> Binder+> updateBinderByIndex i lpos binder =+>     updateBinderByIndexSub lpos i 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+>     | 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+>     | idx == idx' = ((idx', [(pos, pos)]):xs)+>     | otherwise = x:(updateBinderByIndexSub pos idx 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+>     an update function which defines the change of the pattern bindings from the 'source' pattern to +>     the resulting partial derivative. This is used in the compilation of the regular expression pattern -}+> pdPat0 :: Pat  -- ^ the source pattern+>           -> Letter -- ^ the letter to be "consumed"+>           -> [(Pat, Int -> Binder -> Binder)]+> pdPat0 (PVar x w p) (l,idx) +>     | 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))) ]+>     | otherwise = +>         let pfs = pdPat0 p (l,idx)+>         in pfs `seq` [ (PVar x [] pd, (\i -> (updateBinderByIndex x i) . (f i) ) ) | (pd,f) <- pfs ]+> pdPat0 (PE r) (l,idx) = +>     let pds = partDeriv r l+>     in  pds `seq` if null pds then []+>                   else [ (PE (resToRE pds), ( \_ -> id ) ) ]+> pdPat0 (PStar p g) l = let pfs = pdPat0 p l+>                        in pfs `seq` [ (PPair p' (PStar p g), f) | (p', f) <- pfs ]+> pdPat0 (PPair p1 p2) l = +>     if (isEmpty (strip p1))+>     then if isGreedy p1+>          then nub2 ([ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ] ++ (pdPat0 p2 l))+>          else nub2 ((pdPat0 p2 l) ++ [ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ])+>     else [ (PPair p1' p2, f) | (p1',f) <- pdPat0 p1 l ]+> pdPat0 (PChoice p1 p2 g) l = +>      nub2 ((pdPat0 p1 l) ++ (pdPat0 p2 l)) -- nub doesn't seem to be essential+++> nub2 :: Eq a => [(a,b)] -> [(a,b)]+> nub2 = nubBy (\(p1,f1) (p2, f2) -> p1 == p2)
+ Text/Regex/PDeriv/Nfa.lhs view
@@ -0,0 +1,80 @@+> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +> -- | This module defines data types, type classes and instances for NFA+> module Text.Regex.PDeriv.Nfa where ++> import Data.List ++> -- | The type class of Nfa+> class Nfa s a | s -> a where+>    pDeriv :: s -> a -> [s]+>    sigma :: s -> [a]+>    empty :: s -> Bool++> -- | A function that builds an NFA +> buildNFA :: (Nfa s a, Eq s, Eq a) => s -> NFA s a+> buildNFA init = {- all `seq` delta `seq` final `seq` -}+>                 NFA { all_states = all+>                     , delta_states = delta+>                     , init_states = [init]+>                     , final_states = final }+>   where+>      sig = sigma init+>      (all, delta) = sig `seq` builder [] [] [init]+>      final = all `seq` [s | s <- all, empty s]+>      builder acc_states acc_delta [] = (acc_states, acc_delta)+>      builder acc_states acc_delta curr_states =+>        let all_sofar_states = acc_states ++ curr_states+>            new_delta = [ (s, l, s') | s <- curr_states, l <- sig, s' <- pDeriv s l]+>            -- new_states = nub [new_s | s <- curr_states, l <- sig , +>                         --- new_s <- pDeriv s l, not (elem new_s all_sofar_states)]+>            new_states = all_sofar_states `seq` nub [ s' | (_,_,s') <- new_delta, not (s' `elem` all_sofar_states) ]+>            acc_delta_next  = (acc_delta ++ new_delta)+>        in {- all_sofar_states `seq` new_delta `seq` new_states `seq` -} builder all_sofar_states acc_delta_next new_states++> -- | the NFA data type+> data NFA s a = NFA { all_states :: [s]+>                    , delta_states :: [(s, a, s)]+>                    , init_states :: [s]+>                    , final_states :: [s] }+>                 deriving Show+++> -- | the optimized NFA using Int to represent states, IntMap to represent delta+> data SNFA s a = SNFA { mapping_states :: s -> Int+>                        , sall_states :: [Int]+>                        , sdelta_states :: [(Int,a,Int)]+>                        , sinit_states :: [Int]+>                        , sfinal_states :: [Int] }+>                 +++> instance Show a => Show (SNFA s a) where+>   show s = "SNFA:\n" ++ show (sall_states s) ++ "\n"+>                      ++ show (sdelta_states s) ++ "\n"+>                      ++ show (sinit_states s) ++ "\n"+>                      ++ show (sfinal_states s)++> -- | The function 'toSNFA' converts from an NFA to an SNFA+> toSNFA :: (Eq s, Eq a)  => NFA s a -> SNFA s a+> toSNFA (NFA { all_states = all+>             , delta_states = delta+>             , init_states = init+>             , final_states = final }) = +>     let -- generate mapping from states to Int+>         mapping = all `seq` \x -> let (Just i) = findIndex (x ==) all in i +>         sall_sts = [0..(length all)-1]+>         sdelta_sts = mapping `seq` delta `seq` ( map (\ (p,x,q) -> (mapping p,x,mapping q)) delta)+>         sfinal_sts = mapping `seq` final `seq` ( map mapping final )+>     in  {- sall_sts `seq` sdelta_sts `seq` sfinal_sts `seq` -}+>             SNFA { mapping_states = mapping+>                  , sall_states = sall_sts+>                  , sdelta_states = sdelta_sts+>                  , sinit_states = [0]+>                  , sfinal_states = sfinal_sts }+++> nofAllStates (NFA {all_states = all}) = length all+> nofDelta (NFA {delta_states = delta}) = length delta+> nofInitStates (NFA {init_states = init}) = length init+> nofFinalStates (NFA {final_states = final}) = length final
+ Text/Regex/PDeriv/Parse.lhs view
@@ -0,0 +1,150 @@+> module Text.Regex.PDeriv.Parse (parsePat) where++> {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009. BSD3 -}++The parser that parse POSIX style regex syntax and translate it into our +internal pattern representation.+This parser is largely adapted from Text.Regex.TDFA.ReadRegex++> import Text.ParserCombinators.Parsec((<|>), (<?>),+>                                      unexpected, try, runParser, many, getState, setState, CharParser, ParseError,+>                                      sepBy1, option, notFollowedBy, many1, lookAhead, eof, between,+>                                      string, noneOf, digit, char, anyChar)+> import Control.Monad(liftM, when, guard)+> import Data.List (sort,nub)++> import Text.Regex.PDeriv.ExtPattern (EPat(..))+> import Text.Regex.PDeriv.IntPattern (Pat(..))+> import Text.Regex.PDeriv.RE (RE(..))+> import Text.Regex.PDeriv.Translate (translate) ++> type EState = ()+> initEState = ()++> -- | Return either a parse error or an external pattern+> parseEPat :: String -> Either ParseError (EPat, EState)+> parseEPat x = runParser (do { pat <- p_ere+>                             ; eof+>                             ; state <- getState+>                             ; return (pat,state)+>                             } ) initEState x x++> parsePat :: String -> Either ParseError Pat+> parsePat x = case parseEPat x of+>              { Left error -> Left error+>              ; Right (epat, estate) -> Right (translate epat)+>              }++> p_ere :: CharParser EState EPat+> p_ere = liftM EOr $ sepBy1 p_branch (char '|')++> p_branch :: CharParser EState EPat+> p_branch = liftM EConcat $ many1 p_exp++> p_exp = (p_anchor <|> p_atom) >>= p_post_anchor_or_atom+>         +> p_anchor = ((char '^') >> (return ECarat))       -- '^'+>            <|>+>            ((char '$') >> (return EDollar))      -- '$'++todo '{'++> p_atom = p_group <|>+>          p_charclass <|>+>          p_dot <|>+>          p_esc_char <|>+>          p_char++> p_group = liftM EGroup $ between (char '(') (char ')') p_ere++parsing [ ... ] and [^ ... ]++> p_charclass = +>     (char '[') +>     >> ( do { char '^' +>             ; liftM ENoneOf $ p_enum -- enum ends with ']'+>             } +>          <|>+>          (liftM EAny $ p_enum)+>        )++> p_enum :: CharParser EState [Char]+> p_enum = do { initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))) +>               -- todo : why do we need this here? +>               -- answer: if not, this string can't be parsed "[]f-z]", which is any char of  ']' and  between 'f' to 'z'+>             ; chars <- many1 p_one_enum+>             ; char ']'+>             ; let chars_set = nub (sort (initial ++ (concat chars)))+>             ; return chars_set+>             }++todo: support the locale collating char class [: :] [= =] [. .]++> p_one_enum = p_range <|> p_char_set ++> p_range = try $ do  -- try is like atomically?+>           { start <- noneOf "]-"+>           ; char '-'+>           ; end <- noneOf "]"+>           ; return [ start .. end ] +>           }++> p_char_set = do +>   { c <- noneOf "]"+>   ; when (c == '-') $+>     do -- when it is a dash, it must be at the end of the [..]+>     { atEnd <- (lookAhead (char ']') >> return True) <|> (return False)+>     ; when (not atEnd) (unexpected "A dash is in the wrong place in a bracket")+>     }+>   ; return [c]+>   }+++parse the dot (all characters)++> p_dot = char '.' >> (return EDot)++parse the escaped chars++> p_esc_char = char '\\' >> anyChar >>= \c -> return (EEscape c)++parse a single non-escaped char++> p_char = noneOf specials >>= \c -> return (EChar c)+>     where specials = "^.[$()|*+?{\\"+++++> p_post_anchor_or_atom atom = +>     (try (char '?' >> char '?' >> return (EOpt atom False)) <|> (char '?' >> return (EOpt atom True)))+>     <|> (try (char '+' >> char '?' >> return (EPlus atom False)) <|> (char '+' >> return (EPlus atom True)))+>     <|> (try (char '*' >> char '?' >> return (EStar atom False)) <|> (char '*' >> return (EStar atom True)))+>     <|> p_bound_nongreedy atom+>     <|> p_bound atom +>     <|> return atom+++> p_bound_nongreedy atom = try $ between (string "{") (string "}?") (p_bound_spec atom False)++> p_bound atom = try $ between (char '{') (char '}') (p_bound_spec atom True)++> p_bound_spec atom b = do { lowS <- many1 digit+>                         ; let lowI = read lowS+>                         ; highMI <- option (Just lowI) $ try $ +>                           do { char ','+>  -- parsec note: if 'many digits' fails below then the 'try' ensures+>  -- that the ',' will not match the closing '}' in p_bound, same goes+>  -- for any non '}' garbage after the 'many digits'.+>                              ; highS <- many digit+>                              ; if null highS then return Nothing -- no upper bound+>                                else do { let highI = read highS+>                                        ; guard (lowI <= highI)+>                                        ; return (Just (read highS))+>                                        }+>                              }+>                         ; return (EBound atom lowI highMI b)+>                         }+++
+ Text/Regex/PDeriv/Pretty.lhs view
@@ -0,0 +1,4 @@+> module Text.Regex.PDeriv.Pretty where++> class Pretty a where+>     pretty :: a -> String
+ Text/Regex/PDeriv/RE.lhs view
@@ -0,0 +1,148 @@++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+>     FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} ++> module Text.Regex.PDeriv.RE where++> import Data.List (nub)+> import Data.Char (chr)++> import Text.Regex.PDeriv.Common (IsEmpty(..), IsGreedy(..), GFlag(..))+> import Text.Regex.PDeriv.Dictionary (Key(..), primeL, primeR)++------------------------++> -- | data type of the regular expresions+> data RE = Phi +>  | Empty        -- ^ an empty exp+>  | L Char	  -- ^ a literal / a character+>  | Choice RE RE GFlag -- ^ a choice exp 'r1 + r2'+>  | Seq RE RE     -- ^ a pair exp '(r1,r2)'+>  | Star RE GFlag -- ^ a kleene's star exp 'r*'+>  | Any           -- ^ .+>  | Not [Char]    -- ^ excluding characters e.g. [^abc]++> -- | the eq instance+> instance Eq RE where+>     (==) Empty Empty = True+>     (==) (L x) (L y) = x == y+>     (==) (Choice r1 r2 g1) (Choice r3 r4 g2) = (g1 == g2) && (r2 == r4) && (r1 == r3) +>     (==) (Seq r1 r2) (Seq r3 r4) = (r1 == r3) && (r2 == r4)+>     (==) (Star r1 g1) (Star r2 g2) = g1 == g2 && r1 == r2 +>     (==) Any Any = True+>     (==) (Not cs) (Not cs') = cs == cs'+>     (==) _ _ = False+++> -- | A pretty printing function for regular expression+> instance Show RE where+>     show Phi = "{}"+>     show Empty = "<>"+>     show (L c) = show c+>     show (Choice r1 r2 g) = "(" ++ show r1 ++ "|" ++ show r2 ++ ")" ++ show g+>     show (Seq r1 r2) = "<" ++ show r1 ++ "," ++ show r2 ++ ">"+>     show (Star r g) = show r ++ "*" ++ show g+>     show Any = "."+>     show (Not cs) = "[^" ++ cs ++ "]"++> instance IsGreedy RE where+>     isGreedy Phi = True+>     isGreedy Empty = False+>     isGreedy (Choice r1 r2 Greedy) = True+>     isGreedy (Choice r1 r2 NotGreedy) = False -- (isGreedy r1) || (isGreedy r2)+>     isGreedy (Seq r1 r2) = (isGreedy r1) || (isGreedy r2)+>     isGreedy (Star r Greedy) = True+>     isGreedy (Star r NotGreedy) = False+>     isGreedy (L _) = True+>     isGreedy Any = True+>     isGreedy (Not _) = True++> instance Key RE where+>     hash Phi = [0]+>     hash Empty = [1]+>     hash (Choice r1 r2 Greedy) = {- let x1 = head (hash r1)+>                                      x2 = head (hash r2)+>                                  in [ 3 +  x1 * primeL + x2 * primeR ] -} [3]+>     hash (Choice r1 r2 NotGreedy) = {- let x1 = head (hash r1)+>                                         x2 = head (hash r2)+>                                     in [ 4 + x1 * primeL + x2 * primeR ] -} [4]+>     hash (Seq r1 r2) = {- let x1 = head (hash r1)+>                            x2 = head (hash r2)+>                        in [ 5 + x1 * primeL + x2 * primeR ] -} [5]+>     hash (Star r Greedy) = {- let x = head (hash r)+>                            in [ 6 + x * primeL ] -} [6]+>     hash (Star r NotGreedy) = {- let x = head (hash r)+>                             in [ 7 + x * primeL ] -} [7]+>     hash (L c) = {- let x = head (hash c)+>                  in [ 8 + x * primeL ] -} [8]+>     hash Any = [2]+>     hash (Not _) = [9]++++> -- | function 'resToRE' sums up a list of regular expressions with the choice operation.+> resToRE :: [RE] -> RE+> resToRE (r:res) = foldl (\x y -> Choice x y Greedy) r res+> resToRE [] = Phi++> -- | function 'isEmpty' checks whether regular expressions are empty+> instance IsEmpty RE where+>   isEmpty Phi = False+>   isEmpty Empty = True+>   isEmpty (Choice r1 r2 g) = (isEmpty r1) || (isEmpty r2)+>   isEmpty (Seq r1 r2) = (isEmpty r1) && (isEmpty r2)+>   isEmpty (Star r g) = True+>   isEmpty (L _) = False+>   isEmpty Any = False+>   isEmpty (Not _) = False+        ++> -- | function 'partDeriv' implements the partial derivative operations for regular expressions. We don't pay attention to the greediness flag here.+> partDeriv :: RE -> Char -> [RE]+> partDeriv r l = nub (partDerivSub r l)+++> partDerivSub Phi l = []+> partDerivSub Empty l = []+> partDerivSub (L l') l +>     | l == l'   = [Empty]+>     | otherwise = []+> partDerivSub Any l = [Empty]+> partDerivSub (Not cs) l +>     | l `elem` cs = []+>     | otherwise = [Empty]+> partDerivSub (Choice r1 r2 g) l = +>     let +>         s1 = partDerivSub r1 l +>         s2 = partDerivSub r2 l+>     in {- s1 `seq` s2 `seq` -} (s1 ++ s2)+> partDerivSub (Seq r1 r2) l +>     | isEmpty r1 = +>           let +>               s0 = partDerivSub r1 l+>               s1 = s0 `seq` [ (Seq r1' r2) | r1' <- s0 ]+>               s2 = partDerivSub r2 l+>           in {- s1 `seq` s2 `seq` -} (s1 ++ s2)+>     | otherwise = +>         let +>             s0 = partDerivSub r1 l +>         in {- s0 `seq` -} [ (Seq r1' r2) | r1' <- s0 ]+> partDerivSub (Star r g) l = +>     let+>         s0 = partDerivSub r l+>     in {- s0 `seq` -} [ (Seq r' (Star r g)) | r' <- s0 ]++> -- | function 'sigmaRE' returns all characters appearing in a reg exp.+> sigmaRE :: RE -> [Char]+> sigmaRE r = let s = (sigmaREsub r)+>             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 (Seq r1 r2) = (sigmaREsub r1) ++ (sigmaREsub r2) +> sigmaREsub (Choice r1 r2 g) = (sigmaREsub r1) ++ (sigmaREsub r2) +> sigmaREsub (Star r g) = sigmaREsub r+> sigmaREsub Phi = []+> sigmaREsub Empty = []+
+ Text/Regex/PDeriv/Translate.lhs view
@@ -0,0 +1,485 @@+> -- | A translation schema from the external syntax (ERE) to our interal syntax (xhaskell style pattern)+> module Text.Regex.PDeriv.Translate +>     ( translate ) where++> import Control.Monad.State -- needed for the translation scheme+> import Data.Char (chr)++> import Text.Regex.PDeriv.ExtPattern+> import Text.Regex.PDeriv.IntPattern+> import Text.Regex.PDeriv.RE+> import Text.Regex.PDeriv.Common+++> -- | A state monad in which we can assign number to groups and non-groups.+> data TState = TState { ngi :: NGI   -- ^ negative group index+>                      , gi :: GI     -- ^ (positive) group index+>                      , anchorStart :: Bool+>                      , anchorEnd :: Bool } -- the state for trasslation+>             deriving Show+++> -- variables 0,-1,-2 are reserved for pre, main and post!+> initTState = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False } ++> type NGI = Int -- the non group index++> type GI = Int -- the group index++getters and putters++> getNGI :: State TState NGI+> getNGI = do { st <- get+>             ; return $ ngi st+>             }++> getIncNGI :: State TState NGI -- get then increase+> getIncNGI = do { st <- get+>                ; let i = ngi st+>                ; put st{ngi=(i-1)} +>                ; return i+>                }++> getGI :: State TState GI+> getGI = do { st <- get+>            ; return $ gi st+>            }++> getIncGI :: State TState GI -- get then increase +> getIncGI = do { st <- get+>               ; let i = gi st+>               ; put st{gi=(i+1)}+>               ; return i+>               }++> getAnchorStart :: State TState Bool+> getAnchorStart = do { st <- get+>                     ; return (anchorStart st)+>                     }++> setAnchorStart :: State TState ()+> setAnchorStart = do { st <- get+>                     ; put st{anchorStart=True}+>                     }++> getAnchorEnd :: State TState Bool+> getAnchorEnd  = do { st <- get+>                    ; return (anchorEnd st)+>                    }++> setAnchorEnd :: State TState ()+> setAnchorEnd = do { st <- get+>                   ; put st{anchorEnd=True}+>                   }++++> -- | Translating external pattern to internal pattern+> translate :: EPat -> Pat+> translate epat = case runState (trans epat) initTState of+>                  (pat, state) ->+>                    let hasAnchorS = anchorStart state+>                        hasAnchorE = anchorEnd state+>                    in case (hasAnchorS, hasAnchorE) of+>                       (True, True) -> pat -- PVar 0 [] pat +>                       (True, False) -> PPair pat (PVar (-2) [] (PE (Star Any Greedy)))+>                       (False, True) -> PPair (PVar (-1) [] (PE (Star Any NotGreedy))) pat+>                       (False, False) -> PPair (PVar (-1) [] (PE (Star Any NotGreedy))) (PPair pat (PVar (-2) [] (PE (Star Any Greedy))))++> {-| 'trans' The top level translation scheme e ~> p+>     There are two sub rules.+>     e ~>_p p+>     and+>     e ~>_r r+>     which are fired depending on whether e has Group pattern (...) (i.e. pattern variable)+> -}+> trans :: EPat -> State TState Pat+> trans epat | hasGroup epat = p_trans epat+>            | otherwise     = do { r <- r_trans epat+>                                 ; return (PE r)+>                                 }+++> {-| 'p_trans' implementes the rule 'e ~>_p p'+> convention:+> a,b are non group indices.+> x,y,z are group indices+> -}+> p_trans :: EPat -> State TState Pat+> p_trans epat = +>     case epat of+>       -- ^ we might not need this here.+>       -- () ~>_p ()+>     { EEmpty ->+>       do { return ( PE Empty )+>          }+>       {-|+>         e ~> p+>         -----------------+>         ( e ) ~>_p x :: p+>       -}+>     ; EGroup e ->+>       do { i <- getIncGI+>          ; p <- trans e+>          ; return ( PVar i [] p)+>          }+>     ; EOr es -> +>         {-|+>           e1 ~> p1  e2 ~> p2+>           -------------------+>             e1|e2 ~>_p p1|p2+>          -}+>       do { ps <- mapM trans es+>          ; case ps of+>            { (p':ps') -> +>               return (foldl (\xs x -> PChoice xs x Greedy) p' ps')+>            ; [] -> error "an empty choice enountered." -- todo : capture the error in the monad state+>            }+>          }+>     ; EConcat es ->+>         {-| +>            e1 ~> p1  e2 ~> p2+>            ---------------------+>              (e1,e2) ~>_p (p1,p2)+>          -} +>         do { ps <- mapM trans es+>            ; case reverse ps of  -- to make sure it is right assoc+>              { (p':ps') -> +>                    return (foldl (\xs x -> PPair x xs) p' ps')+>              ; [] -> error "an empty sequence enountered." -- todo : capture the error in the moand state+>              }+>            }+>     ; EOpt e b ->+>       {-| +>          todo : not sure whether this makes sense+>            e ~> p+>          -------------------+>            e? ~>_p p|()+>        -}+>       do { p <- trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (PChoice p (PE Empty) g)+>          }+>     ; EPlus e b ->+>       {-| +>            e ~> p+>          -------------------+>            p+ ~>_p (p,p*)+>        -}+>       do { p <- trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (PPair p (PStar p g))+>          }+>     ; EStar e b -> +>       {-| +>            e ~> p+>          -------------------+>            e*~>_p p*+>        -}+>       do { p <- trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (PStar p g)+>          }+>     ; EBound e low (Just high) b ->+>         {-| we could have relax this rule to e ~> p+>             e ~>_r r  +>             r1 = take l (repeat r)+>             r2 = take (h-l) (repeat r?)+>             r' = (r1,r2)+>           -------------------------------------+>             e{l,h} ~> a :: r' +>          -}+>       do { r <- r_trans e+>          ; i <- getIncNGI+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>                r1s = take low $ repeat r+>                r1 = case r1s of +>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r2s = take (high - low) $ repeat (Choice r Empty g)+>                r2 = case r2s of+>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r3 = case (r1,r2) of +>                       (Empty, Empty) -> Empty+>                       (Empty, _    ) -> r2+>                       (_    , Empty) -> r1+>                       (_    , _    ) -> Seq r1 r2+>                p = PVar i [] (PE r3)+>          ; return p+>          }+>     ; EBound e low Nothing b ->+>         {-|+>             e ~>_r r  +>             r1 = take l (repeat r)+>             r' = (r1,r*)+>           -------------------------------------+>             e{l,} ~> a :: r' +>          -}+>       do { r <- r_trans e+>          ; i <- getIncNGI+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>                r1s = take low $ repeat r+>                r1 = case r1s of +>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r2 = Seq r1 (Star r g)+>                p = PVar i [] (PE r2)+>          ; return p+>          }+>     ; ECarat -> +>       -- currently we anchor the entire expression +>       -- regardless of where ^ appears, we turn the subsequent+>       -- ECarat into literal,+>       do { f <- getAnchorStart+>          ; if f +>            then do { i <- getIncNGI -- not the first carat+>                    ; let r = L '^'+>                          p = PVar i [] (PE r)+>                    ; return p+>                    }+>            else do { setAnchorStart -- the first carat+>                    ; i <- getIncNGI+>                    ; let r = Empty+>                          p = PVar i [] (PE r)+>                    ; return p+>                    }+>          }+>     ; EDollar -> +>           -- similar to carat, except that we will not treat+>           -- the subsequent EDollar as literal.+>       do { f <- getAnchorEnd+>          ; if f+>            then return ()+>            else setAnchorEnd+>          ; i <- getIncNGI+>          ; let r = Empty+>                p = PVar i [] (PE r)+>          ; return p+>          }+>     ; EDot -> +>         -- |  . ~> a :: \Sigma +>         -- we might not need this rule+>       do { i <- getIncNGI+>          ; let r = anychar+>                p = PVar i [] (PE r)+>          ; return p+>         }+>     ; EAny cs ->+>         -- | [ abc ] ~> a :: 'a'|'b'|'c' +>         -- we might not need this rule+>       do { i <- getIncNGI+>          ; let -- r = char_list_to_re cs+>                r = Any+>                p = PVar i [] (PE r)+>          ; return p+>          }+>     ; ENoneOf cs ->+>         -- | [^ abc] ~> a :: \Sigma - 'a'|'b'|'c' +>         -- we might not need this rule+>       do { i <- getIncNGI+>          ; let -- r = char_list_to_re (filter (\c -> not (c `elem` cs )) sigma)+>                r = Not cs+>                p = PVar i [] (PE r)+>          ; return p+>          }+>     ; EEscape c ->+>         -- | \\c ~> a :: L c +>         -- we might not need this rule+>       do { i <- getIncNGI +>          ; let p = PVar i [] (PE (L c))+>          ; return p +>          }+>     ; EChar c ->+>         -- | c ~> a :: L c+>         -- we might not need this rule+>       do { i <- getIncNGI+>          ; let p = PVar i [] (PE (L c))+>          ; return p+>          }+>     }+++> char_list_to_re (c:cs) = foldl (\ r c' -> Choice r (L c') Greedy) (L c) cs+> char_list_to_re [] = error "char_list_to_re expects non-empty list"++> alphas = char_list_to_re (['a'..'z'] ++ ['A'..'Z'])++> digits = char_list_to_re ['0'..'9']++> sigma = map chr [0 .. 255]++> anychar = char_list_to_re sigma+++e ~>_r r+++> r_trans :: EPat -> State TState RE+> r_trans e = +>     case e of +>     { EEmpty -> +>       {-|+>         () ~>_r ()+>        -}+>       return Empty+>     ; EGroup e ->+>       {-| we might not need this rule+>          e ~> r+>         ----------+>         (e) ~> r+>        -}+>       r_trans e+>     ; EOr es ->+>       {-|+>         e1 ~>_r r1 e2 ~>_r r2+>       -------------------+>         e1|e2 ~>_r r1|r2+>        -}+>       do { rs <- mapM r_trans es+>          ; case rs of+>            { [] -> return Phi+>            ; (r:rs) -> return (foldl (\ xs x -> Choice xs x Greedy) r rs)+>            }+>          }+>     ; EConcat es ->+>       {-|+>         e1 ~>_r r1  e2 ~>_r r2+>        ----------------------+>         (e1,e2) ~>_r (r1,r2)+>        -}+>       do { rs <- mapM r_trans es+>          ; case rs of+>            { [] -> return Empty+>            ; (r:rs) -> return (foldl (\ xs x -> Seq xs x) r rs)+>            }+>          }+>     ; EOpt e b -> +>       {-|+>           e ~>_r r+>         -----------+>           e? ~>_r r?+>        -}+>       do { r <- r_trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (Choice r Empty g)+>          }+>     ; EPlus e b -> +>       {-|+>         e ~>_r r+>         ---------------+>           e+ ~>_r (r,r*)+>        -}+>       do { r <- r_trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (Seq r (Star r g))+>          }+>     ; EStar e b -> +>       {-|+>         e ~>_r r+>         ----------------+>           e* ~>_r r*+>        -}+>       do { r <- r_trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>          ; return (Star r g)+>          }+>     ; EBound e low (Just high) b ->+>       {-|+>         e ~>_r r+>         r1 = take l (repeat r)+>         r2 = take (h-l) (repeat r?)+>         r' = (r1,r2)         +>         -----------------+>           e{l:h} => r'+>        -}+>       do { r <- r_trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>                r1s = take low $ repeat r+>                r1 = case r1s of+>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r2s = take (high - low) $ repeat (Choice r Empty g)+>                r2 = case r2s of+>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r3 = case (r1,r2) of+>                       (Empty, Empty) -> Empty+>                       (Empty, _    ) -> r2+>                       (_    , Empty) -> r1+>                       (_    , _    ) -> Seq r1 r2+>          ; return r3+>          }+>     ; EBound e low Nothing b -> +>         {-|+>             e ~>_r r  +>             r1 = take l (repeat r)+>             r' = (r1,r*)+>           -------------------------------------+>             e{l,} => r' +>          -}+>       do { r <- r_trans e+>          ; let g | b = Greedy+>                  | otherwise = NotGreedy+>                r1s = take low $ repeat r+>                r1 = case r1s of +>                     { [] -> Empty+>                     ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+>                     }+>                r2 = Seq r1 (Star r g)+>          ; return r2+>          }+>     ; ECarat -> +>       -- currently we anchor the entire expression +>       -- regardless of where ^ appears, we turn the subsequent+>       -- ECarat into literal,+>       do { f <- getAnchorStart+>          ; if f +>            then return (L '^') -- not the first carat+>            else do { setAnchorStart -- the first carat+>                    ; return Empty+>                    }+>          }+>     ; EDollar -> +>           -- similar to carat, except that we will not treat+>           -- the subsequent EDollar as literal.+>       do { f <- getAnchorEnd+>          ; if f+>            then return ()+>            else setAnchorEnd+>          ; return Empty+>          }+>     ; EDot -> +>         -- | . ~>_r \Sigma+>         -- return anychar+>         return Any+>     ; EAny cs ->+>         -- | [ abc ] ~>_r 'a'|'b'|'c'+>         return (char_list_to_re cs)+>     ; ENoneOf cs ->+>         -- | [^ abc] ~>_r \Sigma - 'a'|'b'|'c'+>         -- return $ char_list_to_re (filter (\c -> not (c `elem` cs )) sigma)+>         return (Not cs)+>     ; EEscape c ->+>         -- | \\c ~>_r c+>         return $ L c+>     ; EChar c ->+>         -- | c ~>_r c+>         return $ L c+>     }+>           +
+ Text/Regex/PDeriv/Word.lhs view
@@ -0,0 +1,12 @@+> module Text.Regex.PDeriv.Word where++> -- | the Word type class+> class Word a where+>     uncons :: a -> Maybe (Char,a)+>     take :: Int -> a -> a+>     drop :: Int -> a -> a+>     empty :: a+>     reverse :: a -> a+>     append :: a -> a -> a+>     length :: a -> Int+
+ xhaskell-library.cabal view
@@ -0,0 +1,44 @@+Name:                   xhaskell-library+Version:                0.0.2+License:                BSD3+License-File:           LICENSE+Copyright:              Copyright (c) 2009, 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+Homepage:               http://code.google.com/p/xhaskell-library/+Package-URL:            http://darcs.haskell.org/packages/regex-unstable/xhaskell-library+Synopsis:               Replaces/Enhances Text.Regex+Description:            Regex algorithm implementation using partial derivatives+Category:               Text+Tested-With:            GHC+Build-Type:             Simple+Cabal-Version:          >= 1.2.3++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+  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.Posix+                         Text.Regex.PDeriv.Common +                         Text.Regex.PDeriv.Word+                         Text.Regex.PDeriv.ExtPattern+                         Text.Regex.PDeriv.IntPattern+                         Text.Regex.PDeriv.RE+                         Text.Regex.PDeriv.Parse		+                         Text.Regex.PDeriv.Translate+                         Text.Regex.PDeriv.Nfa			+                         Text.Regex.PDeriv.Pretty+                         Text.Regex.PDeriv.Dictionary+  Buildable:              True+  Extensions:             GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, FlexibleContexts+  GHC-Options:            -O2 +  GHC-Prof-Options:       -auto-all