diff --git a/Text/Regex/Deriv/ByteString/BitCode.hs b/Text/Regex/Deriv/ByteString/BitCode.hs new file mode 100644 --- /dev/null +++ b/Text/Regex/Deriv/ByteString/BitCode.hs @@ -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? diff --git a/Text/Regex/Deriv/ByteString/Posix.lhs b/Text/Regex/Deriv/ByteString/Posix.lhs --- a/Text/Regex/Deriv/ByteString/Posix.lhs +++ b/Text/Regex/Deriv/ByteString/Posix.lhs @@ -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 diff --git a/Text/Regex/Deriv/Common.lhs b/Text/Regex/Deriv/Common.lhs --- a/Text/Regex/Deriv/Common.lhs +++ b/Text/Regex/Deriv/Common.lhs @@ -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 = "" diff --git a/Text/Regex/Deriv/IntPattern.lhs b/Text/Regex/Deriv/IntPattern.lhs --- a/Text/Regex/Deriv/IntPattern.lhs +++ b/Text/Regex/Deriv/IntPattern.lhs @@ -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) diff --git a/Text/Regex/Deriv/RE.lhs b/Text/Regex/Deriv/RE.lhs --- a/Text/Regex/Deriv/RE.lhs +++ b/Text/Regex/Deriv/RE.lhs @@ -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 diff --git a/regex-deriv.cabal b/regex-deriv.cabal --- a/regex-deriv.cabal +++ b/regex-deriv.cabal @@ -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