regex-deriv (empty) → 0.0.1
raw patch · 14 files changed
+2858/−0 lines, 14 filesdep +basedep +bitsetdep +bytestringsetup-changed
Dependencies added: base, bitset, bytestring, containers, deepseq, ghc-prim, mtl, parallel, parsec, regex-base
Files
- LICENSE +12/−0
- Setup.lhs +5/−0
- Text/Regex/Deriv/ByteString.lhs +31/−0
- Text/Regex/Deriv/ByteString/Posix.lhs +1020/−0
- Text/Regex/Deriv/Common.lhs +174/−0
- Text/Regex/Deriv/Dictionary.hs +161/−0
- Text/Regex/Deriv/ExtPattern.lhs +39/−0
- Text/Regex/Deriv/IntPattern.lhs +339/−0
- Text/Regex/Deriv/Parse.lhs +209/−0
- Text/Regex/Deriv/Pretty.lhs +4/−0
- Text/Regex/Deriv/RE.lhs +210/−0
- Text/Regex/Deriv/Translate.lhs +605/−0
- Text/Regex/Deriv/Word.lhs +12/−0
- regex-deriv.cabal +37/−0
+ LICENSE view
@@ -0,0 +1,12 @@+This modile is under this "3 clause" BSD license:++Copyright (c) 2009, Kenny Zhuo Ming Lu and Martin Sulzmann+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+ * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell+++> import Distribution.Simple(defaultMain)+> main = defaultMain
+ Text/Regex/Deriv/ByteString.lhs view
@@ -0,0 +1,31 @@+> {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009, BSD License -}++A bytestring implementation of POSIX reg exp pattern matching using derivative++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+> FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +++> module Text.Regex.Deriv.ByteString +> ( Regex+> , CompOption(..)+> , ExecOption(..)+> , defaultCompOpt+> , defaultExecOpt+> , compile+> , execute+> , regexec+> ) where ++The re-exports++> import Text.Regex.Deriv.ByteString.Posix ( Regex+> , CompOption(..)+> , ExecOption(..)+> , defaultCompOpt+> , defaultExecOpt+> , compile+> , execute+> , regexec+> ) +
+ Text/Regex/Deriv/ByteString/Posix.lhs view
@@ -0,0 +1,1020 @@+> {- 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.Posix+> ( Regex+> , CompOption(..)+> , ExecOption(..)+> , defaultCompOpt+> , defaultExecOpt+> , compile+> , execute+> , regexec+> ) where +++> import System.IO.Unsafe+++> 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.Parse+> import qualified Text.Regex.Deriv.Dictionary as D (Dictionary(..), Key(..), insertNotOverwrite, lookupAll, empty, isIn, nub, member, lookup, insert)++++> logger io = unsafePerformIO io++> type SRange = (Int,[Range])++> type CarryForward = IM.IntMap [Range] -- we only keep the first choice (i.e. the posix) hence it is always mapping one variable to one env+> emptyCF = IM.empty+++> combineCF :: CarryForward -> CarryForward -> CarryForward+> combineCF cf1 cf2 = IM.foldWithKey (\k r cf -> cf `seq` k `seq` r `seq` updateIfExist k r cf) cf2 cf1+> +> updateIfExist :: IM.Key -> [Range] -> CarryForward -> CarryForward+> updateIfExist k !r !cf = +> case IM.lookup k cf of +> { Just !r' -> IM.update (\_ -> Just (combineRange r r')) k cf+> -- { Just !r' -> IM.update (\_ -> Just r) k cf+> ; Nothing -> IM.insert k r cf }++> {-+> combineCF :: CarryForward -> CarryForward -> CarryForward+> combineCF cf1 cf2 = cf1+> -}++> {-+> combineCF :: CarryForward -> CarryForward -> CarryForward+> combineCF cf1 cf2 = let -- l = logger (print ("combining" ++ show cf1 ++ " with " ++ show cf2))+> !cf = {- l `seq` -} {-# SCC "combineCF/unionWith" #-} IM.unionWith combineRange cf1 cf2+> in cf +> -}++> {-+> combineRange :: [Range] -> [Range] -> [Range]+> combineRange rs1 rs2 = +> let rs = rs1 `seq` rs2 `seq` {-# SCC "combineRange/combineRangeAcc" #-} combineRangeAcc [] rs1 rs2 +> in rs `seq` reverse rs+++> +> combineRangeAcc :: [Range] -> [Range] -> [Range] -> [Range]+> combineRangeAcc acc [] rs2 = let rs2' = reverse rs2 in rs2' `seq` rs2' ++ acc+> combineRangeAcc acc rs1 [] = let rs1' = reverse rs1 in rs1' `seq` rs1' ++ acc+> combineRangeAcc acc ((r1@(Range b1 e1)):rs1) ((r2@(Range b2 e2)):rs2) +> | b1 == b2 && e1 >= e2 = let acc' = (Range b1 e1):acc +> in acc' `seq` combineRangeAcc acc' rs1 rs2+> | b1 == b2 && e2 >= e1 = let acc' = (Range b2 e2):acc +> in acc' `seq` combineRangeAcc acc' rs1 rs2+> | b1 == e2+1 = let acc' = (Range b2 e1):acc+> in acc' `seq` combineRangeAcc acc' rs1 rs2+> | b2 == e1+1 = let acc' = (Range b1 e2):acc+> in acc' `seq` (combineRangeAcc acc' rs1 rs2)+> | b1 > e2+1 = let acc' = (Range b2 e2):acc+> in acc' `seq` (combineRangeAcc acc' (r1:rs1) rs2)+> | b2 > e1+1 = let acc' = (Range b1 e1):acc+> in acc' `seq` (combineRangeAcc acc' rs1 (r2:rs2))+> | otherwise = error $ "unhandle combineRangeAcc:" ++ show (r1:rs1) ++ " vs " ++ show (r2:rs2)++> -}+> combineRange :: [Range] -> [Range] -> [Range]+> combineRange [] rs2 = rs2+> combineRange rs1 [] = rs1+> combineRange ((r1@(Range b1 e1)):rs1) ((r2@(Range b2 e2)):rs2) +> | b1 == b2 && e1 >= e2 = -- keeping all the discontinuated binding of p* +> {-+> let rs = combineRange rs1 rs2+> in rs `seq` (r1:rs) +> -}+> -- keeping only the last binding+> [r1]+> | b1 == b2 && e2 >= e1 = -- keeping all the discontinuated binding of p*+> {- +> let rs = combineRange rs1 rs2+> in rs `seq` (r2:rs)+> -}+> -- keeping only the last binding+> [r2]+> | b1 == e2+1 = -- keeping all the discontinuated binding of p* +> {- let r = Range b2 e1+> rs = combineRange rs1 rs2+> in r `seq` rs `seq` (r:rs)+> -}+> -- keeping only the last binding+> [r1]+> | b2 == e1+1 = -- keeping all the discontinuated binding of p* +> {- let r = Range b1 e2+> rs = combineRange rs1 rs2+> in r `seq` rs `seq` (r:rs)+> -}+> -- keeping only the last binding+> [r2]+> | b1 > e2+1 = -- keeping all the discontinuated binding of p*+> {- -- (Range b2 e2):(combineRange (r1:rs1) rs2)+> let rs1' = (r1:rs1) +> rs = rs1' `seq` combineRange rs1' rs2+> in rs `seq` (r2:rs) -}+> -- keeping only the last binding+> [r1]+> | b2 > e1+1 = -- keeping all the discontinuated binding of p*+> {- -- (Range b1 e1):(combineRange rs1 (r2:rs2))+> let rs2' = r2:rs2+> rs = rs2' `seq` combineRange rs1 rs2'+> in rs `seq` (r1:rs) -}+> -- keeping only the last binding+> [r2]+> | b1 >= b2 && e1 <= e2 = [r2]+> | b2 >= b1 && e2 <= e1 = [r1]+> | otherwise = error $ "unhandle combineRange:" ++ show (r1:rs1) ++ " vs " ++ show (r2:rs2)++++> -- -}+++> combineCFs :: [CarryForward] -> CarryForward +> combineCFs cfs = foldl' (\cf1 cf2 -> cf1 `combineCF` cf2) emptyCF cfs++> insertCF :: SRange -> CarryForward -> CarryForward +> insertCF (x,r) cf = IM.insert x r cf+++> data SBinder = SChoice [SBinder] CarryForward +> | SPair SBinder SBinder CarryForward +> | SVar SRange SBinder CarryForward+> | SStar CarryForward -- no need to store any SBinder, but +> | SRE CarryForward+> deriving Show++> toSBinder :: Pat -> SBinder+> toSBinder (PVar x w p) = SVar (x,[]) (toSBinder p) emptyCF+> toSBinder (PE rs) = SRE emptyCF+> toSBinder (PStar p g) = SStar emptyCF+> toSBinder (PPair p1 p2) = SPair (toSBinder p1) (toSBinder p2) emptyCF+> toSBinder (PChoice ps g) = SChoice (map toSBinder ps) emptyCF++++The invariance: +The shapes of the input/output Pat and SBinder should be identical.+++++> 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 +> ; 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+> r'' = {-# SCC "dPat0/f0/updateRange2" #-} r' `seq` r' +> in {-# SCC "dPat0/f0/in" #-} sb'' `seq` r'' `seq` {-# SCC "dPat0/f0/in2" #-} SVar (v, r') sb'' cf +> -- ; senv -> error $ "invariance is broken: " ++ show y ++ " vs " ++ show senv +> }+> ; (!p'',!f'') <- {-# SCC "dPat0/simpFix0" #-} simpFix (PVar x w p')+> ; if {-# SCC "dPat0/eq" #-} (p'' == (PVar x w p')) +> then return (PVar x w p', f')+> else return (p'', (\i sb -> {-# SCC "dPat0/f0'" #-} +> let sb' = sb `seq` i `seq` f' i sb+> in sb' `seq` (f'' i sb')))+> }+> dPat0 (PE rs) l = +> let pds' = (concatMap (\r -> partDeriv r l) rs)+> pds = pds' `seq` nub pds' +> in pds `seq` +> 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 +> ; let emp = toSBinder p +> ; emp `seq` +> return (PPair p' (PStar p g), (\i sb -> {-# SCC "dPat0/f1" #-} i `seq` sb `seq` +> case sb of { SStar !cf -> let sb' = f i emp +> in sb' `seq` +> SPair sb' sb cf} ) ) +> }+> dPat0 (PPair !p1 !p2) l +> | (posEpsilon (strip p1)) =+> let pf1 = dPat0 p1 l +> pf2 = dPat0 p2 l+> in case (pf1, pf2) of+> { ([], []) -> mzero+> ; ([], [(!p2',!f2')]) ->+> let rm = extract p1+> f !i !sb = {-# SCC "dPat0/f3" #-} case sb of +> { SPair !sb1 !sb2 !cf -> +> let sb1' = {-# SCC "dPat0/f3/rm" #-}rm sb1 +> 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'+> ; if p2'' == p2'+> then return (p2', f)+> else return (p2'', \i sb -> {-# SCC "dPat0/f4" #-} +> let sb' = i `seq` sb `seq` f i sb+> in sb' `seq` (f2'' i sb'))+> }+> ; ([(!p1',!f1')], []) -> -- todo+> let f !i !sb = case sb of +> { SPair !sb1 !sb2 !cf -> {-# SCC "dPat0/f5" #-} +> let sb1' = f1' i sb1 +> in sb1' `seq` +> SPair sb1' sb2 cf }+> in do { (!p1'',!f1'') <- simpFix (PPair p1' p2)+> ; if (p1'' == (PPair p1' p2))+> then return (PPair p1' p2, f)+> else return (p1'', \i sb -> {-# SCC "dPat0/f6" #-} +> let sb' = i `seq` sb `seq` f i sb+> in sb' `seq` (f1'' i sb')) +> }+> ; _ | isGreedy p1 -> do +> { (!p1',!f1) <- dPat0 p1 l+> ; (!p2',!f2) <- dPat0 p2 l+> ; let rm = extract p1+> f !i !sb = {-# SCC "dPat0/f7" #-} case sb of+> { SPair !sb1 !sb2 !cf ->+> let sb1' = {-# SCC "dPat0/f7/rm" #-} rm sb1+> sb1'' = {-# SCC "dPat0/f7/f1" #-} f1 i sb1+> cf' = {-# SCC "dPat0/f7/combineCF" #-}sb1' `seq` sb1' `combineCF` cf+> 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) +> ; 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" #-} +> let sb' = i `seq` sb `seq` f i sb +> in sb' `seq` (f' i sb')) +> }+> | otherwise -> do +> { (!p1',!f1) <- dPat0 p1 l+> ; (!p2',!f2) <- dPat0 p2 l+> ; let rm = extract p1+> f !i !sb = {-# SCC "dPat0/f9" #-} case sb of+> { SPair !sb1 !sb2 !cf ->+> let sb1' = rm sb1+> sb2' = f2 i sb2+> cf1' = sb1' `seq` cf `seq` +> sb1' `combineCF` cf+> sb1'' = f1 i sb1+> 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) +> ; 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+> in sb' `seq` (f' i sb')) +> }+> }+> | otherwise =+> do { (!p1',!f1) <- dPat0 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)+> ; if (p' == (PPair p1' p2))+> then return (PPair p1' p2, f)+> else return (p', \i sb -> {-# SCC "dPat0/f12" #-} +> let sb' = i `seq` sb `seq` f i sb +> in sb' `seq` (f' i sb'))+> }+> dPat0 (PChoice [] g) l = mzero+> dPat0 y@(PChoice [!p] g) l = do+> { (!p',!f') <- dPat0 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'+> ; if (p'' == p')+> then return (p', f)+> else return (p'', \i sb -> {-# SCC "dPat0/f14" #-} +> let sb' = i `seq` sb `seq` f i sb +> in sb' `seq` (f'' i sb')) +> }+> dPat0 (PChoice !ps g) l = +> let pfs = map (\p -> p `seq` dPat0 p l) ps+> nubPF :: [[(Pat, Int -> SBinder -> SBinder)]] -> [(Pat, Int -> SBinder -> SBinder)] +> nubPF pfs = nub2Choice pfs M.empty +> in do +> { (!p,!f) <- pfs `seq` nubPF pfs+> ; (!p',!f') <- simpFix p+> ; if (p' == p) +> then return (p, f)+> else return (p', \i sb -> {-# SCC "dPat0/f15" #-} +> let sb' = i `seq` sb `seq` f i sb +> in sb' `seq` (f' i sb')) +> }++Turns a list of pattern x coercion pairs into a pchoice and a func, duplicate patterns are removed.+The first arg is a list of list of pair, because of the list monad generated by dPat0, each non-empty sub list is a singleton list.+The resulting func accept a SChoice pattern (cf to the input list of pattern). +++-----------------------------------+{}, d |-nub PChoice {}, \i -> id+++pfs .... todo+--------------------------------------------+{[]}\cup pfs , d |-nub PChoice {}, \i -> id++> nub2Choice :: [[(Pat, Int -> SBinder -> SBinder)]] -> M.Map Pat (Int -> SBinder -> SBinder) -> [(Pat, Int -> SBinder -> SBinder)] -- the return type is a singleton list.+> nub2Choice [] pDict = return (PChoice [] Greedy, (\i !sb -> {-# SCC "nubChoice/id0" #-} sb )) -- the base case is the identity+> nub2Choice ([]:pfs) pDict = do +> { (PChoice !ps !g, !f'') <- nub2Choice pfs pDict+> ; let f' !i !sb = {-# SCC "nub2Choice/f1" #-} case sb of+> { SChoice (s:ss) !cf -> ss `seq`+> f'' i $! (SChoice ss cf)+> ; _ -> error "nub2Choice coercion is applied to a non SChoice"+> }+> ; return (PChoice ps g, f')+> } +> nub2Choice ([(!p,!f)]:pfs) !pDict -- recall the invarance of nub2Choice and dPat0, the return value of f shares the same shape of p+> | isPhi (strip p) || {-# SCC "nub2Choice/member" #-} p `M.member` pDict = do -- simplification+> { (PChoice !ps !g, !f'') <- nub2Choice pfs pDict+> ; let f' !i !sb = {-# SCC "nub2Choice/f2" #-} case sb of+> { SChoice (s:ss) !cf -> ss `seq` +> f'' i $! (SChoice ss cf)+> ; _ -> error "nub2Choice coercion is applied to a non SChoice"+> }+> ; return (PChoice ps g, f')+> } +> | otherwise = +> case p of +> { PChoice !ps' !g' -> do +> { let fs' :: [Int -> SBinder -> SBinder]+> fs' = repeat (\i !sb -> {-# SCC "nubChoice/id1" #-} sb ) -- identity functions+> pfs' = zip ps' fs'+> pfs'' = pfs' `seq` map (\x -> [x]) pfs'+> pfs''' = pfs'' `seq` pfs'' ++ pfs+> --; (p', f'') <- nub2Choice ((map (\x -> [x]) (zip ps' fs'))++pfs) pDict +> ; (!p', !f'') <- pfs''' `seq` nub2Choice pfs''' pDict+> ; let f' !i !sb = {-# SCC "nub2Choice/f3" #-} case sb of +> { (SChoice (s:ss) !cf) -> s `seq` ss `seq`+> case (f i s) of+> { SChoice !ss'' !cf' -> let ss''' = map (\x -> x `seq` carryForward cf' x) ss''+> ss'''' = ss''' `seq` (ss''' ++ ss)+> in ss'''' `seq` f'' i $ (SChoice ss'''' cf) +> ; _ -> error "nub2Choice coercion is applied to a non SChoice" }+> ; _ -> error "nub2Choice coercion is applied to a non SChoice" }+> ; return (p', f')+> }+> ; _ -> +> do+> { let pDict' = M.insert p f pDict+> ; (PChoice !ps !g, !f'') <- pfs `seq` pDict' `seq` nub2Choice pfs pDict'+> ; let f' !i !sb = {-# SCC "nub2Choice/f4" #-} case sb of+> { SChoice (s:ss) !cf -> s `seq` ss `seq` +> let (SChoice !ss' !cf') = f'' i $ (SChoice ss cf)+> s' = f i s+> ss'' = s' `seq` ss' `seq` (s':ss')+> in ss'' `seq` cf' `seq` SChoice ss'' cf'+> ; _ -> error "nub2Choice coercion is applied to a non SChoice"+> }+> ; let ps' = (p:ps)+> ; ps' `seq` return (PChoice ps' g, f')+> }+> }++simplification++> {-+> simplify :: [(Pat, Int -> SBinder -> SBinder)] -> [(Pat, Int -> SBinder -> SBinder)]+> simplify [] = []+> simplify pfs@[(PPair p1 p2, f)] +> | (isPhi (strip p1)) || (isPhi (strip p2)) = [] +> {- | (isEpsilon (strip p1)) =+> let rm = extract p1+> f i sb = case sb of { SPair sb1 sb2 cf -> let cf' = rm sb1 in carryForward (cf'++cf) sb2 }+> in [(p2,f)]+> | (isEpsilon (strip p2)) =+> let rm = extract p2+> f i sb = case sb of { SPair sb1 sb2 cf -> let cf' = rm sb2 in carryForward (cf'++cf) sb1 }+> in [(p1,f)] -}+> | otherwise = pfs+> simplify pfs = pfs+> -}++> simpFix :: Pat -> [(Pat, Int -> SBinder -> SBinder)]+> simpFix p = simp p -- simpFix' p (\i -> id) -- doto++> simpFix' p f = +> case simp p of+> { [] -> [] +> ; [(!p',!f')] ->+> if p' == p+> then [(p,f)]+> else simpFix' p' (\i sb -> let sb' = i `seq` sb `seq` f i sb+> in sb' `seq` (f' i sb))+> }+++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+> ; case p' of+> { _ | p == p' -> return (PVar x w p,\_ !sb -> {-# SCC "simp/id0" #-} sb)+> | isPhi (strip p') -> mzero+> | otherwise -> let f i sb = {-# SCC "simp/f0" #-} i `seq` sb `seq` case sb of +> { SVar !vr !sb' !cf -> let sb'' = f' i sb' +> in sb'' `seq` SVar vr sb'' cf+> }+> in return (PVar x w p', f)+> }+> }+> simp y@(PPair !p1 !p2) = do+> { (!p1',!f1') <- simp p1+> ; (!p2',!f2') <- simp p2+> ; case (p1',p2') of +> { _ | isPhi p1' || isPhi p2' -> mzero+> | isEpsilon p1' -> +> let !rm = extract p1+> f !i !sb = {-# SCC "simp/f1" #-} case sb of+> { SPair !sb1 !sb2 !cf -> let cf' = {-# SCC "simp/f1/rm" #-} rm sb1 +> cf'' = {-# SCC "simp/f1/combineCF" #-} cf' `seq` cf' `combineCF` cf+> sb2' = {-# SCC "simp/f1/f2'" #-}sb2 `seq` f2' i sb2+> in {-# SCC "simp/f1/in" #-} cf'' `seq` sb2' `seq` carryForward cf'' sb2' }+> in return (p2',f)+> | isEpsilon p2' ->+> let !rm = extract p2+> f !i !sb = {-# SCC "simp/f2" #-} case sb of +> { SPair !sb1 !sb2 !cf -> let cf' = rm sb2 +> cf'' = cf' `seq` (cf' `combineCF` cf) +> sb1' = f1' i sb1 +> in cf'' `seq` sb1' `seq` carryForward cf'' sb1' }+> in return (p1',f)+> | otherwise ->+> let f !i !sb = {-# SCC "simp/f3" #-} case sb of+> { SPair !sb1 !sb2 !cf -> let sb1' = (f1' i sb1)+> sb2' = (f2' i sb2)+> in sb1' `seq` sb2' `seq` SPair sb1' sb2' cf+> ; senv -> error $ "invariance broken: " ++ pretty y ++ " vs " ++ show senv }+> in return (PPair p1' p2', f)+> }+> }+> simp (PChoice [] g) = mzero+> simp (PChoice [!p] !g) = do +> { (!p',!f') <- simp p+> ; if isPhi p' +> then mzero+> else +> let f !i !sb = {-# SCC "simp/f4" #-}+> case sb of { SChoice [!sb'] !cf -> let sb'' = f' i sb' +> in sb'' `seq` carryForward cf sb'' }+> in return (p',f)+> }+> simp (PChoice !ps !g) = +> let pfs = map simp ps +> nubPF :: [[(Pat, Int -> SBinder -> SBinder)]] -> [(Pat, Int -> SBinder -> SBinder)] +> nubPF pfs = nub2Choice pfs M.empty+> in pfs `seq` nubPF pfs+> simp p = return (p,\_ !sb -> {-# SCC "simp/id1" #-} sb)+++> carryForward :: CarryForward -> SBinder -> SBinder+> carryForward sr (SVar (v, r) sb' cf) = let cf' = combineCF cf sr+> in cf' `seq` SVar (v, r) sb' cf'+> carryForward sr (SRE cf) = let cf' = combineCF cf sr in cf' `seq` SRE cf'+> carryForward sr (SStar cf) = let cf' = combineCF cf sr in cf' `seq` SStar cf'+> carryForward sr (SPair sb1 sb2 cf) = let cf' = combineCF cf sr in cf' `seq` SPair sb1 sb2 cf'+> carryForward sr (SChoice sbs cf) = let cf' = combineCF cf sr in cf' `seq` SChoice sbs cf'+> 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+> ; _ -> r }+> compare (PChoice ps1 _) (PChoice ps2 _) = +> compare ps1 ps2+> compare p1 p2 = compare (assignInt p1) (assignInt p2) +> where assignInt (PVar _ _ _) = 0+> assignInt (PE _) = 1+> assignInt (PStar _ _) = 2+> assignInt (PPair _ _) = 3+> assignInt (PChoice _ _) = 4+++extract a carry forward from the sbinder++> extract :: Pat -> SBinder -> CarryForward+> extract (PVar !x w !p) (SVar (_,!b) !sb !cf)+> | posEpsilon (strip p) = let cf' = extract p sb+> cf'' = cf' `seq` insertCF (x,b) cf'+> in cf'' `seq` (cf'' `combineCF` cf)+> | otherwise = IM.empty -- cf?+> extract (PE rs) (SRE !cf) = cf+> extract (PStar p g) (SStar !cf) = cf+> extract (PPair !p1 !p2) (SPair !sb1 !sb2 !cf) = let cf1 = (extract p1 sb1) +> cf2 = (extract p2 sb2) +> cf' = cf1 `seq` cf2 `seq` (combineCF cf1 cf2)+> in cf' `seq` (cf' `combineCF` cf)+> extract (PChoice !ps !g) (SChoice !sbs !cf) = let psbs = zip ps sbs +> cf' = psbs `seq` (combineCFs $! map (\(!p,!sb) -> extract p sb) psbs) +> in cf' `seq` (cf' `combineCF` cf)+> extract p sb = error $ "Error: trying to extract" ++ (show sb) ++ " from " ++ (show p)+++> updateRange :: Int -> [Range] -> [Range]+> updateRange !pos (rs_@((Range !b !e):rs)) = +> let e' = e + 1 +> in e' `seq` case e' of+> _ | pos == e' -> let r = Range b e' in r `seq` rs `seq` (r:rs)+> | pos > e' -> -- keeping all the discontinuated binding of p*+> -- let r = Range pos pos in r `seq` (r:rs_)+> -- only keep the last binding+> let r = Range pos pos in r `seq` [r]+> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter" +> updateRange !pos [] = let r = Range pos pos in r `seq` [r]+++> matchInner :: [(Pat, SBinder)] -> [(Char,Int)] -> [(Pat, SBinder)]+> matchInner pb [] = pb+> matchInner pb (l:ls) = +> do { (p,sb) <- pb +> ; (p',f) <- dPat0 p (fst l)+> ; matchInner [(p', f (snd l) sb)] ls +> }+++> type Env = [SRange]++> match :: Pat -> [Char] -> [Env]+> match p w = do { (p',sb) <- matchInner [(p, toSBinder p)] (zip w [1..]) +> ; sbinderToEnv p' sb }++> posixMatch :: Pat -> [Char] -> Maybe Env+> posixMatch p w = case match p w of+> { (e:_) -> Just e ; _ -> Nothing }+++> match2 :: (Pat,FollowBy,IM.IntMap()) -> [Char] -> [MatchArray]+> match2 (p,fb,posixBinder) w = +> map (\env -> sbinderToMatchArray (length w) fb posixBinder (IM.fromList env)) (match p w)+++get all envs from the sbinder++> sbinderToEnv :: Pat -> SBinder -> [Env]+> sbinderToEnv p sb = +> let cfs = {-# SCC "sbinderToEnv/sbinderToEnv'" #-} sbinderToEnv' p sb+> in map IM.toList cfs++> sbinderToEnv' :: Pat -> SBinder -> [CarryForward]+> sbinderToEnv' _ (SChoice [] _) = []+> sbinderToEnv' (PChoice (p:ps) g) (SChoice (sb:sbs) cf) +> | posEpsilon (strip p) = +> do { cf' <- sbinderToEnv' p sb+> ; cf `seq` cf' `seq` return (combineCF cf cf') }+> | otherwise = sbinderToEnv' (PChoice ps g) (SChoice sbs cf)+> sbinderToEnv' (PPair p1 p2) (SPair sb1 sb2 cf) =+> do { cf1 <- sbinderToEnv' p1 sb1 +> ; cf2 <- sbinderToEnv' p2 sb2+> ; cf1 `seq` cf2 `seq` cf `seq` return (combineCFs [cf1,cf2,cf]) }+> sbinderToEnv' (PVar x _ p) (SVar sr sb cf) +> | posEpsilon (strip p) = do { cf' <- sbinderToEnv' p sb+> ; let cf'' = cf' `seq` sr `seq` insertCF sr cf'+> ; cf `seq` cf'' `seq` return (cf `combineCF` cf'') }+> | otherwise = []+> sbinderToEnv' (PStar _ _) (SStar cf) = return cf+> sbinderToEnv' (PE _) (SRE cf) = return cf+> sbinderToEnv' p sb = error $ (pretty p) ++ " and " ++ (show sb)+++> {-+> sbinderToEnv :: Pat -> SBinder -> [Env]+> sbinderToEnv p sb = +> let envs = {-# SCC "sbinderToEnv/sbinderToEnv'" #-} sbinderToEnv' p sb+> envs' = {-# SCC "sbinderToEnv/sortEnvByVar'" #-} envs `seq` map sortEnvByVar envs+> in envs'++> sbinderToEnv' :: Pat -> SBinder -> [Env]+> sbinderToEnv' _ (SChoice [] _) = []+> sbinderToEnv' (PChoice (p:ps) g) (SChoice (sb:sbs) cf) +> | posEpsilon (strip p) = +> do { env <- sbinderToEnv' p sb+> ; let env' = IM.toList cf +> ; env `seq` env' `seq` return (env ++ env') }+> | otherwise = sbinderToEnv' (PChoice ps g) (SChoice sbs cf)+> sbinderToEnv' (PPair p1 p2) (SPair sb1 sb2 cf) =+> do { e1 <- sbinderToEnv' p1 sb1 +> ; e2 <- sbinderToEnv' p2 sb2+> ; let e3 = (IM.toList cf)+> ; e1 `seq` e2 `seq` e3 `seq` return (e1 ++ e2 ++ e3 ) }+> sbinderToEnv' (PVar x _ p) (SVar sr sb cf) +> | posEpsilon (strip p) = do { env <- sbinderToEnv' p sb+> ; let env' = env `seq` sr `seq` sr:env+> env'' = (IM.toList cf)+> ; env' `seq` env'' `seq` return (env' ++ env'') }+> | otherwise = []+> sbinderToEnv' (PStar _ _) (SStar cf) = let env = IM.toList cf in env `seq` [env]+> sbinderToEnv' (PE _) (SRE cf) = let env = IM.toList cf in env `seq` [env] +> sbinderToEnv' p sb = error $ (pretty p) ++ " and " ++ (show sb)+++> sortEnvByVar :: Env -> Env +> sortEnvByVar env = let im = sortEnvByVar' env IM.empty +> in map (\(i,rs) -> (i, nub (sort rs) )) (IM.toList im)++> sortEnvByVar' :: Env -> IM.IntMap [Range] -> IM.IntMap [Range]+> sortEnvByVar' [] im = im+> sortEnvByVar' ((i,rs):srgs) im = +> case IM.lookup i im of +> { Just _ -> let im' = IM.update (\rs' -> Just $ rs ++ rs') i im+> in sortEnvByVar' srgs im' +> ; Nothing -> sortEnvByVar' srgs (IM.insert i rs im) } +> -}+++> type DfaTable = IM.IntMap (Int, Int -> SBinder -> SBinder, SBinder -> [Env])+++> compilePat :: Pat -> (DfaTable,SBinder, SBinder -> [Env], [Int])+> compilePat p = let (t, sb, toEnv, finals) = buildDfaTable p +> in (t, sb, toEnv, finals)+++> buildDfaTable :: Pat -> (DfaTable, SBinder, SBinder -> [Env], [Int])+> buildDfaTable p = +> let sig = sigmaRE (strip p)+> -- init_dict = M.insert p 0 M.empty +> -- (allStates, delta, mapping) = builder sig [] [] init_dict 0 [p] -- 0 is already used by p+> init_dict = M.insert p 0 M.empty+> (delta, mapping) = {-# SCC "buildDfaTable/builder" #-} builder sig [] init_dict 0 [p] -- 0 is already used by p+> {- +> pat2id p = case M.lookup p mapping of +> { Just i -> i +> ; Nothing -> error ("pattern not found, this should not happen." ++ (show p) ++ (show (M.toList mapping))) }+> -}+> -- delta' = map (\ (s,c,d,f) -> (pat2id s, c, pat2id d, f, sbinderToEnv d) ) delta+> delta' = delta+> table = {-# SCC "buildDfaTable/table" #-} IM.fromList (map (\ (s,c,d,f,sb2env) -> (my_hash s c, (d,f,sb2env))) delta')+> -- finals = map pat2id (filter (\p -> posEpsilon (strip p) ) allStates)+> finals = [] -- todo+> in (table, toSBinder p, sbinderToEnv p, finals)++testing ++> testp = +> 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"+> 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"+> fb = followBy pp+> in (pp,fb,posixBnd)+++let sig = sigmaRE (strip testp)+let init_dict = M.insert testp (0::Int) M.empty++let (delta, mapping) = builder sig [] init_dict (0::Int) [testp]++++let (allStates, delta, mapping) = builder sig [] [] init_dict (0::Int) [testp]+mapM_ (\p -> putStrLn (show p)) (sort allStates)++> {-+> f p = +> let sig = sigmaRE (strip p)+> init_dict = M.insert p 0 M.empty +> f (allStates, delta, mapping) = builder sig [] [] init_dict 0 [p]+> pat2id p = case M.lookup p mapping of +> { Just i -> i +> ; Nothing -> error "pattern not found, this should not happen." }+> delta' = map (\ (s,c,d,f) -> (pat2id s, c, pat2id d, f, sbinderToEnv d) ) delta+> table = IM.fromList (map (\ (s,c,d,f,sb2env) -> (my_hash s c, (d,f,sb2env))) delta')+> in (map (\p -> (p, pat2id p)) allStates) -- (table, allStates, delta, delta')+> -}++> {-+> builder :: [Char] +> -> [Pat] +> -> [ (Pat,Char,Pat,Int -> SBinder -> SBinder) ] +> -> M.Map Pat Int+> -> Int+> -> [Pat]+> -> ([Pat], [ (Pat,Char,Pat,Int -> SBinder -> SBinder) ], M.Map Pat Int)+> builder sig acc_pats acc_delta dict max_id curr_pats +> | null curr_pats = (acc_pats, acc_delta, dict)+> | otherwise = +> let all_sofar_pats = acc_pats ++ curr_pats+> -- io = logger (print all_sofar_pats)+> new_delta = [ (p,l,p',f') | p <- curr_pats, l <- sig, (p',f') <- dPat0 p l ]+> new_pats = D.nub [ p' | (p,l,p',f') <- new_delta, not (p' `M.member` dict) ]+> acc_delta_next = acc_delta ++ new_delta+> (dict',max_id') = foldl' (\(d,id) p -> (M.insert p (id+1) d, id + 1)) (dict,max_id) new_pats+> in {- io `seq` -} builder sig all_sofar_pats acc_delta_next dict' max_id' new_pats +> -}+++> builder :: [Char] +> -> [ (Int,Char,Int,Int -> SBinder -> SBinder, SBinder -> [Env] ) ] +> -> M.Map Pat Int+> -> Int+> -> [Pat]+> -> ([ (Int,Char,Int,Int -> SBinder -> SBinder, SBinder -> [Env] ) ], M.Map Pat Int)+> builder sig acc_delta dict max_id curr_pats +> | null curr_pats = (acc_delta, dict)+> | otherwise = +> let -- all_sofar_pats = dict `union` fromList (zip curr_pats [(id+1)..])+> -- io = logger (print all_sofar_pats)+> 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) ]+> (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 +> where getId :: M.Map Pat Int -> Pat -> Int +> getId m p = {-# SCC "getId/M.lookup" #-} case M.lookup p m of +> { Just i -> i +> ; Nothing -> error "getId failed: this should not happen" }++> type Word = S.ByteString++> execDfa :: Int -> DfaTable -> Word -> [(Int, SBinder, SBinder -> [Env])] -> [(Int,SBinder, SBinder -> [Env])] -- the list is always singleton, since it is a dfa+> execDfa cnt dfaTable w' [] = []+> execDfa cnt dfaTable w' currDfaStateSBinders = +> case {-# SCC "execDfa/uncons" #-} S.uncons w' of+> Nothing -> currDfaStateSBinders+> Just (l,w) -> +> let ((i,sb,_):_) = {-# SCC "execDfa/currDfaStateSBinders" #-} currDfaStateSBinders+> k = {-# SCC "execDfa/my_hash" #-} my_hash i l+> in case {-# SCC "execDfa/IM.lookup" #-} IM.lookup k dfaTable of+> { Nothing -> [] -- error (" k not found " ++ show i ++ " " ++ show l)+> ; Just (j, f, sb2env) -> +> let sb' = {-# SCC "execDfa/compute_sb" #-} {- cnt `seq` -} sb `seq` f cnt sb+> nextDfaStateSBinders = {-# SCC "execDfa/nextDfaStateSBinders" #-} j `seq` sb' `seq` sb2env `seq` +> [(j, sb',sb2env)] +> cnt' = {-# SCC "execDfa/cnt'" #-} cnt + 1+> in nextDfaStateSBinders `seq` cnt' `seq` w `seq` +> execDfa cnt' dfaTable w nextDfaStateSBinders+> }++x0 :: (x1 :: ( x2 :: (ab|a), x3 :: (baa|a)), x4 :: (ac|c))++> execPatMatch :: (DfaTable, SBinder, SBinder -> [Env], [Int], FollowBy, IM.IntMap ()) -> Word -> Maybe Env+> execPatMatch (dt, init_sbinder, init_sb2env, finals, _, posixBinder) w = +> let r = {-# SCC "execDfa" #-} dt `seq` execDfa 0 dt w [(0, init_sbinder, init_sb2env)]+> in case r of +> { [] -> Nothing +> ; ((i,sb,sb2env):_) -> case (sb2env sb) of -- todo: check i `elem` finals?+> { [] -> Nothing +> ; (e:_) -> let e' = filter (\(x,_) -> x `IM.notMember` posixBinder) e +> in Just e'+> } }+++> 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')])+++> -- | 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+> -- | the FollowBy keeps track of the order of the pattern binder +> type Regex = (DfaTable, SBinder, SBinder -> [Env], [Int], FollowBy, IM.IntMap ())+++-- todo: use the CompOption and ExecOption++> compile :: CompOption -- ^ Flags (summed together)+> -> ExecOption -- ^ Flags (summed together) +> -> S.ByteString -- ^ The regular expression to compile+> -> Either String Regex -- ^ Returns: the compiled regular expression+> compile compOpt execOpt bs =+> case {-# SCC "compile/parsePatPosix" #-} parsePatPosix (S.unpack bs) of+> Left err -> Left ("parseRegex for Text.Regex.Deriv.ByteString failed:"++show err)+> Right (pat,posixBnd) -> +> Right (patToRegex pat posixBnd compOpt execOpt)+++> patToRegex p posixBnd compOpt execOpt = +> let (t, sb, toEnv, finals) = {-# SCC "patToRegex/compilePat" #-} compilePat p+> fb = {-# SCC "patToRegex/followBy" #-} followBy p+> in t `seq` sb `seq` toEnv `seq` finals `seq` fb `seq` posixBnd `seq` (t, sb, toEnv, finals, fb, posixBnd)++++> 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_many bs e ; Nothing -> S.empty }+> post = case lookup subBinder env of { Just e -> rg_collect_many 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_many 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 ++++> instance RegexLike Regex S.ByteString where +> -- matchAll :: regex -> source -> [MatchArray]+> matchAll = execPatMatchArray+> -- matchOnce :: regex -> source -> Maybe MatchArray+> matchOnce = posixPatMatchArray+> -- matchCount :: regex -> source -> Int+> -- matchTest :: regex -> source -> Bool+> -- matchAllText :: regex -> source -> [MatchText source]+> -- matchOnceText :: regex -> source -> Maybe (source, MatchText source, source)+> ++> instance RegexLike Regex String where +> -- matchAll :: regex -> source -> [MatchArray]+> matchAll r s = execPatMatchArray r (S.pack s)+> -- matchOnce :: regex -> source -> Maybe MatchArray+> matchOnce r s = posixPatMatchArray r (S.pack s)+> -- matchCount :: regex -> source -> Int+> -- matchTest :: regex -> source -> Bool+> -- matchAllText :: regex -> source -> [MatchText source]+> -- matchOnceText :: regex -> source -> Maybe (source, MatchText source, source)+++++> execPatMatchArray :: (DfaTable, SBinder, SBinder -> [Env], [Int], FollowBy, IM.IntMap ()) -> Word -> [MatchArray]+> execPatMatchArray (dt, init_sbinder, init_sb2env, finals, fb, posixBinder) w =+> let r = execDfa 0 dt w [(0, init_sbinder, init_sb2env)]+> in case r of +> { [] -> [] +> ; ((i,sb,sb2env):_) -> map (\ env -> sbinderToMatchArray (S.length w) fb posixBinder (IM.fromList env)) (sb2env sb) +> }++> updateEmptyBinder b fb = +> let +> up b (x,y) = case IM.lookup x b of +> { Just (_:_) -> -- non-empty, nothing to do+> b+> ; Just [] -> -- lookup the predecessor+> case IM.lookup y b of+> { Just r@(_:_) -> let i = snd (last r)+> in IM.update (\_ -> Just [(i,i)]) x b+> ; _ -> b }+> ; Nothing -> b }+> in foldl' up b fb++> sbinderToMatchArray l fb posixBnd b = +> let -- b' = updateEmptyBinder b fb+> subPatB = filter (\(x,_) -> x > mainBinder && x < subBinder && x `IM.notMember` posixBnd ) (listifyBinder b)+> mbPrefixB = IM.lookup preBinder b+> mbSubfixB = IM.lookup subBinder b+> mainB = case (mbPrefixB, mbSubfixB) of+> (Just [(Range _ x)], Just [(Range y _)]) -> (x, y - x)+> (Just [(Range _ x)], _) -> (x, l - x)+> (_, Just [(Range y _)]) -> (0, y) +> (_, _) -> (0, l)+> _ -> error (show (mbPrefixB, mbSubfixB) ) +> rs = map snd subPatB +> rs' = map lastNonEmpty rs+> io = logger (print $ "\n" ++ show rs ++ " || " ++ show rs' ++ "\n")+> in -- io `seq` +> listToArray (mainB:rs')+> where fromRange (Range b e) = (b, e-b+1) +> -- chris' test cases requires us to get the last result even if it is a reset point,+> -- e.g. input:"aaa" pattern:"((..)|(.))*" expected match:"(0,3)(2,3)(-1,-1)(2,3)" note that (..) matches with [(0,2),(2,2)], we return [(2,2)]+> lastNonEmpty [] = (-1,0)+> lastNonEmpty rs = fromRange (last rs)++> listToArray l = listArray (0,length l-1) l++> posixPatMatchArray :: (DfaTable, SBinder, SBinder -> [Env], [Int], FollowBy, IM.IntMap ()) -> Word -> Maybe MatchArray+> posixPatMatchArray compiled w =+> first (execPatMatchArray compiled w)+> where+> first (env:_) = return env+> first _ = Nothing+++> -- | from FollowBy, we recover the right result of the variable that bound (-1,-1) to fit Chris' test case+> ++> type FollowBy = [(Int,Int)]++> followBy :: Pat -> FollowBy+> followBy p = map (\p -> (snd p, fst p)) (fst $ buildFollowBy p ([],[]))++> -- | describe the "followedBy" relation between two pattern variable+> buildFollowBy :: Pat -> ([(Int,Int)], [Int]) -> ([(Int,Int)], [Int])+> buildFollowBy (PVar x w p) (acc, lefts) = let (acc', lefts') = buildFollowBy p (acc,lefts)+> in ([ (l,x) | l <- lefts] ++ acc', [x])+> buildFollowBy (PE r) x = x+> buildFollowBy (PStar p g) (acc, lefts) = buildFollowBy p (acc,lefts)+> buildFollowBy (PPair p1 p2) (acc, lefts) = let (acc',lefts') = buildFollowBy p1 (acc,lefts)+> in buildFollowBy p2 (acc',lefts')+> buildFollowBy (PChoice ps _) (acc, lefts) = +> foldl' (\(acc', lefts') p -> let (acc'', lefts'') = buildFollowBy p (acc',lefts) -- all choice share the same lefts comming from the parent+> in (acc'', lefts' ++ lefts'')) (acc, []) ps
+ Text/Regex/Deriv/Common.lhs view
@@ -0,0 +1,174 @@+> {-# LANGUAGE BangPatterns #-}+> -- | this module contains the defs of common data types and type classes+> module Text.Regex.Deriv.Common +> ( Range(..), range, minRange, maxRange+> , Letter+> , PosEpsilon (..)+> , IsEpsilon (..)+> , IsPhi (..)+> , Simplifiable (..)+> , my_hash+> , my_lookup+> , GFlag (..)+> , IsGreedy (..)+> , nub2+> , nub3+> , preBinder+> , preBinder_+> , subBinder+> , mainBinder+> ) where++> import Data.Char (ord)+> import qualified Data.IntMap as IM+> import qualified Data.BitSet as BS+> import Data.List (nubBy)++> -- | (sub)words represent by range+> -- type Range = (Int,Int) +> data Range = Range !Int !Int deriving (Show, Ord)++> instance Eq Range where+> (==) (Range x y) (Range w z) = (x == w) && (y == z)++> range :: Int -> Int -> Range+> range = Range++> minRange = fst+> maxRange = snd++> -- | a character and its index (position)+> type Letter = (Char,Int) ++> -- | test for 'epsilon \in a' epsilon-possession+> class PosEpsilon a where+> posEpsilon :: a -> Bool++> -- | test for epsilon == a+> class IsEpsilon a where+> isEpsilon :: a -> Bool++> -- | test for \phi == a+> class IsPhi a where+> isPhi :: a -> Bool++> class Simplifiable a where+> simplify :: a -> a+++> my_hash :: Int -> Char -> Int+> my_hash i x = (ord x) + 256 * i++the lookup function++> my_lookup :: Int -> Char -> IM.IntMap [Int] -> [Int]+> my_lookup i x dict = case IM.lookup (my_hash i x) dict of+> Just ys -> ys+> Nothing -> []++++> -- | The greediness flag+> data GFlag = Greedy -- ^ greedy+> | NotGreedy -- ^ not greedy+> deriving Eq++> instance Show GFlag where+> show Greedy = ""+> show NotGreedy = "?"++> class IsGreedy a where+> isGreedy :: a -> Bool+++> -- | remove duplications in a list of pairs, using the first components as key.+> nub2 :: [(Int,a)] -> [(Int,a)]+> nub2 [] = []+> nub2 [x] = [x] -- optimization+> -- nub2 ls@[x,y] = nubBy (\ (x,_) (y,_) -> x == y) ls -- optimization+> nub2 ls = nub2sub IM.empty ls+> -- nub2aux BS.empty ls []+++> nub2sub im [] = []+> nub2sub im (x@(k,_):xs) = +> -- im `seq` k `seq` +> case IM.lookup k im of+> Just _ -> xs `seq` nub2sub im xs+> Nothing -> let im' = IM.insert k () im +> in im' `seq` xs `seq` x:(nub2sub im' xs)++> {-+> nub2sub im [] = []+> nub2sub im (x@(k,_):xs) = +> -- im `seq` k `seq` +> if not (IM.notMember k im)+> then xs `seq` nub2sub im xs+> else let im' = IM.insert k () im +> in im' `seq` xs `seq` x:(nub2sub im' xs)+> -}++> nub2aux bs [] acc = reverse acc +> nub2aux bs (x@(k,_):xs) acc = +> case bs `seq` k `seq` BS.member k bs of +> True -> xs `seq` nub2aux bs xs acc+> False -> let bs' = BS.insert k bs+> in bs' `seq` xs `seq` (nub2aux bs' xs (x:acc))+++> nub3 :: [(Int,a,Int)] -> [(Int,a,Int)]+> nub3 [] = []+> nub3 [x] = [x] -- optimization+> nub3 ls = nub3subsimple IM.empty ls++ let (_,ls') = nub3sub IM.empty ls+ in ls'++> nub3subsimple :: IM.IntMap () -> [(Int,a,Int)] -> [(Int,a,Int)]+> nub3subsimple im [] = []+> nub3subsimple im [ x ] = [ x ]+> nub3subsimple im (x@(k,f,0):xs) = x:(nub3subsimple im xs)+> nub3subsimple im (x@(k,f,1):xs) = let im' = IM.insert k () im+> in im' `seq` x:(nub3subsimple im' xs)+> nub3subsimple im (x@(k,f,n):xs) = case IM.lookup k im of +> Just _ -> nub3subsimple im xs+> Nothing -> let im' = IM.insert k () im+> in im' `seq` xs `seq` x:(nub3subsimple im' xs)++> nub3sub :: IM.IntMap () -> [(Int,a,Int)] -> (IM.IntMap (), [(Int,a,Int)])+> {-# INLINE nub3sub #-}+> nub3sub im [] = (im,[])+> nub3sub im [(k,f,0)] = (im, [(k,f,0)]) -- 0 means deterministic+> nub3sub im [(k,f,1)] = let im' = IM.insert k () im -- 1 means greedy+> in (im', [(k,f,1)])+> nub3sub im (x@(k,f,0):xs) = let (im',xs') = nub3sub im xs+> in (im',x:xs')+> nub3sub im (x@(k,f,1):xs) = let im' = IM.insert k () im+> (im'', xs') = nub3sub im' xs+> in (im'', x:xs')+> nub3sub im (x@(k,f,n):xs) = case IM.lookup k im of +> Just _ -> nub3sub im xs+> Nothing -> let (im', xs') = nub3sub im xs+> in case IM.lookup k im' of +> Just _ -> (im', xs')+> Nothing -> (im', x:xs')+++The smallest binder index capturing the prefix of the unanchored regex++> preBinder :: Int+> preBinder = -1++> preBinder_ :: Int+> preBinder_ = -2++The largest binder index capturing for the suffix of the unanchored regex++> subBinder :: Int+> subBinder = 2147483647+++The binder index capturing substring which matches by the unanchored regex++> mainBinder :: Int+> mainBinder = 0
+ Text/Regex/Deriv/Dictionary.hs view
@@ -0,0 +1,161 @@+-- | A module that implements a dictionary/hash table++module Text.Regex.Deriv.Dictionary where+++import qualified Data.IntMap as IM+import Data.Char++class Key a where+ hash :: a -> [Int]+++instance Key Int where+ hash i = [i]++instance Key Char where+ hash c = [(ord c)]++instance (Key a, Key b) => Key (a,b) where+ hash (a,b) = hash a ++ hash b++instance (Key a, Key b, Key c) => Key (a,b,c) where+ hash (a,b,c) = hash a ++ hash b ++ hash c+++instance Key a => Key [a] where+ hash as = concatMap hash as+++-- an immutable dictionary+newtype Dictionary a = Dictionary (Trie a)++primeL :: Int+primeL = 757+primeR :: Int+primeR = 577++empty :: Dictionary a+empty = Dictionary emptyTrie ++-- insert and overwrite+insert :: Key k => k -> a -> Dictionary a -> Dictionary a+insert key val (Dictionary trie) = + let key_hash = hash key+ in key_hash `seq` Dictionary (insertTrie True key_hash val trie)++-- insert not overwrite+insertNotOverwrite :: Key k => k -> a -> Dictionary a -> Dictionary a+insertNotOverwrite key val (Dictionary trie) = + let key_hash = hash key+ in key_hash `seq` Dictionary (insertTrie False key_hash val trie)++++lookup :: Key k => k -> Dictionary a -> Maybe a+lookup key (Dictionary trie) = + let key_hash = hash key+ in key_hash `seq` + case lookupTrie key_hash trie of+ Just (Trie (x:_) _) -> Just x+ _ -> Nothing++lookupAll :: Key k => k -> Dictionary a -> [a]+lookupAll key (Dictionary trie) = + let key_hash = hash key+ in key_hash `seq` + case lookupTrie key_hash trie of+ Just (Trie xs _) -> xs+ _ -> [] ++member :: Key k => k -> Dictionary a -> Bool+member key d =+ case Text.Regex.Deriv.Dictionary.lookup key d of + { Just _ -> True + ; Nothing -> False + }++fromList :: Key k => [(k,a)] -> Dictionary a +fromList l = foldl (\d (key,val) -> insert key val d) empty l++fromListNotOverwrite :: Key k => [(k,a)] -> Dictionary a +fromListNotOverwrite l = foldl (\d (key,val) -> insertNotOverwrite key val d) empty l++update :: Key k => k -> a -> Dictionary a -> Dictionary a+update key val (Dictionary trie) = + let key_hash = hash key+ trie' = key_hash `seq` updateTrie key_hash val trie+ in Dictionary trie'+++-- The following are some special functions we implemented for+-- an special instance of the dictionary 'Dictionary (k,a)' +-- in which we store both the key k together with the actual value a, +-- i.e. we map (hash k) to list of (k,a) value pairs++-- ^ the dictionary (k,a) version of elem+isIn :: (Key k, Eq k) => k -> Dictionary (k,a) -> Bool+isIn k dict = + let all = lookupAll (hash k) dict+ in k `elem` (map fst all)++nub :: (Key k, Eq k) => [k] -> [k]+nub ks = nubSub ks empty++nubSub :: (Key k, Eq k) => [k] -> Dictionary (k,()) -> [k]+nubSub [] d = []+nubSub (x:xs) d + | x `isIn` d = nubSub xs d+ | otherwise = let d' = insertNotOverwrite x (x,()) d + in x:(nubSub xs d')+++++-- An internal trie which we use to implement the dictoinar ++data Trie a = Trie ![a] !(IM.IntMap (Trie a))++emptyTrie = Trie [] (IM.empty)+++insertTrie :: Bool -> [Int] -> a -> Trie a -> Trie a+insertTrie overwrite [] i (Trie is maps) + | overwrite = Trie [i] maps+ | otherwise = Trie (i:is) maps+insertTrie overwrite (word:words) i (Trie is maps) = + let key = word+ in key `seq` case IM.lookup key maps of + { Just trie -> let trie' = insertTrie overwrite words i trie+ maps' = trie' `seq` IM.update (\x -> Just trie') key maps+ in maps' `seq` Trie is maps'+ ; Nothing -> let trie = emptyTrie+ trie' = insertTrie overwrite words i trie+ maps' = trie' `seq` IM.insert key trie' maps+ in maps' `seq` Trie is maps'+ }+++++lookupTrie :: [Int] -> Trie a -> Maybe (Trie a) +lookupTrie [] trie = Just trie+lookupTrie (word:words) (Trie is maps) = + let key = word+ in case IM.lookup key maps of+ Just trie -> lookupTrie words trie+ Nothing -> Nothing++-- we only update the first one, not the collided ones+updateTrie :: [Int] -> a -> Trie a -> Trie a+updateTrie [] y (Trie (x:xs) maps) = Trie (y:xs) maps+updateTrie (word:words) v (Trie is maps) =+ let key = word+ in case IM.lookup key maps of+ Just trie -> let trie' = updateTrie words v trie+ maps' = IM.update (\x -> Just trie') key maps+ in Trie is maps'+ Nothing -> Trie is maps+++
+ Text/Regex/Deriv/ExtPattern.lhs view
@@ -0,0 +1,39 @@+> module Text.Regex.Deriv.ExtPattern where++> -- | The external pattern syntax (ERE syntax)+> data EPat = EEmpty +> | EGroupNonMarking EPat -- ^ non marking group (?: re )+> | EGroup EPat -- ^ the group ( re )+> | EOr [EPat] -- ^ the union re|re+> | EConcat [EPat] -- ^ the concantenation rere+> | EOpt EPat Bool -- ^ the option re?, the last boolean flag indicates whether it is greedy+> | EPlus EPat Bool -- ^ the plus re++> | EStar EPat Bool -- ^ the star re*+> | EBound EPat Int (Maybe Int) Bool -- ^ re{1:10}+> | ECarat -- ^ the ^ NOTE:shouldn't this must be top level?+> | EDollar -- ^ the $+> | EDot -- ^ the any char .+> | EAny [Char] -- ^ the character class [ a-z ] +> | ENoneOf [Char] -- ^ the negative character class [^a-z]+> | EEscape Char -- ^ backslash char+> | EChar Char -- ^ the non-escaped char+> deriving Show++> -- | Function 'hasGroup' tests whether an external pattern has ( ... ) (i.e. variable patterns in the internal pattern)+> hasGroup :: EPat -> Bool+> hasGroup EEmpty = False+> hasGroup (EGroup _) = True+> hasGroup (EGroupNonMarking ep) = hasGroup ep+> hasGroup (EOr eps) = any hasGroup eps+> hasGroup (EConcat eps) = any hasGroup eps+> hasGroup (EOpt ep _) = hasGroup ep+> hasGroup (EPlus ep _) = hasGroup ep+> hasGroup (EStar ep _) = hasGroup ep+> hasGroup (EBound ep _ _ _) = hasGroup ep+> hasGroup ECarat = False+> hasGroup EDollar = False+> hasGroup EDot = False+> hasGroup (EAny _) = False+> hasGroup (ENoneOf _) = False+> hasGroup (EEscape _) = False+> hasGroup (EChar _) = False
+ Text/Regex/Deriv/IntPattern.lhs view
@@ -0,0 +1,339 @@+> {-# LANGUAGE BangPatterns #-}+> -- | This module defines the data type of internal regular expression pattern, +> -- | as well as the partial derivative operations for regular expression patterns.+> module Text.Regex.Deriv.IntPattern +> ( Pat(..)+> , strip+> , Binder+> , toBinder+> , listifyBinder+> , Key(..)+> )+> where++> import Data.List+> import qualified Data.IntMap as IM+> import Text.Regex.Deriv.Common (Range(..), range, minRange, maxRange, Letter, PosEpsilon(..), IsEpsilon(..), IsPhi(..), GFlag(..), IsGreedy(..), Simplifiable(..) )+> import Text.Regex.Deriv.RE+> import Text.Regex.Deriv.Dictionary (Key(..), primeL, primeR)+> import Text.Regex.Deriv.Pretty+++> -- | regular expression patterns+> data Pat = PVar Int [Range] Pat -- ^ variable pattern +> | PE [RE] -- ^ pattern without binder+> | PPair Pat Pat -- ^ pair pattern+> | PChoice [Pat] GFlag -- ^ choice pattern +> | PStar Pat GFlag -- ^ star pattern +> | PPlus Pat Pat -- ^ plus pattern, it is used internally to indicate that it is unrolled from a PStar+> | PEmpty Pat -- ^ empty pattern, it is used intermally to indicate that mkEmpty function has been applied.+++> {-| The Eq instance for Pat data type+> NOTE: We ignore the 'consumed word' when comparing patterns+> (ie we only compare the pattern structure).+> Essential for later comparisons among patterns. -}++> instance Eq Pat where+> (==) (PVar x1 _ p1) (PVar x2 _ p2) = (x1 == x2) && (p1 == p2) +> (==) (PPair p1 p2) (PPair p1' p2') = (p1 == p1') && (p2 == p2')+> (==) (PChoice ps1 g1) (PChoice ps2 g2) = (g1 == g2) && (ps1 == ps2) -- more efficient, because choices are constructed in left-nested+> (==) (PPlus p1 p2) (PPlus p1' p2') = (p1 == p1') && (p2 == p2')+> (==) (PStar p1 g1) (PStar p2 g2) = (g1 == g2) && (p1 == p2)+> (==) (PE rs1) (PE rs2) = rs1 == rs2+> (==) _ _ = False+> ++> instance Pretty a => Pretty [a] where+> pretty [] = "{}"+> pretty a@(x:xs) = "{" ++ prettyAll ++ "}"+> where prettyAll = foldl' (\a i -> a++","++(pretty i)) (pretty x) xs++> instance Pretty Pat where+> pretty (PVar x1 _ p1) = "(" ++ show x1 ++ ":" ++ pretty p1 ++ ")"+> pretty (PPair p1 p2) = "<" ++ pretty p1 ++ "," ++ pretty p2 ++ ">"+> pretty (PChoice ps g) = "(" ++ pretty ps ++ ")" ++ (show g)+> pretty (PE rs) = "|" ++ show rs ++ "|"+> pretty (PPlus p1 p2 ) = "(" ++ pretty p1 ++ "," ++ pretty p2 ++ ")"+> pretty (PStar p g) = (pretty p) ++ "*" ++ (show g)+> pretty (PEmpty p) = "[" ++ pretty p ++ "]"++> instance Show Pat where+> show pat = pretty pat++> instance Key Pat where+> hash (PVar x1 _ p1) = let y1 = head (hash x1) +> y2 = head (hash p1)+> in y1 `seq` y2 `seq` [ 1 + y1 * primeL + y2 * primeR ] +> hash (PPair p1 p2) = let x1 = head (hash p1)+> x2 = head (hash p2)+> in x1 `seq` x2 `seq` [ 2 + x1 * primeL + x2 * primeR ] +> hash (PChoice (p1:p2:_) Greedy) = let x1 = head (hash p1)+> x2 = head (hash p2)+> in x1 `seq` x2 `seq` [ 4 + x1 * primeL + x2 * primeR ] +> hash (PChoice (p1:p2:_) NotGreedy) = let x1 = head (hash p1)+> x2 = head (hash p2)+> in x1 `seq` x2 `seq` [ 5 + x1 * primeL + x2 * primeR ]+> hash (PChoice (p1:_) _) = let x1 = head (hash p1)+> +> in x1 `seq` [ 5 + x1 * primeL ]+> hash (PChoice [] _) = [5]+> hash (PPlus p1 p2) = let x1 = head (hash p1)+> x2 = head (hash p2)+> in x1 `seq` x2 `seq` [ 6 + x1 * primeL + x2 * primeR ]+> hash (PStar p Greedy) = let x = head (hash p)+> in x `seq` [ 7 + x * primeL ]+> hash (PStar p NotGreedy) = let x = head (hash p)+> in x `seq` [ 8 + x * primeL ]+> hash (PE r) = let x = head (hash r)+> in x `seq` [ 9 + x * primeL ]+> hash (PEmpty p) = let x = head (hash p)+> in x `seq` [ 3 + x * primeL ]+> hash p = error ("hash is applied to an unacceptable pattern " ++ (show p))++> -- | function 'strip' strips away the bindings from a pattern+> strip :: Pat -> RE +> strip (PVar _ w p) = strip p+> strip (PE rs) = resToRE rs+> strip (PStar p g) = Star (strip p) g+> strip (PPair p1 p2) = Seq (strip p1) (strip p2)+> strip (PPlus p1 p2) = Seq (strip p1) (strip p2)+> strip (PChoice ps g) = Choice (map strip ps) g+> strip (PEmpty p) = strip p+++> -- | function 'mkEmpPat' makes an empty pattern+> mkEmpPat :: Pat -> Pat+> mkEmpPat (PVar x w p) = PVar x w (mkEmpPat p)+> mkEmpPat (PE rs) +> | any posEpsilon rs = PE [Empty]+> | otherwise = PE [Phi]+> mkEmpPat (PStar p g) = PE [Empty] -- problematic?! we are losing binding (x,()) from ( x : a*) ~> PE <>+> mkEmpPat (PPlus p1 p2) = mkEmpPat p1 -- since p2 must be pstar we drop it. If we mkEmpPat p2, we need to deal with pdPat (PPlus (x :<>) (PE <>)) l+> mkEmpPat (PPair p1 p2) = PPair (mkEmpPat p1) (mkEmpPat p2)+> mkEmpPat (PChoice ps g) = PChoice (map mkEmpPat ps) g++> -- | function 'getBindingsFrom' transfer bindings from p2 to p1+> getBindingsFrom :: Pat -- ^ the source of the +> -> Pat -> Pat+> getBindingsFrom p1 p2 = let b = toBinder p2+> in assign p1 b+> where assign :: Pat -> Binder -> Pat+> assign (PVar x w p) b = +> case IM.lookup x b of+> Nothing -> let p' = assign p b in PVar x w p'+> Just rs -> let+> p' = assign p b +> in PVar x (w ++ rs) p'+> assign (PE r) _ = PE r+> assign (PPlus p1 p2) b = PPlus (assign p1 b) p2 -- we don't need to care about p2 since it is a p*+> assign (PPair p1 p2) b = PPair (assign p1 b) (assign p2 b)+> assign (PChoice ps g) b = PChoice (map (\p -> assign p b) ps) g++++> -- | Function 'isGreedy' checks whether a pattern is greedy+> instance IsGreedy Pat where+> isGreedy (PVar _ _ p) = isGreedy p+> isGreedy (PE rs) = any isGreedy rs+> isGreedy (PPair p1 p2) = isGreedy p1 || isGreedy p2+> isGreedy (PChoice ps Greedy) = True+> isGreedy (PChoice ps NotGreedy) = False -- isGreedy p1 || isGreedy p2+> isGreedy (PEmpty p) = False+> isGreedy (PStar p Greedy) = True+> isGreedy (PStar p NotGreedy) = False+> isGreedy (PPlus p p') = isGreedy p || isGreedy p'+++> -- | The 'Binder' type denotes a set of (pattern var * range) pairs+> -- type Binder = [(Int, [Range])]+> type Binder = IM.IntMap [Range]+++> -- | check whether a pattern has binder+> hasBinder :: Pat -> Bool+> hasBinder (PVar _ _ _) = True +> hasBinder (PPair p1 p2) = (hasBinder p1) || (hasBinder p2)+> hasBinder (PPlus p1 p2) = hasBinder p1 +> hasBinder (PStar p1 g) = hasBinder p1 +> hasBinder (PE rs) = False+> hasBinder (PChoice ps g) = any hasBinder ps +> hasBinder (PEmpty p) = hasBinder p+ ++> -- | Function 'toBinder' turns a pattern into a binder+> toBinder :: Pat -> Binder+> toBinder p = IM.fromList (toBinderList p)++> toBinderList :: Pat -> [(Int, [Range])]+> toBinderList (PVar i rs p) = [(i, rs)] ++ (toBinderList p)+> toBinderList (PPair p1 p2) = (toBinderList p1) ++ (toBinderList p2)+> toBinderList (PPlus p1 p2) = (toBinderList p1) +> toBinderList (PStar p1 g) = (toBinderList p1) +> toBinderList (PE rs) = []+> toBinderList (PChoice ps g) = concatMap toBinderList ps +> toBinderList (PEmpty p) = toBinderList p++> listifyBinder :: Binder -> [(Int, [Range])]+> listifyBinder b = sortBy (\ x y -> compare (fst x) (fst y)) (IM.toList b)+> ++> {-| Function 'updateBinderByIndex' updates a binder given an index to a pattern var+> ASSUMPTION: the var index in the pattern is linear. e.g. no ( 0 :: R1, (1 :: R2, 2 :a: R3))+> -}++> updateBinderByIndex :: Int +> -> Int +> -> Binder +> -> Binder+> updateBinderByIndex i !pos binder = -- binder {-+> IM.update (\ r -> case r of -- we always initialize to [], we don't need to handle the key miss case+> { (rs_@((Range b e):rs)) -> +> let !e' = e + 1+> in case e' of +> _ | pos == e' -> Just ((range b e'):rs)+> | pos > e' -> Just ((range pos pos):rs_)+> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter" +> ; [] -> Just [(range pos pos)] +> } ) i binder -- -}+> {-+> updateBinderByIndex i pos binder = +> case IM.lookup i binder of+> { Nothing -> IM.insert i [(pos, pos)] binder+> ; Just ranges -> +> case ranges of +> { [] -> IM.update (\_ -> Just [(pos,pos)]) i binder+> ; ((b,e):rs)+> | pos == e + 1 -> IM.update (\_ -> Just ((b,e+1):rs)) i binder +> | pos > e + 1 -> IM.update (\_ -> Just ((pos,pos):(b,e):rs)) i binder+> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter" +> }+> }+> -}+> {-+> {-# INLINE updateBinderByIndex #-}+> updateBinderByIndex :: Int -- ^ the indext of the pattern variable+> -> Int -- ^ the letter position+> -> Binder -> Binder+> updateBinderByIndex i lpos binder =+> updateBinderByIndexSub i lpos binder +> +> {-# INLINE updateBinderByIndexSub #-}+> updateBinderByIndexSub :: Int -> Int -> Binder -> Binder+> updateBinderByIndexSub idx pos [] = []+> updateBinderByIndexSub idx pos (x@(idx',(b,e):rs):xs)+> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined+> | idx == idx' = if pos == (e + 1)+> then (idx', (b, e+ 1):rs):xs+> else if pos > (e + 1) +> then (idx', (pos,pos):(b, e):rs):xs+> else error "impossible, the current letter position is smaller than the last recorded letter"+> | otherwise = -- idx `seq` pos `seq` xs `seq` +> x:(updateBinderByIndexSub idx pos xs)+> updateBinderByIndexSub idx pos (x@(idx',[]):xs)+> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined+> | idx == idx' = ((idx', [(pos, pos)]):xs)+> | otherwise = -- idx `seq` pos `seq` xs `seq` +> x:(updateBinderByIndexSub idx pos xs)+> -} +> {-+> {-| Function 'pdPat0' is the 'abstracted' form of the 'pdPat' function+> It computes a set of pairs. Each pair consists a 'shape' of the partial derivative, and+> an update function which defines the change of the pattern bindings from the 'source' pattern to +> the resulting partial derivative. This is used in the compilation of the regular expression pattern -}+> pdPat0 :: Pat -- ^ the source pattern+> -> Letter -- ^ the letter to be "consumed"+> -> [(Pat, Int -> Binder -> Binder)]+> pdPat0 (PVar x w p) (l,idx) +> | hasBinder p = +> let pfs = pdPat0 p (l,idx)+> in g `seq` pfs `seq` [ (PVar x [] pd, (\i -> (g i) . (f i) )) | (pd,f) <- pfs ]+> | otherwise = -- p is not nested+> let pds = partDeriv (strip p) l+> in g `seq` pds `seq` if null pds then []+> else -- not PCRE [ (PVar x [] (PE (resToRE pds)), g) ]+> [ (PVar x [] (PE pd), g) | pd <- pds ]+> where g = updateBinderByIndex x +> {-+> | IM.null (toBinder p) = -- p is not nested+> let pds = partDeriv (strip p) l+> in g `seq` pds `seq` if null pds then []+> else [ (PVar x [] (PE (resToRE pds)), g) ]+> | otherwise = +> let pfs = pdPat0 p (l,idx)+> in g `seq` pfs `seq` [ (PVar x [] pd, (\i -> (g i) . (f i) )) | (pd,f) <- pfs ]+> where g = updateBinderByIndex x +> -}+> pdPat0 (PE r) (l,idx) = +> let pds = partDeriv r l+> in pds `seq` if null pds then []+> else [ (PE (resToRE pds), ( \_ -> id ) ) ]+> pdPat0 (PStar p g) l = let pfs = pdPat0 p l+> in pfs `seq` [ (PPair p' (PStar p g), f) | (p', f) <- pfs ]+> pdPat0 (PPair p1 p2) l = +> if (posEpsilon (strip p1))+> then if isGreedy p1+> then nub2 ([ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ] ++ (pdPat0 p2 l))+> else nub2 ((pdPat0 p2 l) ++ [ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ])+> else [ (PPair p1' p2, f) | (p1',f) <- pdPat0 p1 l ]+> pdPat0 (PChoice ps g) l = +> nub2 (concatMap (\p -> pdPat0 p l) ps) -- nub doesn't seem to be essential+++> nub2 :: Eq a => [(a,b)] -> [(a,b)]+> nub2 = nubBy (\(p1,f1) (p2, f2) -> p1 == p2) +++> {-| Function 'pdPat0Sim' applies simplification to the results of 'pdPat0' -}+> pdPat0Sim :: Pat -- ^ the source pattern +> -> Letter -- ^ the letter to be "consumed"+> -> [(Pat, Int -> Binder -> Binder)]+> pdPat0Sim p l = +> let pfs = pdPat0 p l+> pfs' = pfs `seq` map (\(p,f) -> (simplify p, f)) pfs+> in nub2 pfs'+> -}+++> -- | mainly interested in simplifying epsilon, p --> p+> -- could be made more optimal, e.g. (epsilon, epsilon) --> epsilon+> instance Simplifiable Pat where+> -- simplify :: Pat -> Pat+> simplify (PVar i rs p) = PVar i rs (simplify p)+> simplify (PPair p1 p2) =+> let p1' = simplify p1+> p2' = simplify p2+> in if isEpsilon p1'+> then p2'+> else if isEpsilon p2'+> then p1'+> else PPair p1' p2'+> simplify (PChoice ps g) =+> let ps' = filter (not . isPhi) (map simplify ps)+> in PChoice ps' g+> simplify (PStar p g) = PStar (simplify p) g+> simplify (PPlus p1 p2) = PPlus (simplify p1) (simplify p2)+> simplify (PE r) = PE (map simplify r)+++> instance IsEpsilon Pat where+> isEpsilon (PVar _ _ p) = isEpsilon p+> isEpsilon (PE rs) = all isEpsilon rs +> isEpsilon (PPair p1 p2) = (isEpsilon p1) && (isEpsilon p2)+> isEpsilon (PChoice ps _) = all isEpsilon ps+> isEpsilon (PStar p _) = isEpsilon p+> isEpsilon (PPlus p1 p2) = isEpsilon p1 && isEpsilon p2+> isEpsilon (PEmpty _) = True+ ++> instance IsPhi Pat where+> isPhi (PVar _ _ p) = isPhi p+> isPhi (PE rs) = all isPhi rs +> isPhi (PPair p1 p2) = (isPhi p1) || (isPhi p2)+> isPhi (PChoice ps _) = all isPhi ps+> isPhi (PStar p _) = False+> isPhi (PPlus p1 p2) = isPhi p1 || isPhi p2+> isPhi (PEmpty _) = False+++
+ Text/Regex/Deriv/Parse.lhs view
@@ -0,0 +1,209 @@+> {-# LANGUAGE FlexibleContexts #-}+> module Text.Regex.Deriv.Parse (parsePat, parseEPat, parsePatPosix) where++> {- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009. BSD3 -}++The parser that parse POSIX style regex syntax and translate it into our +internal pattern representation.+This parser is largely adapted from Text.Regex.TDFA.ReadRegex++> import Data.Char+> import Text.ParserCombinators.Parsec((<|>), (<?>),+> unexpected, try, runParser, many, getState, setState, CharParser, ParseError,+> sepBy1, option, notFollowedBy, many1, lookAhead, eof, between,+> string, oneOf, noneOf, digit, char, anyChar)+> import Control.Monad(liftM, when, guard)+> import Data.List (sort,nub)+> import qualified Data.IntMap as IM+> import qualified Data.ByteString.Char8 as S++> import Text.Regex.Deriv.ExtPattern (EPat(..))+> import Text.Regex.Deriv.IntPattern (Pat(..))+> import Text.Regex.Deriv.RE (RE(..))+> import Text.Regex.Deriv.Translate (translate, translatePosix) ++> type EState = ()+> initEState = ()++> -- | Return either a parse error or an external pattern+> parseEPat :: String -> Either ParseError (EPat, EState)+> parseEPat x = runParser (do { pat <- p_ere+> ; eof+> ; state <- getState+> ; return (pat,state)+> } ) initEState x x++> parsePat :: String -> Either ParseError Pat+> parsePat x = case parseEPat x of+> { Left error -> Left error+> ; Right (epat, estate) -> Right (translate epat)+> }++posix pattern parsing: we need to add binders everywhere++> parsePatPosix :: String -> Either ParseError (Pat,IM.IntMap ())+> parsePatPosix x = case parseEPat x of+> { Left error -> Left error+> ; Right (epat, estate) -> Right (translatePosix epat)+> }+++> p_ere :: CharParser EState EPat+> p_ere = liftM EOr $ sepBy1 p_branch (char '|')++> p_branch :: CharParser EState EPat+> p_branch = liftM EConcat $ many1 p_exp++> p_exp = (p_anchor <|> p_atom) >>= p_post_anchor_or_atom+> +> p_anchor = ((char '^') >> (return ECarat)) -- '^'+> <|>+> ((char '$') >> (return EDollar)) -- '$'++todo '{'++> p_atom = p_group <|>+> p_charclass <|>+> p_dot <|>+> p_esc_char <|>+> p_char++ p_group = liftM EGroup $ between (char '(') (char ')') p_ere++> p_group = +> between (char '(') (char ')') +> ( try +> ( do +> { -- non marking group +> ; (char '?') +> ; (char ':')+> ; x <- p_ere+> ; return (EGroupNonMarking x)+> } +> )+> <|>+> liftM EGroup p_ere+> )++++parsing [ ... ] and [^ ... ]++> p_charclass = +> (char '[') +> >> ( do { char '^' +> ; liftM ENoneOf $ p_enum -- enum ends with ']'+> } +> <|>+> (liftM EAny $ p_enum)+> )++> p_enum :: CharParser EState [Char]+> p_enum = do { initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))) +> -- todo : why do we need this here? +> -- answer: if not, this string can't be parsed "[]f-z]", which is any char of ']' and between 'f' to 'z'+> ; chars <- many1 p_one_enum+> ; char ']'+> ; let chars_set = nub (sort (initial ++ (concat chars)))+> ; return chars_set+> }++todo: support the locale collating char class [: :] [= =] [. .]++> p_one_enum = p_range <|> p_char_set ++> p_range = try $ do +> { start <- (try p_esc_char_) <|> noneOf "]-"+> ; char '-'+> ; end <- (try p_esc_char_) <|> noneOf "]"+> ; return [ start .. end ] +> }++> p_char_set = do +> { c <- (try p_esc_char_) <|> noneOf "]" -- <|> (char '\\' >> p_special_char)+> ; when (c == '-') $+> do -- when it is a dash, it must be at the end of the [..]+> { atEnd <- (lookAhead (char ']') >> return True) <|> (return False)+> ; when (not atEnd) (unexpected "A dash is in the wrong place in a bracket")+> }+> ; return [c]+> }++parse the dot (all characters)++> p_dot = char '.' >> (return EDot)++parse the escaped chars++> p_esc_char_ = char '\\' >> ((try p_tab) <|> (try p_return) <|> (try p_newline) <|> (try p_oct_ascii) <|> anyChar)++> p_esc_char = char '\\' >> ((try p_tab) <|> (try p_return) <|> (try p_newline) <|> (try p_oct_ascii) <|> anyChar) >>= \c -> return (EEscape c)++oct ascii, e.g. \000++> p_return = do +> { char 'r'+> ; return '\r'+> }++> p_newline = do +> { char 'n'+> ; return '\n'+> }++> p_tab = do +> { char 't'+> ; return '\t'+> }+++> p_oct_ascii = do +> { d1 <- digit+> ; d2 <- digit+> ; d3 <- digit+> ; return (chr ((digitToInt d2)*8 + (digitToInt d3)))+> }+++parse a single non-escaped char++> specials = "^.[$()|*+?{\\"++> p_char = noneOf specials >>= \c -> return (EChar c)++> p_special_char :: CharParser EState Char+> p_special_char = oneOf specials+++> p_post_anchor_or_atom atom = +> (try (char '?' >> char '?' >> return (EOpt atom False)) <|> (char '?' >> return (EOpt atom True)))+> <|> (try (char '+' >> char '?' >> return (EPlus atom False)) <|> (char '+' >> return (EPlus atom True)))+> <|> (try (char '*' >> char '?' >> return (EStar atom False)) <|> (char '*' >> return (EStar atom True)))+> <|> p_bound_nongreedy atom+> <|> p_bound atom +> <|> return atom+++> p_bound_nongreedy atom = try $ between (string "{") (string "}?") (p_bound_spec atom False)++> p_bound atom = try $ between (char '{') (char '}') (p_bound_spec atom True)++> p_bound_spec atom b = do { lowS <- many1 digit+> ; let lowI = read lowS+> ; highMI <- option (Just lowI) $ try $ +> do { char ','+> -- parsec note: if 'many digits' fails below then the 'try' ensures+> -- that the ',' will not match the closing '}' in p_bound, same goes+> -- for any non '}' garbage after the 'many digits'.+> ; highS <- many digit+> ; if null highS then return Nothing -- no upper bound+> else do { let highI = read highS+> ; guard (lowI <= highI)+> ; return (Just (read highS))+> }+> }+> ; return (EBound atom lowI highMI b)+> }+++
+ Text/Regex/Deriv/Pretty.lhs view
@@ -0,0 +1,4 @@+> module Text.Regex.Deriv.Pretty where++> class Pretty a where+> pretty :: a -> String
+ Text/Regex/Deriv/RE.lhs view
@@ -0,0 +1,210 @@++> {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies,+> FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} ++> module Text.Regex.Deriv.RE where++> import Data.List (nub)+> import Data.Char (chr)++> import Text.Regex.Deriv.Common (PosEpsilon(..), IsEpsilon(..), IsPhi(..), Simplifiable(..), IsGreedy(..), GFlag(..))+> import Text.Regex.Deriv.Dictionary (Key(..), primeL, primeR)++------------------------++> -- | data type of the regular expresions+> data RE = Phi +> | Empty -- ^ an empty exp+> | L Char -- ^ a literal / a character+> | Choice [RE] GFlag -- ^ a choice exp 'r1 + r2'+> | Seq RE RE -- ^ a pair exp '(r1,r2)'+> | Star RE GFlag -- ^ a kleene's star exp 'r*'+> | Any -- ^ .+> | Not [Char] -- ^ excluding characters e.g. [^abc]++> -- | the eq instance+> instance Eq RE where+> (==) Empty Empty = True+> (==) (L x) (L y) = x == y+> (==) (Choice rs1 g1) (Choice rs2 g2) = (g1 == g2) && (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' +> (==) _ _ = 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 (Seq r1 r2) (Seq r3 r4) = +> let x = compare r1 r3 +> in case x of +> { EQ -> compare r2 r4+> ; _ -> x }+> compare (Star r1 _) (Star r2 _) = compare r1 r2+> compare Any Any = EQ+> compare (Not cs) (Not cs') = compare cs cs'+> compare r1 r2 = compare (assignInt r1) (assignInt r2)+> where assignInt Empty = 0+> assignInt (L _) = 1 +> assignInt (Choice _ _) = 2+> assignInt (Seq _ _) = 3+> assignInt (Star _ _) = 4+> assignInt Any = 5+> assignInt (Not _) = 6+++> -- | 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 (Seq r1 r2) = "<" ++ show r1 ++ "," ++ show r2 ++ ">"+> show (Star r g) = show r ++ "*" ++ show g+> show Any = "."+> show (Not cs) = "[^" ++ cs ++ "]"++> instance IsGreedy RE where+> isGreedy Phi = True+> isGreedy Empty = False+> isGreedy (Choice _ Greedy) = True+> isGreedy (Choice _ NotGreedy) = False -- (isGreedy r1) || (isGreedy r2)+> isGreedy (Seq r1 r2) = (isGreedy r1) || (isGreedy r2)+> isGreedy (Star r Greedy) = True+> isGreedy (Star r NotGreedy) = False+> isGreedy (L _) = True+> isGreedy Any = True+> isGreedy (Not _) = True++> instance Key RE where+> hash Phi = [0]+> hash Empty = [1]+> hash (Choice _ Greedy) = {- let x1 = head (hash r1)+> x2 = head (hash r2)+> in [ 3 + x1 * primeL + x2 * primeR ] -} [3]+> hash (Choice _ NotGreedy) = {- let x1 = head (hash r1)+> x2 = head (hash r2)+> in [ 4 + x1 * primeL + x2 * primeR ] -} [4]+> hash (Seq r1 r2) = let x1 = head (hash r1)+> x2 = head (hash r2)+> in [ 5 + x1 * primeL + x2 * primeR ] -- [5]+> hash (Star r Greedy) = {- let x = head (hash r)+> in [ 6 + x * primeL ] -} [6]+> hash (Star r NotGreedy) = {- let x = head (hash r)+> in [ 7 + x * primeL ] -} [7]+> hash (L c) = {- let x = head (hash c)+> in [ 8 + x * primeL ] -} [8]+> hash Any = [2]+> hash (Not _) = [9]++++> -- | function 'resToRE' sums up a list of regular expressions with the choice operation.+> resToRE :: [RE] -> RE+> resToRE x@(r:res) = Choice x Greedy+> resToRE [] = Phi+++> instance PosEpsilon RE where+> posEpsilon Phi = False+> posEpsilon Empty = True+> posEpsilon (Choice rs g) = any posEpsilon rs+> posEpsilon (Seq r1 r2) = (posEpsilon r1) && (posEpsilon r2)+> posEpsilon (Star r g) = True+> posEpsilon (L _) = False+> posEpsilon Any = False+> posEpsilon (Not _) = False+ ++> -- | function 'isEpsilon' checks whether epsilon = r+> instance IsEpsilon RE where+> isEpsilon Phi = False+> isEpsilon Empty = True+> isEpsilon (Choice rs g) = all isEpsilon rs+> isEpsilon (Seq r1 r2) = (isEpsilon r1) && (isEpsilon r2)+> isEpsilon (Star Phi g) = True+> isEpsilon (Star r g) = isEpsilon r+> isEpsilon (L _) = False+> isEpsilon Any = False+> isEpsilon (Not _) = False++> instance IsPhi RE where+> isPhi Phi = True+> isPhi Empty = False+> isPhi (Choice [] _) = True+> isPhi (Choice rs g) = all isPhi rs+> isPhi (Seq r1 r2) = (isPhi r1) || (isPhi r2)+> isPhi (Star r g) = False+> isPhi (L _) = False+> isPhi Any = False+> isPhi (Not _) = False++> -- | function 'partDeriv' implements the partial derivative operations for regular expressions. We don't pay attention to the greediness flag here.+> partDeriv :: RE -> Char -> [RE]+> partDeriv r l = let pds = (partDerivSub r l)+> in {-# SCC "nub_pd" #-} nub (map simplify pds) +++> partDerivSub Phi l = []+> partDerivSub Empty l = []+> partDerivSub (L l') l +> | l == l' = [Empty]+> | otherwise = []+> partDerivSub Any l = [Empty]+> partDerivSub (Not cs) l +> | l `elem` cs = []+> | otherwise = [Empty]+> partDerivSub (Choice rs g) l = concatMap (\ r -> partDerivSub r l) rs+> partDerivSub (Seq r1 r2) l +> | posEpsilon r1 = +> let +> s0 = partDerivSub r1 l+> s1 = s0 `seq` [ (Seq r1' r2) | r1' <- s0 ]+> s2 = partDerivSub r2 l+> in s1 `seq` s2 `seq` (s1 ++ s2)+> | otherwise = +> let +> s0 = partDerivSub r1 l +> in s0 `seq` [ (Seq r1' r2) | r1' <- s0 ]+> partDerivSub (Star r g) l = +> let+> s0 = partDerivSub r l+> in s0 `seq` [ (Seq r' (Star r g)) | r' <- s0 ]++> -- | function 'sigmaRE' returns all characters appearing in a reg exp.+> sigmaRE :: RE -> [Char]+> sigmaRE r = let s = (sigmaREsub r)+> in s `seq` nub s++> sigmaREsub (L l) = [l]+> sigmaREsub Any = map chr [32 .. 127]+> sigmaREsub (Not cs) = filter (\c -> not (c `elem` cs)) (map chr [32 .. 127])+> sigmaREsub (Seq r1 r2) = (sigmaREsub r1) ++ (sigmaREsub r2) +> sigmaREsub (Choice rs g) = concatMap sigmaREsub rs+> sigmaREsub (Star r g) = sigmaREsub r+> sigmaREsub Phi = []+> sigmaREsub Empty = []++> instance Simplifiable RE where+> simplify (L l) = L l+> simplify Any = Any+> simplify (Not cs) = Not cs+> simplify (Seq r1 r2) = +> let r1' = simplify r1+> r2' = simplify r2+> in if isEpsilon r1'+> then r2'+> else if isEpsilon r2'+> then r1'+> else Seq r1' r2'+> simplify (Choice rs g) = +> let rs' = filter (not . isPhi) $ map simplify rs+> in if null rs' +> then Phi+> else Choice rs' g+> simplify (Star r g) = Star (simplify r) g+> simplify Phi = Phi+> simplify Empty = Empty
+ Text/Regex/Deriv/Translate.lhs view
@@ -0,0 +1,605 @@+> -- | A translation schema from the external syntax (ERE) to our interal syntax (xhaskell style pattern)+> module Text.Regex.Deriv.Translate +> ( translate, translatePosix ) where++> import Control.Monad.State -- needed for the translation scheme+> import Data.Char (chr)+> import qualified Data.IntMap as IM++> import Text.Regex.Deriv.ExtPattern+> import Text.Regex.Deriv.IntPattern+> import Text.Regex.Deriv.RE+> import Text.Regex.Deriv.Common+++> -- | A state monad in which we can assign number to groups and non-groups.+> data TState = TState { ngi :: NGI -- ^ negative group index+> , gi :: GI -- ^ (positive) group index+> , anchorStart :: Bool+> , anchorEnd :: Bool+> , posix :: Bool -- ^ if posix, add binders to non-groups +> , posix_binder :: IM.IntMap () -- ^ keep tracks of posix binder+> } -- the state for trasslation+> deriving Show+++> -- variables 0,-1,-2 are reserved for pre, main and post!+> initTState = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False, posix = False, posix_binder = IM.empty } +++> initTStatePosix = TState { ngi = -3, gi = 1, anchorStart = False, anchorEnd = False, posix = True, posix_binder = IM.empty } +++> type NGI = Int -- the non group index++> type GI = Int -- the group index++getters and putters++> getNGI :: State TState NGI+> getNGI = do { st <- get+> ; return $ ngi st+> }++> getIncNGI :: State TState NGI -- get then increase+> getIncNGI = do { st <- get+> ; let i = ngi st+> ; put st{ngi=(i-1)} +> ; return i+> }++> getGI :: State TState GI+> getGI = do { st <- get+> ; return $ gi st+> }++> getIncGI :: State TState GI -- get then increase +> getIncGI = do { st <- get+> ; let i = gi st+> ; put st{gi=(i+1)}+> ; return i+> }++> getAnchorStart :: State TState Bool+> getAnchorStart = do { st <- get+> ; return (anchorStart st)+> }++> setAnchorStart :: State TState ()+> setAnchorStart = do { st <- get+> ; put st{anchorStart=True}+> }++> getAnchorEnd :: State TState Bool+> getAnchorEnd = do { st <- get+> ; return (anchorEnd st)+> }++> setAnchorEnd :: State TState ()+> setAnchorEnd = do { st <- get+> ; put st{anchorEnd=True}+> }++> isPosix :: State TState Bool+> isPosix = do { st <- get+> ; return (posix st)+> }+++> isPosixBinder :: GI -> State TState Bool+> isPosixBinder gi = do { st <- get+> ; return (IM.member gi (posix_binder st)) +> } ++> addPosixBinder :: Int -> State TState ()+> addPosixBinder i = do { st <- get+> ; let bs = posix_binder st+> bs' = IM.insert i () bs+> ; put st{posix_binder=bs'}+> }++> -- | Translating external pattern to internal pattern+> translate :: EPat -> Pat+> translate epat = case runState (trans epat) initTState of+> (pat, state) ->+> let hasAnchorS = anchorStart state+> hasAnchorE = anchorEnd state+> in case (hasAnchorS, hasAnchorE) of+> (True, True) -> PVar mainBinder [] pat +> (True, False) -> PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE [(Star Any NotGreedy)]))+> (False, True) -> PPair (PVar preBinder [] (PE [(Star Any NotGreedy)])) (PVar mainBinder [] pat)+> -- (False, False) -> PPair (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat)) (PVar subBinder [] (PE (Star Any NotGreedy)))+> -- (False, False) -> PPair (PVar preBinder_ [] (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat))) (PVar subBinder [] (PE (Star Any NotGreedy)))+> (False, False) -> (PPair (PVar preBinder [] (PE [(Star Any NotGreedy)])) (PVar preBinder_ [] (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE [(Star Any NotGreedy)])))))+++> -- | for posix +> translatePosix :: EPat -> (Pat,IM.IntMap ())+> translatePosix epat = case runState (trans epat) initTStatePosix of+> (pat, state) ->+> let hasAnchorS = anchorStart state+> hasAnchorE = anchorEnd state+> posixBnd = posix_binder state+> in case (hasAnchorS, hasAnchorE) of+> (True, True) -> (PVar mainBinder [] pat, posixBnd)+> (True, False) -> (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE [(Star Any NotGreedy)])), posixBnd)+> (False, True) -> (PPair (PVar preBinder [] (PE [(Star Any NotGreedy)])) (PVar mainBinder [] pat), posixBnd)+> -- (False, False) -> PPair (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat)) (PVar subBinder [] (PE (Star Any NotGreedy)))+> -- (False, False) -> PPair (PVar preBinder_ [] (PPair (PVar preBinder [] (PE (Star Any NotGreedy))) (PVar mainBinder [] pat))) (PVar subBinder [] (PE (Star Any NotGreedy)))+> (False, False) -> ((PPair (PVar preBinder [] (PE [(Star Any NotGreedy)])) (PVar preBinder_ [] (PPair (PVar mainBinder [] pat) (PVar subBinder [] (PE [(Star Any NotGreedy)]))))), posixBnd)++++> {-| 'trans' The top level translation scheme e ~> p+> There are two sub rules.+> e ~>_p p+> and+> e ~>_r r+> which are fired depending on whether e has Group pattern (...) (i.e. pattern variable)+> -}+> trans :: EPat -> State TState Pat+> trans epat = +> do { is_posix <- isPosix -- if it is posix, we need to aggresively "tag" every sub expression with a binder+> ; if is_posix && isStructural epat+> then do +> { gi <- getIncGI+> ; ipat <- trans' epat+> ; if isPVar ipat+> then do +> { return ipat+> }+> else do +> { addPosixBinder gi+> ; return (PVar gi [] ipat)+> }+> }+> else trans' epat+> }+> where isStructural :: EPat -> Bool -- ^ indicate whether it is a complex structure which we need to add extra binding for POSIX tracking+> isStructural (EOr _) = True+> isStructural (EConcat _) = True +> isStructural (EOpt _ _) = True+> isStructural (EPlus _ _) = True+> isStructural (EStar _ _) = True+> isStructural _ = False +> isPVar :: Pat -> Bool+> isPVar (PVar _ _ _) = True+> isPVar _ = False++> trans' :: EPat -> State TState Pat+> trans' epat +> | hasGroup epat = p_trans epat+> | otherwise = do +> { r <- r_trans epat+> ; return (PE [r])+> }++> {-+> trans :: EPat -> State TState Pat+> trans epat | hasGroup epat = p_trans epat+> | otherwise = +> do +> { is_posix <- isPosix +> ; if is_posix +> then do +> { gi <- getIncGI+> ; r <- r_trans epat+> ; addPosixBinder gi+> ; return (PVar gi [] (PE r))+> }+> else do +> { r <- r_trans epat+> ; return (PE r)+> }+> }+> -}++> {-| 'adhoc_simp' make some simplification for p' on the fly for nested x :: p'+> removing immediate nested PVar created for posix+> -}+> adhocSimp :: Pat -> State TState Pat +> adhocSimp q@(PChoice [ (PVar x _ p) ] g) = do +> { b <- isPosixBinder x+> ; if b +> then return p +> else return q }+> adhocSimp q = return q++> {-| 'p_trans' implementes the rule 'e ~>_p p'+> convention:+> a,b are non group indices.+> x,y,z are group indices+> -}+> p_trans :: EPat -> State TState Pat+> p_trans epat = +> case epat of+> -- () ~>_p ()+> { EEmpty ->+> do { return ( PE [Empty] )+> }+> {-+> e ~> p+> -----------------+> ( e ) ~>_p x :: p+> -}+> ; EGroup e ->+> do { i <- getIncGI+> ; -- p <- trans e+> ; p <- trans' e -- no need to go through trans which possible tag p with a posix var+> ; p' <- adhocSimp p+> ; return ( PVar i [] p')+> }+> {-+> e ~> p+> -----------------+> (? e ) ~>_p p +> -}+> ; EGroupNonMarking e -> +> trans' e+> ; EOr es -> +> {-+> e1 ~> p1 e2 ~> p2+> -------------------+> e1|e2 ~>_p p1|p2+> -}+> do { ps <- mapM trans es+> ; case ps of+> { (p':ps') -> +> return (PChoice ps Greedy )+> ; [] -> error "an empty choice enountered." -- todo : capture the error in the monad state+> }+> }+> ; EConcat es ->+> {- +> e1 ~> p1 e2 ~> p2+> ---------------------+> (e1,e2) ~>_p (p1,p2)+> -} +> do { ps <- mapM trans es+> ; case reverse ps of -- to make sure it is right assoc+> { (p':ps') -> +> return (foldl (\xs x -> PPair x xs) p' ps')+> ; [] -> error "an empty sequence enountered." -- todo : capture the error in the moand state+> }+> }+> ; EOpt e b ->+> {- +> todo : not sure whether this makes sense+> e ~> p+> -------------------+> e? ~>_p p|()+> -}+> do { p <- trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (PChoice [p,PE [Empty]] g)+> }+> ; EPlus e b ->+> {- +> e ~> p+> -------------------+> p+ ~>_p (p,p*)+> -}+> do { p <- trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (PPair p (PStar p g))+> }+> ; EStar e b -> +> {- +> e ~> p+> -------------------+> e*~>_p p*+> -}+> do { p <- trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (PStar p g)+> }+> ; EBound e low (Just high) b ->+> {- we could have relax this rule to e ~> p+> e ~>_r r +> r1 = take l (repeat r)+> r2 = take (h-l) (repeat r?)+> r' = (r1,r2)+> -------------------------------------+> e{l,h} ~> a :: r' +> -}+> do { r <- r_trans e+> ; i <- getIncNGI+> ; let g | b = Greedy+> | otherwise = NotGreedy+> r1s = take low $ repeat r+> r1 = case r1s of +> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r2s = take (high - low) $ repeat (Choice [r,Empty] g)+> r2 = case r2s of+> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r3 = case (r1,r2) of +> (Empty, Empty) -> Empty+> (Empty, _ ) -> r2+> (_ , Empty) -> r1+> (_ , _ ) -> Seq r1 r2+> p = PVar i [] (PE [r3])+> ; return p+> }+> ; EBound e low Nothing b ->+> {-+> e ~>_r r +> r1 = take l (repeat r)+> r' = (r1,r*)+> -------------------------------------+> e{l,} ~> a :: r' +> -}+> do { r <- r_trans e+> ; i <- getIncNGI+> ; let g | b = Greedy+> | otherwise = NotGreedy+> r1s = take low $ repeat r+> r1 = case r1s of +> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r2 = Seq r1 (Star r g)+> p = PVar i [] (PE [r2])+> ; return p+> }+> ; ECarat -> +> -- currently we anchor the entire expression +> -- regardless of where ^ appears, we turn the subsequent+> -- ECarat into literal,+> do { f <- getAnchorStart+> ; if f +> then do { i <- getIncNGI -- not the first carat+> ; let r = L '^'+> p = PVar i [] (PE [r])+> ; return p+> }+> else do { setAnchorStart -- the first carat+> ; i <- getIncNGI+> ; let r = Empty+> p = PVar i [] (PE [r])+> ; return p+> }+> }+> ; EDollar -> +> -- similar to carat, except that we will not treat+> -- the subsequent EDollar as literal.+> do { f <- getAnchorEnd+> ; if f+> then return ()+> else setAnchorEnd+> ; i <- getIncNGI+> ; let r = Empty+> p = PVar i [] (PE [r])+> ; return p+> }+> ; EDot -> +> -- . ~> a :: \Sigma +> -- we might not need this rule+> do { i <- getIncNGI+> ; let r = Any+> p = PVar i [] (PE [r])+> ; return p+> }+> ; EAny cs ->+> -- [ abc ] ~> a :: 'a'|'b'|'c' +> -- we might not need this rule+> do { i <- getIncNGI+> ; let r = char_list_to_re cs+> -- r = Any+> p = PVar i [] (PE [r])+> ; return p+> }+> ; ENoneOf cs ->+> -- [^ abc] ~> a :: \Sigma - 'a'|'b'|'c' +> -- we might not need this rule+> do { i <- getIncNGI+> ; let -- r = char_list_to_re (filter (\c -> not (c `elem` cs )) sigma)+> r = Not cs+> p = PVar i [] (PE [r])+> ; return p+> }+> ; EEscape c ->+> -- \\c ~> a :: L c +> -- we might not need this rule+> do { i <- getIncNGI +> ; let p = PVar i [] (PE [L c])+> ; return p +> }+> ; EChar c ->+> -- c ~> a :: L c+> -- we might not need this rule+> do { i <- getIncNGI+> ; let p = PVar i [] (PE [L c])+> ; return p+> }+> }+++> char_list_to_re (c:cs) = Choice (map L (c:cs)) Greedy+> char_list_to_re [] = error "char_list_to_re expects non-empty list"++> alphas = char_list_to_re (['a'..'z'] ++ ['A'..'Z'])++> digits = char_list_to_re ['0'..'9']++> sigma = map chr [0 .. 255]++> anychar = char_list_to_re sigma+++e ~>_r r+++> r_trans :: EPat -> State TState RE+> r_trans e = +> case e of +> { EEmpty -> +> {-+> () ~>_r ()+> -}+> return Empty+> ; EGroup e ->+> {- we might not need this rule+> e ~> r+> ----------+> (e) ~> r+> -}+> r_trans e+> ; EGroupNonMarking e ->+> {- we might not need this rule+> e ~> r+> ----------+> (?e) ~> r+> -}+> r_trans e+> ; EOr es ->+> {-+> e1 ~>_r r1 e2 ~>_r r2+> -------------------+> e1|e2 ~>_r r1|r2+> -}+> do { rs <- mapM r_trans es+> ; case rs of+> { [] -> return Phi+> ; (r:rs) -> return (Choice (r:rs) Greedy)+> }+> }+> ; EConcat es ->+> {-+> e1 ~>_r r1 e2 ~>_r r2+> ----------------------+> (e1,e2) ~>_r (r1,r2)+> -}+> do { rs <- mapM r_trans es+> ; case rs of+> { [] -> return Empty+> ; (r:rs) -> return (foldl (\ xs x -> Seq xs x) r rs)+> }+> }+> ; EOpt e b -> +> {-+> e ~>_r r+> -----------+> e? ~>_r r?+> -}+> do { r <- r_trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (Choice [r,Empty] g)+> }+> ; EPlus e b -> +> {-+> e ~>_r r+> ---------------+> e+ ~>_r (r,r*)+> -}+> do { r <- r_trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (Seq r (Star r g))+> }+> ; EStar e b -> +> {-+> e ~>_r r+> ----------------+> e* ~>_r r*+> -}+> do { r <- r_trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> ; return (Star r g)+> }+> ; EBound e low (Just high) b ->+> {-+> e ~>_r r+> r1 = take l (repeat r)+> r2 = take (h-l) (repeat r?)+> r' = (r1,r2) +> -----------------+> e{l:h} => r'+> -}+> do { r <- r_trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> r1s = take low $ repeat r+> r1 = case r1s of+> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r2s = take (high - low) $ repeat (Choice [r,Empty] g)+> r2 = case r2s of+> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r3 = case (r1,r2) of+> (Empty, Empty) -> Empty+> (Empty, _ ) -> r2+> (_ , Empty) -> r1+> (_ , _ ) -> Seq r1 r2+> ; return r3+> }+> ; EBound e low Nothing b -> +> {-+> e ~>_r r +> r1 = take l (repeat r)+> r' = (r1,r*)+> -------------------------------------+> e{l,} => r' +> -}+> do { r <- r_trans e+> ; let g | b = Greedy+> | otherwise = NotGreedy+> r1s = take low $ repeat r+> r1 = case r1s of +> { [] -> Empty+> ; (r':rs') -> foldl (\ rs r -> Seq rs r) r' rs'+> }+> r2 = Seq r1 (Star r g)+> ; return r2+> }+> ; ECarat -> +> -- currently we anchor the entire expression +> -- regardless of where ^ appears, we turn the subsequent+> -- ECarat into literal,+> do { f <- getAnchorStart+> ; if f +> then return (L '^') -- not the first carat+> else do { setAnchorStart -- the first carat+> ; return Empty+> }+> }+> ; EDollar -> +> -- similar to carat, except that we will not treat+> -- the subsequent EDollar as literal.+> do { f <- getAnchorEnd+> ; if f+> then return ()+> else setAnchorEnd+> ; return Empty+> }+> ; EDot -> +> -- . ~>_r \Sigma+> -- return anychar+> return Any+> ; EAny cs ->+> -- [ abc ] ~>_r 'a'|'b'|'c'+> return (char_list_to_re cs)+> ; ENoneOf cs ->+> -- [^ abc] ~>_r \Sigma - 'a'|'b'|'c'+> -- return $ char_list_to_re (filter (\c -> not (c `elem` cs )) sigma)+> return (Not cs)+> ; EEscape c ->+> -- \\c ~>_r c+> return $ L c+> ; EChar c ->+> -- c ~>_r c+> return $ L c+> }+> +
+ Text/Regex/Deriv/Word.lhs view
@@ -0,0 +1,12 @@+> module Text.Regex.Deriv.Word where++> -- | the Word type class+> class Word a where+> uncons :: a -> Maybe (Char,a)+> take :: Int -> a -> a+> drop :: Int -> a -> a+> empty :: a+> reverse :: a -> a+> append :: a -> a -> a+> length :: a -> Int+
+ regex-deriv.cabal view
@@ -0,0 +1,37 @@+Name: regex-deriv+Version: 0.0.1+License: BSD3+License-File: LICENSE+Copyright: Copyright (c) 2010-2013, Kenny Zhuo Ming Lu and Martin Sulzmann+Author: Kenny Zhuo Ming Lu and Martin Sulzmann+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+Description: Regex algorithm implementation using derivatives. +Category: Text+Tested-With: GHC+Build-Type: Simple+Cabal-Version: >= 1.2.3++flag base4++library + Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, bytestring, deepseq+ 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.Common + Text.Regex.Deriv.Word+ Text.Regex.Deriv.ExtPattern+ Text.Regex.Deriv.IntPattern+ Text.Regex.Deriv.RE+ Text.Regex.Deriv.Parse + Text.Regex.Deriv.Translate+ Text.Regex.Deriv.Pretty+ Text.Regex.Deriv.Dictionary+ Buildable: True+ Extensions: GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, FlexibleContexts+ GHC-Options: -threaded -O2 -funbox-strict-fields+ GHC-Prof-Options: -auto-all