regex-deriv 0.0.3 → 0.0.4
raw patch · 6 files changed
+983/−56 lines, 6 filesdep +dequeuedep +hashabledep +hashtables
Dependencies added: dequeue, hashable, hashtables
Files
- Text/Regex/Deriv/ByteString/BitCode.hs +686/−0
- Text/Regex/Deriv/ByteString/Posix.lhs +250/−42
- Text/Regex/Deriv/Common.lhs +1/−1
- Text/Regex/Deriv/IntPattern.lhs +4/−1
- Text/Regex/Deriv/RE.lhs +38/−9
- regex-deriv.cabal +4/−3
+ Text/Regex/Deriv/ByteString/BitCode.hs view
@@ -0,0 +1,686 @@+{- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2013, BSD License -}++{- A bytestring implementation of reg exp pattern matching using partial derivative / derivative+The POSIX matching policy is implemented by following the 'structure' of the reg-exp.+The pattern is follow annotated. +We do not break part the sub-pattern of the original reg, they are always grouped under the same var pattern.+-}++{-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+ BangPatterns, + FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} ++module Text.Regex.Deriv.ByteString.BitCode+ ( Regex+ , CompOption(..)+ , ExecOption(..)+ , defaultCompOpt+ , defaultExecOpt+ , compile+ , execute+ , regexec+ ) where +++import System.IO.Unsafe+import Data.IORef+import qualified Data.HashTable.IO as H+import qualified Data.Hashable as Ha+++import qualified Data.Dequeue as DQ+import Data.List +import Data.Char (ord)+import GHC.Int+import GHC.Arr +import qualified Data.IntMap as IM+import qualified Data.ByteString.Char8 as S+import qualified Data.Map as M++import Control.Monad++import Text.Regex.Base(RegexOptions(..),RegexLike(..),MatchArray)+++import Text.Regex.Deriv.RE +import Text.Regex.Deriv.Common (IsPhi(..), IsEpsilon(..))+import Text.Regex.Deriv.Pretty (Pretty(..))+import Text.Regex.Deriv.Common (Range(..), Letter, PosEpsilon(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), preBinder, subBinder, mainBinder)+-- import Text.Regex.Deriv.IntPattern (Pat(..), toBinder, Binder(..), strip, listifyBinder, Key(..))+import Text.Regex.Deriv.IntPattern (Pat(..), toBinder, Binder(..), strip, listifyBinder)+import Text.Regex.Deriv.Parse+import qualified Text.Regex.Deriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub, member, lookup, insert) ++++logger io = unsafePerformIO io++{-+type Path = [Int] +emptyP = []+appP p1 p2 = ((++) $!p1) $! p2+zero = 0+one = 1+zeroP = [0]+oneP = [1]+zeroZeroP = [0,0]+zeroOneP = [0,1]+consP = (:)+headP (x:xs) = x+unconsP (x:xs) = Just (x,xs)+unconsP [] = Nothing++nullP [] = True+nullP (_:_) = False+-}++type Path = DQ.BankersDequeue Int++-- decompose the left path and cons them into the right+rightApp :: Path -> Path -> Path +rightApp p1 p2 = case DQ.popBack p1 of+ { (Just x, p1') -> rightApp p1' (DQ.pushFront p2 x)+ ; (Nothing, _ ) -> p2+ }++-- decompose the right path and snoc them into the left+leftApp :: Path -> Path -> Path+leftApp p1 p2 = case DQ.popFront p2 of+ { (Just x, p2') -> leftApp (DQ.pushBack p1 x) p2'+ ; (Nothing, _ ) -> p1+ }+ +smartApp :: Path -> Path -> Path+smartApp p1 p2 | DQ.length p1 > DQ.length p2 = leftApp p1 p2+ | otherwise = rightApp p1 p2++singleton :: Int -> Path+singleton i = DQ.pushFront DQ.empty i+++emptyP = DQ.empty+appP p1 p2 = smartApp p1 p2+zero = 0+one = 1+zeroP = singleton zero+oneP = singleton one+zeroZeroP = DQ.fromList [zero,zero]+zeroOneP = DQ.fromList [zero,one]+consP = flip DQ.pushFront +headP p = case DQ.first p of { Just x -> x; _ -> error "headP is applied to an empty path." }+unconsP p = case DQ.popFront p of+ { (Nothing, _ ) -> Nothing+ ; (Just x , p') -> Just (x, p')+ }+nullP = DQ.null+++data U where+ Nil :: U+ EmptyU :: U+ Letter :: Char -> U+ LeftU :: U -> U+ RightU :: U -> U+ Pair :: (U,U) -> U+ List :: [U] -> U+ deriving Show+++data SPath = SChoice Path [SPath] + | SPair Path SPath SPath + | SStar Path SPath -- no need to store any SPath, but + | SL Path+ | SEps Path + | SPhi+ deriving Show++-- build empty SPath from a RE+mkSPath :: RE -> SPath +mkSPath Empty = SEps emptyP+mkSPath (L c) = SL emptyP+mkSPath (Choice [r1,r2] _) = SChoice emptyP [mkSPath r1, mkSPath r2]+mkSPath (Choice [r] _) = SChoice emptyP [mkSPath r]+mkSPath (Seq r1 r2) = SPair emptyP (mkSPath r1) (mkSPath r2)+mkSPath (Star r _) = SStar emptyP (mkSPath r)+mkSPath Phi = SPhi++mkEmpty :: RE -> SPath -> Path +mkEmpty Empty = (\x -> case x of { (SEps p) -> p })+mkEmpty (Choice [r1,r2] _ ) + | nullable r1 = let f = mkEmpty r1 + in (\(SChoice p [sp1,sp2]) -> p `appP` (consP zero (f sp1)))+ | nullable r2 = let f = mkEmpty r2+ in (\(SChoice p [sp1,sp2]) -> p `appP` (consP one (f sp2)))+mkEmpty (Choice [r] _ ) + | nullable r = let f = mkEmpty r + in (\(SChoice p [sp]) -> p `appP` (f sp))+mkEmpty (ChoiceInt [r1,r2]) + | nullable r1 = let f = mkEmpty r1+ in (\(SChoice p [sp1,sp2]) -> p `appP` (f sp1))+ | nullable r2 = let f = mkEmpty r2+ in (\(SChoice p [sp1,sp2]) -> p `appP` (f sp2))++mkEmpty (Seq r1 r2) = + let f1 = mkEmpty r1 + f2 = mkEmpty r2+ in (\ (SPair p sp1 sp2) -> p `appP` (f1 sp1) `appP` (f2 sp2))+mkEmpty (Star r _) = (\(SStar p _) -> p `appP` oneP )+++prefix :: Path -> SPath -> SPath+prefix b (SEps p) = SEps $! (b `appP` p)+prefix b (SL p) = SL $! (b `appP` p)+prefix b (SChoice p [sp1,sp2]) = + let !bp = b `appP` p+ in SChoice bp $! [sp1, sp2]+prefix b (SChoice p [sp]) = let !bp = b `appP` p in SChoice bp $! [sp]+prefix b (SPair p sp1 sp2) = let !bp = b `appP` p in SPair bp sp1 sp2+prefix b (SStar p sp) = let !bp = b `appP` p in SStar bp sp++nullable = posEpsilon+ +deriv :: RE -> Char -> (RE, SPath -> SPath)+deriv Phi l = (Phi, \_ -> SPhi)+deriv Empty l = (Phi, \_ -> SPhi)+deriv (L l') l+ | l == l' = (Empty, \(SL p) -> (SEps p))+ | otherwise = (Phi, \_ -> SPhi)+deriv (Choice [r1,r2] gf) l = let (r1',!f1) = deriv r1 l+ (r2',!f2) = deriv r2 l+ in r1' `seq` r2' `seq` (Choice [r1',r2'] gf, \(SChoice !p [!sp1,!sp2]) -> + let !sp1' = f1 sp1 + !sp2' = f2 sp2+ in SChoice p $! [sp1',sp2'])+deriv (Choice [r] gf) l = let (r',!f) = deriv r l + in r' `seq` (Choice [r'] gf, \(SChoice !p [!sp]) -> + let !sp' = f sp + in SChoice p [sp'])+deriv (ChoiceInt [r1,r2]) l = let (r1',!f1) = deriv r1 l+ (r2',!f2) = deriv r2 l+ in r1' `seq` r2' `seq` (ChoiceInt [r1', r2'], \(SChoice !p [!sp1,!sp2]) -> + let !sp1' = f1 sp1+ !sp2' = f2 sp2 + in SChoice p $! [sp1', sp2'])+deriv (Seq r1 r2) l = let (r1', !f1) = deriv r1 l+ (r2', !f2) = deriv r2 l+ f3 = mkEmpty r1 + in r1' `seq` r2' `seq` if nullable r1+ then (ChoiceInt [(Seq r1' r2), r2'], (\(SPair !p !sp1 !sp2) -> + let !sp1' = f1 sp1+ !sp2' = f2 sp2+ !p1'' = f3 sp1+ !p' = (p `appP` p1'') + !sp' = prefix p' sp2'+ !spp12 = (SPair p sp1' sp2)+ in SChoice emptyP $! [spp12, sp' ]))+ else (Seq r1' r2, (\(SPair !p !sp1 !sp2) -> + let !sp1' = f1 sp1+ in SPair p sp1' sp2))+deriv (Star r gf) l = let (r', f) = deriv r l + in r' `seq` (Seq r' (Star r gf), \(SStar !p !sp) -> + let !sp' = f sp+ !p' = (p `appP` zeroP)+ in SPair p' sp' $! (SStar emptyP sp)) -- todo check+deriv r l = error (show r) + + +simp :: RE -> (RE, SPath -> SPath) +simp (Seq Empty r)+ | isPhi r = (Phi, \sp ->SPhi)+ | otherwise = (r, \(SPair !p1 (SEps !p2) !sp2) -> + let !p12 = p1 `appP` p2+ in prefix p12 sp2)+simp (Seq r1 r2) + | isPhi r1 || isPhi r2 = (Phi, \sp -> SPhi)+ | otherwise = let (r1', !f1) = simp r1 + (r2', !f2) = simp r2+ in r1' `seq` r2' `seq` (Seq r1' r2', \(SPair !p !sp1 !sp2) -> + let !sp1' = f1 sp1+ !sp2' = f2 sp2 + in SPair p sp1' sp2')+simp (Choice [(Choice [r1,r2] gf2), r3] gf1) = -- (r1+r2)+r3 => (r1+( push all the path info to the options under the choice+ (ChoiceInt [r1, ChoiceInt [r2,r3]], \(SChoice !p1 [SChoice !p2 [!sp1, !sp2], !sp3]) ->+ let !p' = p1 `appP` p2 `appP` zeroZeroP+ !sp1' = prefix p' sp1+ !p'' = p1 `appP` p2 `appP` zeroOneP+ !sp2' = prefix p'' sp2+ !p''' = p1 `appP` oneP+ !sp3' = prefix p''' sp3+ in SChoice emptyP [ sp1', SChoice emptyP [ sp2', sp3']])+simp (Choice [r1,r2] gf) + | r1 == r2 = (r1, \(SChoice !p [!sp1,!sp2]) -> let !p' = (p `appP` zeroP) in prefix p' sp1)+ | isPhi r1 = (r2, \(SChoice !p [!sp1,!sp2]) -> let !p' = (p `appP` oneP) in prefix p' sp2)+ | isPhi r2 = (r1, \(SChoice !p [!sp1,!sp2]) -> let !p' = (p `appP` zeroP) in prefix p' sp1)+ | otherwise = let (r1',!f1) = simp r1+ (r2',!f2) = simp r2+ in r1' `seq` r2' `seq` (Choice [r1',r2'] gf, \(SChoice !p [!sp1,!sp2]) -> + let !sp1' = f1 sp1+ !sp2' = f2 sp2 + in SChoice p [sp1', sp2'])+simp (ChoiceInt [ChoiceInt [r1,r2], r3]) = + (ChoiceInt [r1, ChoiceInt [r2,r3]], \(SChoice !p1 [SChoice !p2 [!sp1, !sp2], !sp3]) ->+ let + !p12 = (p1 `appP` p2)+ !sp1' = prefix p12 sp1 + !sp2' = prefix p12 sp2+ !sp3' = prefix p1 sp3+ in SChoice emptyP [sp1', SChoice emptyP [sp2', sp3']])+simp (ChoiceInt [r1,r2]) + | r1 == r2 = (r1, \(SChoice !p [!sp1,!sp2]) -> prefix p sp1)+ | isPhi r1 = (r2, \(SChoice !p [!sp1,!sp2]) -> prefix p sp2)+ | isPhi r2 = (r1, \(SChoice !p [!sp1,!sp2]) -> prefix p sp1)+ | otherwise = let (r1',!f1) = simp r1+ (r2',!f2) = simp r2+ in r1' `seq` r2' `seq` (ChoiceInt [r1',r2'], \(SChoice !p [!sp1,!sp2]) -> + let !sp1' = f1 sp1+ !sp2' = f2 sp2+ in SChoice p [sp1', sp2'])+simp (Star Empty gf) = (Empty, \(SStar !p1 (SEps !p2)) -> + let !p = (p1 `appP` p2 `appP` oneP)+ in SEps p) -- how likely this will be applied when p1 and p2 are non-empty paths?+-- r** ==> r*+-- tricky, because r* path p, would need to be embedded into+-- 0 p 1+-- That is, the outer Kleene star performs a single iteration+-- I'm quite sure we can do without this optimization.+-- simp (Star (Star r gf2) gf1) = (Star r gf1, \(SStar p1 (SStar p2 sp)) -> SStar (p1 `appP` p2) sp)+simp (Star r gf) | isPhi r = (Empty, \(SStar !p !sp) -> let !p' = (p `appP` oneP) in SEps p' )+ | otherwise = let (r', !f) = simp r+ in r' `seq` (Star r' gf, \(SStar !p !sp) -> let !sp' = f sp in SStar p sp')+simp (Choice [r] gf) = let (r',!f) = simp r + in r' `seq` (Choice [r'] gf, \(SChoice !p [!sp]) -> let !sp' = f sp in SChoice p [sp'])+ -- in (r', \(SChoice p [sp]) -> prefix p $ f sp) +simp r = (r, \sp -> sp) + + +simpFix :: RE -> (RE, SPath -> SPath) +simpFix r = let (r', !f) = simp r + in r' `seq` if r == r' + then (r, \sp -> sp)+ else let (r'', f') = simpFix r'+ in (r'', f' . f)+ + +builder :: [Char] + -> [ (Int,Char,Int,SPath -> SPath) ]+ -> M.Map RE Int+ -> Int+ -> [RE]+ -> ([ (Int,Char,Int, SPath -> SPath) ], M.Map RE Int)+builder sig acc_delta dict max_id curr_res + | null curr_res = (acc_delta, dict)+ | otherwise = + let new_delta = sig `seq` curr_res `seq` [ r'' `seq` r `seq` g `seq` l `seq` (r,l,r'', g) | r <- curr_res, l <- sig, let (r',f) = deriv r l, let (r'',f') = r' `seq` simpFix r', let g = f' . f] + new_res = new_delta `seq` dict `seq` nub [ r' | (r,l,r',f) <- new_delta, not (r' `M.member` dict) ]+ (dict', max_id') = new_delta `seq` dict `seq`+ foldl' (\(d,id) r -> + let io = logger (putStrLn $show (r,id+1))+ in {- io `seq` -} (M.insert r (id+1) d, id+1)) (dict, max_id) new_res+ acc_delta_next = new_delta `seq` acc_delta ++ (map (\(r,l,r',f) -> (getId dict' r, l, getId dict' r', f)) new_delta)+ in dict' `seq` max_id' `seq` new_res `seq` builder sig acc_delta_next dict' max_id' new_res+ where getId :: M.Map RE Int -> RE -> Int+ getId m r = case M.lookup r m of+ { Just i -> i+ ; Nothing -> error "getId failed: this should not happen" }+ +-- todo: move to Common.lhs +instance Ha.Hashable GFlag where + hashWithSalt salt Greedy = Ha.hashWithSalt salt (19::Int)+ hashWithSalt salt NotGreedy = Ha.hashWithSalt salt (23::Int)++instance Ha.Hashable RE where+ hashWithSalt salt Empty = Ha.hashWithSalt salt (29::Int)+ hashWithSalt salt (L x) = Ha.hashWithSalt salt (Ha.hashWithSalt 31 (Ha.hash x))+ hashWithSalt salt (Choice rs g) = Ha.hashWithSalt salt (Ha.hashWithSalt 37 (Ha.hashWithSalt (Ha.hash g) rs))+ hashWithSalt salt (Seq r1 r2) = Ha.hashWithSalt salt (Ha.hashWithSalt 41 (Ha.hashWithSalt (Ha.hash r1) r2))+ hashWithSalt salt (Star r g) = Ha.hashWithSalt salt (Ha.hashWithSalt 43 (Ha.hashWithSalt (Ha.hash g) r))+ hashWithSalt salt Any = Ha.hashWithSalt salt (47 ::Int)+ hashWithSalt salt (Not cs) = Ha.hashWithSalt salt (Ha.hashWithSalt 53 cs)+ hashWithSalt salt (ChoiceInt rs) = Ha.hashWithSalt salt (Ha.hashWithSalt 59 rs)++ +type DfaTable = IM.IntMap (Int, SPath -> SPath) ++buildDfaTable :: RE -> (DfaTable, IM.IntMap RE) -- the dfa table and the id-to-regex mapping+buildDfaTable r = + let sig = sigmaRE r+ init_dict = M.insert r 0 M.empty+ (delta, mapping) = sig `seq` init_dict `seq` builder sig [] init_dict 0 [r]+ table = delta`seq` IM.fromList (map (\(s,c,d,f) -> (my_hash s c, (d,f))) delta)+ r_mapping = mapping `seq` IM.fromList (map (\(x,y) -> (y,x)) (M.toList mapping))+ -- io = logger (mapM_ (\x -> putStrLn (show x)) (M.toList mapping))+ in table`seq` r_mapping `seq` (table,r_mapping)+ +type Word = S.ByteString+ +execDfa :: DfaTable -> Word -> [(Int, SPath)] -> [(Int, SPath)] -- list is either singleton or null, since it is a DFA+execDfa dfaTable w' [] = []+execDfa dfaTable w' currStateSPaths = + case S.uncons w' of+ Nothing -> currStateSPaths + Just (l,w) -> + let ((i,sp):_) = currStateSPaths+ k = my_hash i l+ in case IM.lookup k dfaTable of + { Nothing -> [] + ; Just (j, f) ->+ let sp' = sp `seq` f sp+ -- io = logger (putStrLn (show sp) >> putStrLn (show sp') >> putStrLn "=================")+ nextStateSPaths = {- io `seq` -} j `seq` sp' `seq` [(j,sp')]+ in nextStateSPaths `seq` w `seq`+ execDfa dfaTable w nextStateSPaths+ }+ ++execDfa2 :: IM.IntMap RE -> DfaTable -> Word -> [(Int, SPath)] -> [(Int, SPath)] -- list is either singleton or null, since it is a DFA+execDfa2 im dfaTable w' [] = []+execDfa2 im dfaTable w' currStateSPaths = + case S.uncons w' of+ Nothing -> currStateSPaths + Just (l,w) -> + let ((i,sp):_) = currStateSPaths+ k = my_hash i l+ in case IM.lookup k dfaTable of + { Nothing -> [] + ; Just (j, f) ->+ let sp' = sp `seq` f sp+ -- io = logger (putStrLn (show (im IM.! i)) >> putStrLn (show sp) >> putStrLn (show (im IM.! j)) >> putStrLn (show sp') >> putStrLn "=================")+ nextStateSPaths = {- io `seq` -} j `seq` sp' `seq` [(j,sp')]+ in nextStateSPaths `seq` w `seq`+ execDfa2 im dfaTable w nextStateSPaths+ }+++++match :: [(RE,SPath)] -> String -> [(RE,SPath)]+match [(r,sp)] (c:cs) = case deriv r c of+ { (r',f) -> let (r'',f') = simp r'+ in + match [(r', f sp)] cs+ }+match [(r,sp)] [] = [(r,sp)]++match2 :: [(RE,SPath)] -> String -> [(RE,SPath)]+match2 [(r,sp)] (c:cs) = case deriv r c of+ { (r',f) -> let (r'',f') = simp r'+ in match2 [(r'', (f'. f) sp)] cs+ }+match2 [(r,sp)] [] = [(r,sp)]+++retrieveEmpty :: RE -> SPath -> Path+retrieveEmpty Empty (SEps p) = p+retrieveEmpty (Choice [r1,r2] gf) (SChoice p [sp1, sp2]) + | nullable r1 = p `appP` (consP zero (retrieveEmpty r1 sp1))+ | nullable r2 = p `appP` (consP one (retrieveEmpty r2 sp2))+retrieveEmpty (Choice [r] gf) (SChoice p [sp]) + | nullable r = p `appP` (retrieveEmpty r sp)+retrieveEmpty (ChoiceInt [r1,r2]) (SChoice p [sp1, sp2]) + | nullable r1 = p `appP` (retrieveEmpty r1 sp1)+ | nullable r2 = p `appP` (retrieveEmpty r2 sp2)+retrieveEmpty (Seq r1 r2) (SPair p sp1 sp2) = p `appP` (retrieveEmpty r1 sp1) `appP` (retrieveEmpty r2 sp2)+retrieveEmpty (Star r gf) (SStar p sp) = p `appP` oneP+retrieveEmpty r sr = error ("retrieveEmpty failed:" ++ show (posEpsilon r) ++ (show r) ++ (show sr))+++decode2 :: RE -> Path -> (U, Path)+decode2 Phi bs = (Nil,bs)+decode2 Empty bs = (EmptyU,bs)+decode2 (L l) bs = (Letter l, bs)+decode2 sr@(Choice [r1,r2] gf) bs' = + case unconsP bs' of + Just (b, bs) | b == zero -> let (u,p) = decode2 r1 bs+ in (LeftU u, p)+ | b == one -> let (u,p) = decode2 r2 bs+ in (RightU u, p)+ Nothing -> error ("decode2 failed:" ++ show sr ++ show bs')+decode2 (Choice [r] gf) bs = decode2 r bs +decode2 (Seq r1 r2) bs = let (u1,p1) = decode2 r1 bs+ (u2,p2) = decode2 r2 p1+ in (Pair (u1,u2), p2)+decode2 (sr@(Star r gf)) bs' = + case unconsP bs' of+ Just (b, bs) | b == zero -> let (u,p1) = decode2 r bs+ (List us,p2) = decode2 sr p1+ in (List (u:us), p2)+ | b == one -> (List [],bs)+ Nothing -> error ("decode2 failed:" ++ show sr ++ show bs')+decode2 sr bs = error ("decode2 failed:" ++ show sr ++ show bs)++decode :: RE -> Path -> U+decode r bs = let (u,p) = decode2 r bs+ in if nullP p + then u+ else error "invalid bit coding"++-- assume strip p = r+extract :: Pat -> RE -> U -> [(Int,Word)]+extract (PVar i _ p) r u+ | strip p == r = [(i, flatten u)]+ | otherwise = error ("the structures of the pattern and regex are not in sync" ++ show p ++ " vs " ++ show r)+extract (PE rs) (Choice rs' _) u = [] -- not in used+extract (PStar p _) (Star r _) (List []) = []+extract (PStar p _) (Star r _) (List [u]) = extract p r u +extract p'@(PStar p _) r'@(Star r _) (List (u:us)) = extract p' r' (List us) -- we only extract the last binding+extract (PPair p1 p2) (Seq r1 r2) (Pair (u1,u2)) = extract p1 r1 u1 ++ extract p2 r2 u2+extract (PChoice [p1,p2] _) (Choice [r1,r2] _) (LeftU u) = extract p1 r1 u+extract (PChoice [p1,p2] _) (Choice [r1,r2] _) (RightU u) = extract p2 r2 u+extract (PEmpty p) Empty _ = [] -- not in used+++extractSR :: Pat -> RE -> U -> Int -> ([(Int, Range)], Int)+extractSR (PVar i _ p) r u start_index + | strip p == r = let l = S.length $ flatten u + (e,_) = extractSR p r u start_index+ in ([(i, Range start_index l)]++e , start_index + l)+ | otherwise = error ("the structures of the pattern and regex are not in sync" ++ show p ++ " vs " ++ show r)+extractSR (PE rs) (Choice rs' _) u start_index = ([],start_index) -- not in used+extractSR (PStar p _) (Star r _) (List []) start_index = ([], start_index)+extractSR (PStar p _) (Star r _) (List [u]) start_index = extractSR p r u start_index+extractSR p'@(PStar p _) r'@(Star r _) (List (u:us)) start_index = extractSR p' r' (List us) start_index -- we only extract the last binding+extractSR (PPair p1 p2) (Seq r1 r2) (Pair (u1,u2)) start_index = + let (l1, i1) = extractSR p1 r1 u1 start_index + (l2, i2) = extractSR p2 r2 u2 i1+ in (l1 ++ l2, i2)+extractSR (PChoice [p1,p2] _) (Choice [r1,r2] _) (LeftU u) start_index = extractSR p1 r1 u start_index+extractSR (PChoice [p1,p2] _) (Choice [r1,r2] _) (RightU u) start_index = extractSR p2 r2 u start_index+extractSR (PEmpty p) Empty _ start_index = ([],start_index) -- not in used+extractSR (PChoice [p] _) (Choice [r] _) u start_index = extractSR p r u start_index+extractSR p r u _ = error ("etractSR failed:" ++ (show p) ++ show r ++ show u)+++ +++flatten :: U -> Word+flatten u = S.pack (flatten' u)++flatten' :: U -> [Char]+flatten' Nil = []+flatten' EmptyU = []+flatten' (Letter c) = [c]+flatten' (LeftU u) = flatten' u+flatten' (RightU u) = flatten' u+flatten' (Pair (u1,u2)) = flatten' u1 ++ flatten' u2+flatten' (List us) = concatMap flatten' us+++compilePat :: Pat -> (DfaTable, Pat, IM.IntMap RE)+compilePat p = + let r = strip p + (dfa,im) = buildDfaTable r+ in (dfa, p, im)+ ++type Env = [(Int,Range)]++execPatMatch :: (DfaTable, Pat, IM.IntMap RE) -> Word -> Maybe Env+execPatMatch (dfa, p, im) w = + let res = dfa `seq` p `seq` im `seq` execDfa dfa w [(0, mkSPath (strip p))]+ in case res of + { [] -> Nothing+ ; [ (i, sp) ] -> + let r' = im IM.! i+ -- io = logger (putStrLn (show i)) + path = {- io `seq`-} r' `seq` sp `seq` retrieveEmpty r' sp+ r = p `seq` strip p+ -- io = logger (putStrLn (show path) >> putStrLn (show sp) >> putStrLn (show r'))+ parseTree = path `seq` decode r path+ -- io = logger (putStrLn (show path) >> putStrLn (show parseTree) >> putStrLn (show p))+ (env, _) = {- io `seq` -} parseTree `seq` extractSR p r parseTree 0 + in Just env+ }+ + +p4 = PVar 0 [] (PPair (PVar 1 [] ((PPair p_x p_y))) p_z)+ where p_x = PVar 2 [] (PE [(Choice [(L 'A'),(Seq (L 'A') (L 'B'))] Greedy)]) + p_y = PVar 3 [] (PE [(Choice [(Seq (L 'B') (Seq (L 'A') (L 'A'))), (L 'A')] Greedy)])+ p_z = PVar 4 [] (PE [(Choice [(Seq (L 'A') (L 'C')), (L 'C')] Greedy)])+ + + +-- x0 :: ( x1 :: ( x2 :: (x3:: a | x4 :: ab) | x5 :: b)* )+ + +p3 = PVar 0 [] (PStar ( PVar 1 [] ( PChoice [(PVar 2 [] (PChoice [p3,p4] Greedy)), p5] Greedy)) Greedy)+ where p3 = PVar 3 [] (PE [(L 'A')])+ p4 = PVar 4 [] (PE [(Seq (L 'A') (L 'B'))]) + p5 = PVar 5 [] (PE [(L 'B')])+ ++p0 = PVar 0 [] (PChoice [PPair (PE [Empty]) (PPair (PStar (PVar 1 [] (PChoice [PPair (PVar 2 [] (PChoice [PPair (PVar 3 [] (PE [Choice [L 'A',Seq (L 'A') (L 'B')] Greedy ])) (PVar 4 [] (PE [Choice [Seq (Seq (L 'B') (L 'A')) (L 'A'),L 'A'] Greedy ]))] Greedy)) (PVar 5 [] (PE [Choice [Seq (L 'A') (L 'C'),L 'C'] Greedy]))] Greedy)) Greedy ) (PE [Empty]))] Greedy)++p1 = PVar 0 [] (PChoice [PPair (PE [Empty]) (PPair ++ (PVar 1 [] (PChoice [PPair (PVar 2 [] (PChoice [PPair (PVar 3 [] (PE [Choice [L 'A',Seq (L 'A') (L 'B')] Greedy ])) (PVar 4 [] (PE [Choice [Seq (Seq (L 'B') (L 'A')) (L 'A'),L 'A'] Greedy ]))] Greedy)) (PVar 5 [] (PE [Choice [Seq (L 'A') (L 'C'),L 'C'] Greedy]))] Greedy)) + + (PE [Empty]))] Greedy)+++p2 = PVar 0 [] (PPair (PE [Empty]) (PPair ++ (PVar 1 [] (PChoice [PPair (PVar 2 [] (PChoice [PPair (PVar 3 [] (PE [Choice [L 'A',Seq (L 'A') (L 'B')] Greedy ])) (PVar 4 [] (PE [Choice [Seq (Seq (L 'B') (L 'A')) (L 'A'),L 'A'] Greedy ]))] Greedy)) (PVar 5 [] (PE [Choice [Seq (L 'A') (L 'C'),L 'C'] Greedy]))] Greedy)) + + (PE [Empty])) )++q2 = PVar 0 [] + (PVar 1 [] (PChoice [PPair (PVar 2 [] (PChoice [PPair (PVar 3 [] (PE [Choice [L 'A',Seq (L 'A') (L 'B')] Greedy ])) (PVar 4 [] (PE [Choice [Seq (Seq (L 'B') (L 'A')) (L 'A'),L 'A'] Greedy ]))] Greedy)) (PVar 5 [] (PE [Choice [Seq (L 'A') (L 'C'),L 'C'] Greedy]))] Greedy)) + ++++type Regex = (DfaTable, Pat, IM.IntMap RE)++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 {-# SCC "compile/parsePatPosix" #-} parsePatPosix (S.unpack bs) of+ Left err -> Left ("parseRegex for Text.Regex.Deriv.ByteString failed:"++show err)+ Right (pat,posixBnd) -> + Right (compilePat pat)+++execute :: Regex -- ^ Compiled regular expression+ -> S.ByteString -- ^ ByteString to match against+ -> Either String (Maybe Env)+execute r bs = Right (execPatMatch 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 r bs =+ case execPatMatch r bs of+ Nothing -> Right Nothing+ Just env ->+ let pre = case lookup preBinder env of { Just e -> rg_collect bs e ; Nothing -> S.empty }+ post = case lookup subBinder env of { Just e -> rg_collect bs e ; 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 ((rg_collect bs) . snd) (filter (\(v,w) -> v > mainBinder && v < subBinder ) env)+ in -- logger (print (show env)) `seq` + Right (Just (pre,main,post,matched))+++++rg_collect :: S.ByteString -> Range -> S.ByteString+rg_collect w (Range i j) = S.take (j' - i' + 1) (S.drop i' w)+ where i' = fromIntegral i+ j' = fromIntegral j++rg_collect_many w rs = foldl' S.append S.empty $ map (rg_collect w) rs+++-- | 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 +++choice r = Choice r Greedy++{-+r = choice [Seq (choice [ChoiceInt [Seq (choice [choice [Phi,ChoiceInt [Seq Phi (L 'B'),Empty]] ] ) (choice [choice [Seq (Seq (L 'B') (L 'A')) (L 'A'),L 'A'] ] )+ ,choice [choice [Seq (Seq Empty (L 'A')) (L 'A'),Phi] ] ]] ) (choice [choice [Seq (L 'A') (L 'C'),L 'C'] ] )] +++sp = SChoice [] [SPair [] (SChoice [] [SChoice [] [SPair [] (SChoice [] [SChoice [] [SPhi,SChoice [] [SPair [] SPhi (SL []),SEps []]]]) (SChoice [] [SChoice [] [SPair [] (SPair [] (SL []) (SL [])) (SL []),SL []]]) + ,SChoice [0] [SChoice [] [SPair [] (SPair [] (SEps []) (SL [])) (SL []),SPhi]]]]) + (SChoice [] [SChoice [] [SPair [] (SL []) (SL []),SL []]])]+++-- (A|AB)(BB|B)++pp1 = PVar 1 [] (PE [r1])++r1 = Seq (choice [L 'A', (Seq (L 'A') (L 'B'))]) (choice [(Seq (L 'B') (L 'B')), L 'B']) ++pp2 = PVar 1 [] (PE [r2])++r2 = Seq (choice [L 'A', Empty]) (choice [Empty, L 'A']) -}+ + +-- A?A?
Text/Regex/Deriv/ByteString/Posix.lhs view
@@ -24,6 +24,9 @@ > import System.IO.Unsafe+> import Data.IORef+> import qualified Data.HashTable.IO as H+> import qualified Data.Hashable as Ha > import Data.List @@ -43,9 +46,10 @@ > import Text.Regex.Deriv.Common (IsPhi(..), IsEpsilon(..)) > import Text.Regex.Deriv.Pretty (Pretty(..)) > import Text.Regex.Deriv.Common (Range(..), Letter, PosEpsilon(..), my_hash, my_lookup, GFlag(..), IsGreedy(..), preBinder, subBinder, mainBinder)-> import Text.Regex.Deriv.IntPattern (Pat(..), toBinder, Binder(..), strip, listifyBinder, Key(..))+> -- import Text.Regex.Deriv.IntPattern (Pat(..), toBinder, Binder(..), strip, listifyBinder, Key(..))+> import Text.Regex.Deriv.IntPattern (Pat(..), toBinder, Binder(..), strip, listifyBinder) > import Text.Regex.Deriv.Parse-> import qualified Text.Regex.Deriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub, member, lookup, insert)+> import qualified Text.Regex.Deriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub, member, lookup, insert) @@ -67,7 +71,7 @@ > ; Nothing -> IM.insert k r cf } > combineRange :: [Range] -> [Range] -> [Range]-> -- combineRange rs1 rs2 = rs1+> -- combineRange rs1 rs2 = rs1 -- this caused the bug of (.)* returning the first match instead of the last. > combineRange ((r1@(Range b1 e1)):rs1) ((r2@(Range b2 e2)):rs2) > | b1 == b2 = if e1 >= e2 > then [r1]@@ -135,11 +139,20 @@ The shapes of the input/output Pat and SBinder should be identical. -+> dPat0C :: Pat -> Char -> [(Pat, Int -> SBinder -> SBinder)]+> dPat0C p c = dPat0 p c +> {- memoization+> dPat0C p c = +> case {-# SCC "dPat0C/lookupDCache" #-} lookupDCache p c of +> { Nothing -> let r = {-# SCC "dPat0C/dPat0" #-} dPat0 p c +> io = r `seq` {-# SCC "dPat0C/insertDCache" #-} insertDCache p c r+> in io `seq` r+> ; Just r -> r } +> -} > dPat0 :: Pat -> Char -> [(Pat, Int -> SBinder -> SBinder)] -- the result is always singleton or empty > dPat0 y@(PVar x w p) l = -> do { (!p',!f) <- dPat0 p l +> do { (!p',!f) <- dPat0C p l > ; let f' !i !sb = {-# SCC "dPat0/f0" #-} case sb of > { SVar (!v,!r) !sb' !cf -> let sb'' = {-# SCC "dPat0/f0/sb''" #-} f i sb' > r' = {-# SCC "dPat0/f0/updateRange" #-} updateRange i r@@ -161,7 +174,7 @@ > if null pds then mzero > else return (PE pds, (\_ !sb -> {-# SCC "dPat0/id0" #-} sb) ) > dPat0 (PStar p g) l = -> do { (!p', !f) <- dPat0 p l +> do { (!p', !f) <- dPat0C p l > ; let emp = toSBinder p > ; emp `seq` > return (PPair p' (PStar p g), (\i sb -> {-# SCC "dPat0/f1" #-} i `seq` sb `seq` @@ -171,8 +184,8 @@ > } > dPat0 (PPair !p1 !p2) l > | (posEpsilon (strip p1)) =-> let pf1 = dPat0 p1 l -> pf2 = dPat0 p2 l+> let pf1 = dPat0C p1 l +> pf2 = dPat0C p2 l > in case (pf1, pf2) of > { ([], []) -> mzero > ; ([], [(!p2',!f2')]) ->@@ -183,7 +196,7 @@ > cf' = {-# SCC "dPat0/f3/cf'" #-}sb1' `seq` combineCF sb1' cf > sb2' = {-# SCC "dPat0/f3/sb2'" #-}f2' i sb2 > in cf' `seq` sb2' `seq` {-# SCC "dPat0/f3/carryForward" #-} carryForward cf' sb2' }-> in do { (!p2'',!f2'') <- simpFix p2'+> in do { (!p2'',!f2'') <- {-# SCC "dPat0/simpFix1" #-} simpFix p2' > ; if p2'' == p2' > then return (p2', f) > else return (p2'', \i sb -> {-# SCC "dPat0/f4" #-} @@ -196,7 +209,7 @@ > let sb1' = f1' i sb1 > in sb1' `seq` > SPair sb1' sb2 cf }-> in do { (!p1'',!f1'') <- simpFix (PPair p1' p2)+> in do { (!p1'',!f1'') <- {-# SCC "dPat0/simpFix2" #-} simpFix (PPair p1' p2) > ; if (p1'' == (PPair p1' p2)) > then return (PPair p1' p2, f) > else return (p1'', \i sb -> {-# SCC "dPat0/f6" #-} @@ -204,8 +217,8 @@ > in sb' `seq` (f1'' i sb')) > } > ; _ | isGreedy p1 -> do -> { (!p1',!f1) <- dPat0 p1 l-> ; (!p2',!f2) <- dPat0 p2 l+> { (!p1',!f1) <- pf1+> ; (!p2',!f2) <- pf2 > ; let rm = extract p1 > f !i !sb = {-# SCC "dPat0/f7" #-} case sb of > { SPair !sb1 !sb2 !cf ->@@ -215,7 +228,7 @@ > sb2' = {-# SCC "dPat0/f7/f2" #-}f2 i sb2 > sb2'' = {-# SCC "dPat0/f7/carryForward" #-}sb2' `seq` cf' `seq` carryForward cf' sb2' > in {-# SCC "dPat0/f7/in" #-} sb1'' `seq` cf `seq` sb2 `seq` sb2'' `seq` SChoice [ SPair sb1'' sb2 cf, sb2'' ] emptyCF }-> ; (!p',!f') <- simpFix (PChoice [PPair p1' p2, p2'] Greedy) +> ; (!p',!f') <- {-# SCC "dPat0/simpFix3" #-} simpFix (PChoice [PPair p1' p2, p2'] Greedy) > ; if (p' == (PChoice [PPair p1' p2, p2'] Greedy)) > then return (PChoice [PPair p1' p2, p2'] Greedy, f) > else return (p', \i sb -> {-# SCC "dPat0/f8" #-} @@ -223,8 +236,8 @@ > in sb' `seq` (f' i sb')) > } > | otherwise -> do -> { (!p1',!f1) <- dPat0 p1 l-> ; (!p2',!f2) <- dPat0 p2 l+> { (!p1',!f1) <- pf1+> ; (!p2',!f2) <- pf2 > ; let rm = extract p1 > f !i !sb = {-# SCC "dPat0/f9" #-} case sb of > { SPair !sb1 !sb2 !cf ->@@ -236,7 +249,7 @@ > sb2'' = cf1' `seq` sb2' `seq` carryForward cf1' sb2' > in sb2'' `seq` sb1'' `seq` sb2 `seq` > SChoice [sb2'', SPair sb1'' sb2 cf ] emptyCF }-> ; (!p',!f') <- simpFix (PChoice [p2' , PPair p1' p2] Greedy) +> ; (!p',!f') <- {-# SCC "dPat0/simpFix4" #-} simpFix (PChoice [p2' , PPair p1' p2] Greedy) > ; if (p' == (PChoice [p2' , PPair p1' p2] Greedy)) > then return (PChoice [p2' , PPair p1' p2] Greedy, f) > else return (p', \i sb -> {-# SCC "dPat0/f10" #-} let sb' = i `seq` sb `seq` f i sb@@ -244,11 +257,11 @@ > } > } > | otherwise =-> do { (!p1',!f1) <- dPat0 p1 l+> do { (!p1',!f1) <- dPat0C p1 l > ; let f !i !sb = {-# SCC "dPat0/f11" #-} case sb of { SPair !sb1 !sb2 !cf -> > let sb1' = f1 i sb1 > in sb1' `seq` sb2 `seq` SPair sb1' sb2 cf } -> ; (!p',!f') <- simpFix (PPair p1' p2)+> ; (!p',!f') <- {-# SCC "dPat0/simpFix5" #-} simpFix (PPair p1' p2) > ; if (p' == (PPair p1' p2)) > then return (PPair p1' p2, f) > else return (p', \i sb -> {-# SCC "dPat0/f12" #-} @@ -257,12 +270,12 @@ > } > dPat0 (PChoice [] g) l = mzero > dPat0 y@(PChoice [!p] g) l = do-> { (!p',!f') <- dPat0 p l+> { (!p',!f') <- dPat0C p l > ; let f !i !sb = {-# SCC "dPat0/f13" #-} > case sb of { SChoice [!sb'] !cf -> let sb'' = (f' i sb') in sb'' `seq` carryForward cf sb'' > ; senv -> error $ "invariance is broken: " ++ pretty y ++ " vs " ++ show senv > }-> ; (!p'',!f'') <- simpFix p'+> ; (!p'',!f'') <- {-# SCC "dPat0/simpFix6" #-} simpFix p' > ; if (p'' == p') > then return (p', f) > else return (p'', \i sb -> {-# SCC "dPat0/f14" #-} @@ -270,12 +283,12 @@ > in sb' `seq` (f'' i sb')) > } > dPat0 (PChoice !ps g) l = -> let pfs = map (\p -> p `seq` dPat0 p l) ps+> let pfs = map (\p -> p `seq` dPat0C p l) ps > nubPF :: [[(Pat, Int -> SBinder -> SBinder)]] -> [(Pat, Int -> SBinder -> SBinder)] > nubPF pfs = {-# SCC "dPat0/nubPF" #-} nub2Choice pfs M.empty > in do > { (!p,!f) <- pfs `seq` nubPF pfs-> ; (!p',!f') <- simpFix p+> ; (!p',!f') <- {-# SCC "dPat0/simpFix7" #-} simpFix p > ; if (p' == p) > then return (p, f) > else return (p', \i sb -> {-# SCC "dPat0/f15" #-} @@ -283,6 +296,8 @@ > in sb' `seq` (f' i sb')) > } ++ nub2Choice: turns a list of pattern x coercion pairs into a pchoice and a func, duplicate patterns (hence conflicting matches) are removed. @@ -384,10 +399,171 @@ > } > } +unsafe cache++> {- 16 6+> dPat0Cache :: IORef (M.Map (Char,Pat) [(Pat, Int -> SBinder -> SBinder)])+> dPat0Cache = unsafePerformIO $ do { cref <- newIORef M.empty +> ; return cref }++> insertDCache :: Pat -> Char -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertDCache p c r = unsafePerformIO $ do { m <- {-# SCC "insertDCache/readIORef" #-} readIORef dPat0Cache+> ; let m' = {-# SCC "insertDCache/insert" #-} M.insert (c,p) r m+> ; {-# SCC "insertDCache/writeIORef" #-} writeIORef dPat0Cache m' }++> lookupDCache :: Pat -> Char -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupDCache p c = unsafePerformIO $ do { m <- {-# SCC "lookupDCache/readIORef" #-} readIORef dPat0Cache+> ; case {-# SCC "lookupDCache/lookup" #-} M.lookup (c,p) m of+> { Nothing -> return Nothing +> ; Just x -> return (Just x) } }+> ++> +> +> simpCache :: IORef (M.Map Pat [(Pat, Int -> SBinder -> SBinder)])+> simpCache = unsafePerformIO $ do { cref <- newIORef M.empty +> ; return cref }++> insertSCache :: Pat -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertSCache p r = unsafePerformIO $ do { m <- readIORef simpCache+> ; let m' = M.insert p r m+> ; writeIORef simpCache m' }++> lookupSCache :: Pat -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupSCache p = unsafePerformIO $ do { m <- readIORef simpCache+> ; case M.lookup p m of+> { Nothing -> return Nothing +> ; Just x -> return (Just x) } }+> -}+++> ++> instance Ha.Hashable Pat where+> hashWithSalt salt (PVar x _ p) = Ha.hashWithSalt salt (Ha.hashWithSalt 1 $ Ha.hashWithSalt (Ha.hash x) p)+> hashWithSalt salt (PPair p1 p2) = Ha.hashWithSalt salt $ Ha.hashWithSalt 3 $ Ha.hashWithSalt (Ha.hash p1) p2+> hashWithSalt salt (PPlus p1 p2) = Ha.hashWithSalt salt $ Ha.hashWithSalt 5 $ Ha.hashWithSalt (Ha.hash p1) p2+> hashWithSalt salt (PStar p1 g) = Ha.hashWithSalt salt $ Ha.hashWithSalt 7 $ Ha.hashWithSalt (Ha.hash g) p1+> hashWithSalt salt (PE rs) = Ha.hashWithSalt salt $ Ha.hashWithSalt 11 $ Ha.hash rs +> hashWithSalt salt (PChoice ps g) = Ha.hashWithSalt salt $ Ha.hashWithSalt 13 $ Ha.hashWithSalt (Ha.hash g) ps+> hashWithSalt salt (PEmpty p) = Ha.hashWithSalt salt $ Ha.hashWithSalt 17 $ p+++> instance Ha.Hashable GFlag where +> hashWithSalt salt Greedy = Ha.hashWithSalt salt (19::Int)+> hashWithSalt salt NotGreedy = Ha.hashWithSalt salt (23::Int)++> instance Ha.Hashable RE where+> hashWithSalt salt Empty = Ha.hashWithSalt salt (29::Int)+> hashWithSalt salt (L x) = Ha.hashWithSalt salt (Ha.hashWithSalt 31 (Ha.hash x))+> hashWithSalt salt (Choice rs g) = Ha.hashWithSalt salt (Ha.hashWithSalt 37 (Ha.hashWithSalt (Ha.hash g) rs))+> hashWithSalt salt (Seq r1 r2) = Ha.hashWithSalt salt (Ha.hashWithSalt 41 (Ha.hashWithSalt (Ha.hash r1) r2))+> hashWithSalt salt (Star r g) = Ha.hashWithSalt salt (Ha.hashWithSalt 43 (Ha.hashWithSalt (Ha.hash g) r))+> hashWithSalt salt Any = Ha.hashWithSalt salt (47 ::Int)+> hashWithSalt salt (Not cs) = Ha.hashWithSalt salt (Ha.hashWithSalt 53 cs)+++> {-+> type HashTable k v = H.BasicHashTable k v --9.7 5.9+ +> +> dPat0Cache :: IORef (HashTable (Char,Pat) [(Pat, Int -> SBinder -> SBinder)])+> dPat0Cache = unsafePerformIO $ do { ht <- H.new+> ; cref <- newIORef ht+> ; return cref }+++> insertDCache :: Pat -> Char -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertDCache p c r = unsafePerformIO $ do { ht <- {-# SCC "insertDCache/readIORef" #-} readIORef dPat0Cache+> ; {-# SCC "insertDCache/insert" #-} H.insert ht (c,p) r +> ; {-# SCC "insertDCache/writeIORef" #-} writeIORef dPat0Cache ht }+++> lookupDCache :: Pat -> Char -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupDCache p c = unsafePerformIO $ do { ht <- {-# SCC "lookupDCache/readIORef" #-} readIORef dPat0Cache+> ; {-# SCC "lookupDCache/lookup" #-} H.lookup ht (c,p) }+> ++> +> simpCache :: IORef (HashTable Pat [(Pat, Int -> SBinder -> SBinder)])+> simpCache = unsafePerformIO $ do { ht <- H.new+> ; cref <- newIORef ht+> ; return cref }++> insertSCache :: Pat -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertSCache p r = unsafePerformIO $ do { ht <- readIORef simpCache+> ; H.insert ht p r+> ; writeIORef simpCache ht }++> lookupSCache :: Pat -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupSCache p = unsafePerformIO $ do { ht <- readIORef simpCache+> ; H.lookup ht p } +> -}++++> -- slowest+> dPat0Cache :: IORef (IM.IntMap [(Pat, Int -> SBinder -> SBinder)])+> dPat0Cache = unsafePerformIO $ do { cref <- newIORef IM.empty +> ; return cref }++> insertDCache :: Pat -> Char -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertDCache p c r = unsafePerformIO $ do { m <- readIORef simpCache+> ; let m' = IM.insert (Ha.hash (c,p)) r m+> ; writeIORef simpCache m' }++> lookupDCache :: Pat -> Char -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupDCache p c = unsafePerformIO $ do { m <- readIORef simpCache+> ; case IM.lookup (Ha.hash (c,p)) m of+> { Nothing -> return Nothing +> ; Just x -> return (Just x) } }++> simpCache :: IORef (IM.IntMap [(Pat, Int -> SBinder -> SBinder)])+> simpCache = unsafePerformIO $ do { cref <- newIORef IM.empty +> ; return cref }++> insertSCache :: Pat -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> insertSCache p r = unsafePerformIO $ do { m <- readIORef simpCache+> ; let m' = IM.insert (Ha.hash p) r m+> ; writeIORef simpCache m' }++> lookupSCache :: Pat -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupSCache p = unsafePerformIO $ do { m <- readIORef simpCache+> ; case IM.lookup (Ha.hash p) m of+> { Nothing -> return Nothing +> ; Just x -> return (Just x) } }++> {-+> mkKey :: Pat -> Int+> mkKey p = let s = show p+> in foldl' (\i c -> i*31 + (ord c)) 0 s +> -}++> {- collision+> simpCache :: IORef (D.Dictionary [(Pat, Int -> SBinder -> SBinder)])+> simpCache = unsafePerformIO $ do { cref <- newIORef D.empty +> ; return cref }++> cache :: Pat -> [(Pat, Int -> SBinder -> SBinder)] -> ()+> cache p r = unsafePerformIO $ do { m <- readIORef simpCache+> ; let m' = D.insertNotOverwrite p r m+> ; writeIORef simpCache m' }++> lookupCache :: Pat -> Maybe [(Pat, Int -> SBinder -> SBinder)]+> lookupCache p = unsafePerformIO $ do { m <- readIORef simpCache+> ; case D.lookup p m of+> { Nothing -> return Nothing +> ; Just x -> return (Just x) } }+> -}+> + simplification + > simpFix :: Pat -> [(Pat, Int -> SBinder -> SBinder)]-> simpFix p = simp p -- simpFix' p (\i -> id) -- simpfix' seems not neccessary+> simpFix p = +> simpC p +> -- simpFix' p (\i -> id) -- simpfix' seems not neccessary > simpFix' p f = > case simp p of@@ -400,11 +576,22 @@ > } +> simpC :: Pat -> [(Pat, Int -> SBinder -> SBinder)]+> simpC p = simp p +> {- memoization+> simpC p = +> case lookupSCache p of +> { Nothing -> let r = simp p +> io = insertSCache p r+> in io `seq` r+> ; Just r -> r }+> -}+ invariance: input / outoput of Int -> SBinder -> SBinder agree with simp's Pat input/ output > simp :: Pat -> [(Pat, Int -> SBinder -> SBinder)] -- the output list is singleton > simp (PVar !x w !p) = do-> { (!p',!f') <- simp p+> { (!p',!f') <- simpC p > ; case p' of > { _ | p == p' -> return (PVar x w p,\_ !sb -> {-# SCC "simp/id0" #-} sb) > | isPhi (strip p') -> mzero@@ -416,8 +603,8 @@ > } > } > simp y@(PPair !p1 !p2) = do-> { (!p1',!f1') <- simp p1-> ; (!p2',!f2') <- simp p2+> { (!p1',!f1') <- simpC p1+> ; (!p2',!f2') <- simpC p2 > ; case (p1',p2') of > { _ | isPhi p1' || isPhi p2' -> mzero > | isEpsilon p1' -> @@ -447,7 +634,7 @@ > } > simp (PChoice [] g) = mzero > simp (PChoice [!p] !g) = do -> { (!p',!f') <- simp p+> { (!p',!f') <- simpC p > ; if isPhi p' > then mzero > else @@ -457,10 +644,10 @@ > in return (p',f) > } > simp (PChoice !ps !g) = -> let pfs = map simp ps +> let pfs = map simpC ps > nubPF :: [[(Pat, Int -> SBinder -> SBinder)]] -> [(Pat, Int -> SBinder -> SBinder)] > nubPF pfs = nub2Choice pfs M.empty-> in pfs `seq` nubPF pfs+> in pfs `seq` {-# SCC "simp/nubPF" #-} nubPF pfs > simp p = return (p,\_ !sb -> {-# SCC "simp/id1" #-} sb) @@ -474,19 +661,21 @@ > carryForward sr sb2 = error ("trying to carry forward into a non-annotated pattern binder " ++ (show sb2)) - > instance Ord Pat where > compare (PVar x1 _ p1) (PVar x2 _ p2) -> | x1 == x2 = compare p1 p2-> | otherwise = compare x1 x2-> compare (PE r1) (PE r2) = compare r1 r2 -> compare (PStar p1 _) (PStar p2 _) = compare p1 p2 -> compare (PPair p1 p2) (PPair p3 p4) = let r = compare p1 p3 in case r of -> { EQ -> compare p2 p4+> | x1 == x2 = {-# SCC "compare1" #-} compare p1 p2+> | otherwise = {-# SCC "compare2" #-} compare x1 x2+> compare (PE r1) (PE r2) = {-# SCC "compare3" #-} compare r1 r2 +> compare (PStar p1 g1) (PStar p2 g2) = let r = {-# SCC "compare4" #-} compare g1 g2 in case r of +> { EQ -> compare p1 p2 > ; _ -> r }-> compare (PChoice ps1 _) (PChoice ps2 _) = -> compare ps1 ps2-> compare p1 p2 = compare (assignInt p1) (assignInt p2) +> compare (PPair p1 p2) (PPair p3 p4) = let r = {-# SCC "compare5" #-} compare p1 p3 in case r of +> { EQ -> {-# SCC "compare6" #-} compare p2 p4+> ; _ -> r }+> compare (PChoice ps1 g1) (PChoice ps2 g2) = let r = {-# SCC "compare7" #-} compare g1 g2 in case r of+> { EQ -> compare ps1 ps2+> ; _ -> r }+> compare p1 p2 = {-# SCC "compare8" #-} compare (assignInt p1) (assignInt p2) > where assignInt (PVar _ _ _) = 0 > assignInt (PE _) = 1 > assignInt (PStar _ _) = 2@@ -605,16 +794,26 @@ > -- let (Right (pp,posixBnd)) = parsePatPosix "(...?.?)*" > -- let (Right (pp,posixBnd)) = parsePatPosix "^(((A|AB)(BAA|A))(AC|C))$" > -- let (Right (pp,posixBnd)) = parsePatPosix "^((A)|(AB)|(B))*$" -> let (Right (pp,posixBnd)) = parsePatPosix "^((a)|(bcdef)|(g)|(ab)|(c)|(d)|(e)|(efg)|(fg))*$"-- "X(.?){1,8}Y"+> -- let (Right (pp,posixBnd)) = parsePatPosix "^((a)|(bcdef)|(g)|(ab)|(c)|(d)|(e)|(efg)|(fg))*$"-- "X(.?){1,8}Y"+> let (Right (pp,posixBnd)) = parsePatPosix "^[XY]*X([XY]?){1,2}Y[XY]*$"+> -- let (Right (pp,posixBnd)) = parsePatPosix "^.*X(.?){1,4}Y.*$"+> -- let (Right (pp,posixBnd)) = parsePatPosix "X(.?){1,4}Y" > in pp > testp2 = -> let (Right (pp,posixBnd)) = parsePatPosix "^(((A|AB)(BAA|A))(AC|C))$" -- "^((A)|(AB)|(B))*$" -- "^((a)|(bcdef)|(g)|(ab)|(c)|(d)|(e)|(efg)|(fg))*$"-- "X(.?){1,8}Y"+> let (Right (pp,posixBnd)) = parsePatPosix "X(.?){1,3}Y" > fb = followBy pp > in (pp,fb,posixBnd) +> testp3 = +> let sig = sigmaRE (strip testp)+> init_dict = M.insert testp (0::Int) M.empty+> (delta, mapping) = builder sig [] init_dict (0::Int) [testp]+> in (delta,mapping) ++ let sig = sigmaRE (strip testp) let init_dict = M.insert testp (0::Int) M.empty @@ -639,7 +838,7 @@ > let > new_delta = {-# SCC "builder/new_delta" #-} [ p `seq` p' `seq` l `seq` f' `seq` g `seq` (p,l,p',f',g) | p <- curr_pats, > l <- sig, (p',f') <- {-# SCC "builder/dPat0" #-} dPat0 p l, let g = sbinderToEnv p' ]-> new_pats = {-# SCC "builder/new_pats" #-} D.nub [ p' | (p,l,p',f',g) <- new_delta, not (p' `M.member` dict) ]+> new_pats = {-# SCC "builder/new_pats" #-} D.nub [ p' | (p,l,p',f',g) <- new_delta, not (p' `M.member` dict) ] -- todo D.nub might cause collision > (dict',max_id') = {-# SCC "builder/dict'" #-} foldl' (\(d,id) p -> (M.insert p (id+1) d, id + 1)) (dict,max_id) new_pats > acc_delta_next = {-# SCC "builder/acc_delta_next" #-} acc_delta ++ (map (\(p,l,p',f,g) -> (getId dict' p, l, getId dict' p', f, g)) new_delta) > in {- io `seq` -} builder sig acc_delta_next dict' max_id' new_pats @@ -699,6 +898,15 @@ > p4 = PVar 4 [] (PE [(Seq (L 'A') (L 'B'))]) > p5 = PVar 5 [] (PE [(L 'B')]) +(X|Y)* X (X|Y)|() ((X|Y)|())|() Y (X|Y)*+(0:(1:(2:<(3:|[(['X','Y'])*]|),<|['X']|,<(-3:|[<([([(['X','Y']),<>])]),([([([(['X','Y']),<>])]),<>])>]|),<|['Y']|,(4:|[(['X','Y'])*]|)>>>>)))++> p0 = PVar 0 [] p1+> where p1 = PVar 1 [] p2+> p2 = PVar 2 [] (PPair p3 (PPair (PE [(L 'X')]) (PPair pn3 (PPair (PE [(L 'Y')]) p4))))+> p3 = PVar 3 [] (PE [Star (Choice [L 'X', L 'Y'] Greedy) Greedy])+> pn3 = PVar (-3) [] (PE [ Seq (Choice [(Choice [Choice [L 'X', L 'Y'] Greedy, Empty] Greedy)] Greedy) (Choice [(Choice [(Choice [Choice [L 'X', L 'Y'] Greedy, Empty] Greedy), Empty] Greedy)] Greedy)])+> p4 = PVar 4 [] (PE [Star (Choice [L 'X', L 'Y'] Greedy) Greedy]) > -- | The Deriv backend spepcific 'Regex' type > -- | the IntMap keeps track of the auxillary binder generated because of posix matching, i.e. all sub expressions need to be tag
Text/Regex/Deriv/Common.lhs view
@@ -71,7 +71,7 @@ > -- | The greediness flag > data GFlag = Greedy -- ^ greedy > | NotGreedy -- ^ not greedy-> deriving Eq+> deriving (Eq,Ord) > instance Show GFlag where > show Greedy = ""
Text/Regex/Deriv/IntPattern.lhs view
@@ -27,7 +27,7 @@ > | 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.-+> deriving Show > {-| The Eq instance for Pat data type > NOTE: We ignore the 'consumed word' when comparing patterns@@ -58,8 +58,11 @@ > 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)
Text/Regex/Deriv/RE.lhs view
@@ -17,36 +17,57 @@ > | Empty -- ^ an empty exp > | L Char -- ^ a literal / a character > | Choice [RE] GFlag -- ^ a choice exp 'r1 + r2'+> | ChoiceInt [RE] -- ^ internal choice used in the BitCode version > | 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]+> deriving Show > -- | the eq instance > instance Eq RE where > (==) Empty Empty = True > (==) (L x) (L y) = x == y > (==) (Choice rs1 g1) (Choice rs2 g2) = (g1 == g2) && (rs2 == rs1) +> (==) (ChoiceInt rs1) (ChoiceInt rs2) = (rs2 == rs1) > (==) (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' +> (==) Phi Phi = True > (==) _ _ = False > instance Ord RE where-> compare Empty Empty = EQ-> compare (L x) (L y) = compare x y-> compare (Choice rs1 _) (Choice rs2 _) = compare rs1 rs2+> compare Empty Empty = {-# SCC "compare0" #-} EQ+> compare (L x) (L y) = {-# SCC "compare1" #-} compare x y+> compare (Choice rs1 _) (Choice rs2 _) = +> let l1 = length rs1 +> l2 = length rs2+> -- rs1' = reverse rs1+> -- rs2' = reverse rs2+> in if l1 == l2+> then+> {-# SCC "compare2" #-} compare rs1 rs2+> else compare l1 l2 +> compare (ChoiceInt rs1) (ChoiceInt rs2) = +> let l1 = length rs1 +> l2 = length rs2+> -- rs1' = reverse rs1+> -- rs2' = reverse rs2+> in if l1 == l2+> then+> {-# SCC "compare2" #-} compare rs1 rs2+> else compare l1 l2 > compare (Seq r1 r2) (Seq r3 r4) = -> let x = compare r1 r3 -> in case x of -> { EQ -> compare r2 r4+> let x = {-# SCC "compare3" #-} compare r1 r3+> in x `seq` case x of +> { EQ -> {-# SCC "compare4" #-} compare r2 r4 > ; _ -> x }-> compare (Star r1 _) (Star r2 _) = compare r1 r2-> compare Any Any = EQ+> compare (Star r1 _) (Star r2 _) = {-# SCC "compare5" #-} compare r1 r2+> compare Any Any = {-# SCC "compare6" #-} EQ > compare (Not cs) (Not cs') = compare cs cs'-> compare r1 r2 = compare (assignInt r1) (assignInt r2)+> compare r1 r2 = {-# SCC "compare7" #-} compare (assignInt r1) (assignInt r2) > where assignInt Empty = 0 > assignInt (L _) = 1 > assignInt (Choice _ _) = 2@@ -54,18 +75,23 @@ > assignInt (Star _ _) = 4 > assignInt Any = 5 > assignInt (Not _) = 6+> assignInt (ChoiceInt _) = 7+> assignInt Phi = 8 +> {- > -- | A pretty printing function for regular expression > instance Show RE where > show Phi = "{}" > show Empty = "<>" > show (L c) = show c > show (Choice rs g) = "(" ++ show rs ++ ")" ++ show g+> show (ChoiceInt rs) = "(i:" ++ show rs ++ ":i)" > 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@@ -112,6 +138,7 @@ > posEpsilon Phi = False > posEpsilon Empty = True > posEpsilon (Choice rs g) = any posEpsilon rs+> posEpsilon (ChoiceInt rs) = any posEpsilon rs > posEpsilon (Seq r1 r2) = (posEpsilon r1) && (posEpsilon r2) > posEpsilon (Star r g) = True > posEpsilon (L _) = False@@ -136,6 +163,8 @@ > isPhi Empty = False > isPhi (Choice [] _) = True > isPhi (Choice rs g) = all isPhi rs+> isPhi (ChoiceInt []) = True+> isPhi (ChoiceInt rs) = all isPhi rs > isPhi (Seq r1 r2) = (isPhi r1) || (isPhi r2) > isPhi (Star r g) = False > isPhi (L _) = False
regex-deriv.cabal view
@@ -1,5 +1,5 @@ Name: regex-deriv-Version: 0.0.3+Version: 0.0.4 License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2010-2013, Kenny Zhuo Ming Lu and Martin Sulzmann@@ -7,7 +7,7 @@ Maintainer: luzhuomi@gmail.com, martin.sulzmann@gmail.com Stability: Beta Homepage: http://code.google.com/p/xhaskell-regex-deriv/-Synopsis: Replaces/Enhances Text.Regex. Implementing regular expression matching using Bzozoski's Deriviative+Synopsis: Replaces/Enhances Text.Regex. Implementing regular expression matching using Brzozowski's Deriviatives Description: Regex algorithm implementation using derivatives. Category: Text Tested-With: GHC@@ -17,11 +17,12 @@ flag base4 library - Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, bytestring, deepseq+ Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, bytestring, deepseq, hashable >= 1.2.0.5, hashtables, dequeue Build-Depends: bitset, parallel Build-Depends: base >= 4.0 && < 5.0, ghc-prim Exposed-Modules: Text.Regex.Deriv.ByteString Text.Regex.Deriv.ByteString.Posix+ Text.Regex.Deriv.ByteString.BitCode Text.Regex.Deriv.Common Text.Regex.Deriv.Word Text.Regex.Deriv.ExtPattern