diff --git a/examples/test/Main.hs b/examples/test/Main.hs --- a/examples/test/Main.hs +++ b/examples/test/Main.hs @@ -212,7 +212,7 @@ where tokenTest (re, inp, toks) = TestCase $ - assertEqual ("tokenize " ++ show re ++ show inp ++ " = " ++ show toks) + assertEqual ("tokenize " ++ show re ++ " " ++ show inp ++ " = " ++ show toks) toks (tokenize re inp) tests = [ ("", "", [] ) @@ -220,7 +220,7 @@ , ("a", "b", [] ) , ("a", "ba", ["a"] ) , ("a*", "a", ["a"] ) - , ("a*", "ba", ["", "a"] ) + , ("a*", "ba", ["","a"] ) , ("a*", "aba", ["a", "a"] ) , ("a*", "abba", ["a", "", "a"] ) , ("a+", "abba", ["a", "a"] ) diff --git a/regex-xmlschema.cabal b/regex-xmlschema.cabal --- a/regex-xmlschema.cabal +++ b/regex-xmlschema.cabal @@ -1,5 +1,5 @@ name: regex-xmlschema -version: 0.1.0 +version: 0.1.1 license: BSD3 license-file: LICENSE maintainer: Uwe Schmidt diff --git a/src/Text/Regex/XMLSchema/String.hs b/src/Text/Regex/XMLSchema/String.hs --- a/src/Text/Regex/XMLSchema/String.hs +++ b/src/Text/Regex/XMLSchema/String.hs @@ -22,6 +22,7 @@ ( GenRegex , Regex + , grep , match , matchSubex , sed @@ -44,12 +45,14 @@ , mkUnit , mkSym1 , mkSymRng + , mkWord , mkDot , mkStar , mkAll , mkAlt , mkElse , mkSeq + , mkSeqs , mkRep , mkRng , mkOpt @@ -67,6 +70,7 @@ import Control.Arrow +import Data.List import Data.Maybe import Text.Regex.XMLSchema.String.Regex @@ -149,13 +153,14 @@ = token'' where re1 = mkDiff re mkUnit - token'' = token' re - token1'' = token' re1 + token'' = token' re fcs + token1'' = token' re1 fcs + fcs = firstChars re - -- token' :: (Eq l, Show l) => GenRegex l -> String -> [String] - token' re' inp + -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> [String] + token' re' fcs' inp | null inp = [] - | otherwise = evalRes . splitWithRegex re' $ inp + | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp where evalRes Nothing = token'' (tail inp) -- re does not match any prefix evalRes (Just (toks, rest)) @@ -225,13 +230,14 @@ = token'' "" where re1 = mkDiff re mkUnit - token'' = token' re - token1'' = token' re1 + token'' = token' re fcs + token1'' = token' re1 fcs + fcs = firstChars re - -- token' :: (Eq l, Show l) => GenRegex l -> String -> String -> [Either String String] - token' re' unmatched inp + -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> String -> [Either String String] + token' re' fcs' unmatched inp | null inp = addUnmatched [] - | otherwise = evalRes . splitWithRegex re' $ inp + | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp where addUnmatched | null unmatched = id @@ -276,13 +282,14 @@ = token'' where re1 = mkDiff re mkUnit - token'' = token' re - token1'' = token' re1 + token'' = token' re fcs + token1'' = token' re1 fcs + fcs = firstChars re - -- token' :: (Eq l, Show l) => GenRegex l -> String -> [(l,String)] - token' re' inp + -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> [(l,String)] + token' re' fcs' inp | null inp = [] - | otherwise = evalRes . splitWithRegex re' $ inp + | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp where evalRes Nothing = token'' (tail inp) -- re does not match any prefix evalRes (Just (toks, rest)) @@ -377,5 +384,39 @@ matchSubex :: String -> String -> [(String, String)] matchSubex = matchSubexRE . parseRegex + +-- ------------------------------------------------------------ + +-- | grep like filter for lists of strings +-- +-- The regular expression may be prefixed with the usual context spec \"^\" for start of string, +-- and "\\<" for start of word. +-- and suffixed with \"$\" for end of text and "\\>" end of word. +-- Word chars are defined by the multi char escape sequence "\\w" +-- +-- Examples +-- +-- > grep "a" ["_a_", "_a", "a_", "a", "_"] => ["_a_", "_a", "a_", "a"] +-- > grep "^a" ["_a_", "_a", "a_", "a", "_"] => ["a_", "a"] +-- > grep "a$" ["_a_", "_a", "a_", "a", "_"] => ["_a", "a"] +-- > grep "^a$" ["_a_", "_a", "a_", "a", "_"] => ["a"] +-- > grep "\\ ["x a b", " ax "] +-- > grep "a\\>" ["x a b", " ax ", " xa ", "xab"] => ["x a b", " xa "] + +grep :: String -> [String] -> [String] +grep re = filter (matchRE re') + where + re' = mkSeqs . concat $ [ startContext + , (:[]) . parseRegex $ re2 + , endContext + ] + (startContext, re1) + | "^" `isPrefixOf` re = ([], tail re) + | "\\<" `isPrefixOf` re = ([parseRegex "(\\A\\W)?"], drop 2 re) + | otherwise = ([mkStar mkDot], re) + (endContext, re2) + | "$" `isSuffixOf` re1 = ([], init re1) + | "\\>" `isSuffixOf` re1 = ([parseRegex "(\\W\\A)?"], init . init $ re1) + | otherwise = ([mkStar mkDot], re1) -- ------------------------------------------------------------ diff --git a/src/Text/Regex/XMLSchema/String/Regex.hs b/src/Text/Regex/XMLSchema/String/Regex.hs --- a/src/Text/Regex/XMLSchema/String/Regex.hs +++ b/src/Text/Regex/XMLSchema/String/Regex.hs @@ -26,12 +26,14 @@ , mkSym , mkSym1 , mkSymRng + , mkWord , mkDot , mkStar , mkAll , mkAlt , mkElse , mkSeq + , mkSeqs , mkRep , mkRng , mkOpt @@ -50,10 +52,14 @@ , delta1 , delta + , firstChars + , matchWithRegex , matchWithRegex' , splitWithRegex , splitWithRegex' + , splitWithRegexCS + , splitWithRegexCS' ) where @@ -150,6 +156,10 @@ mkSymRng c1 c2 = mkSym $ rangeCS c1 c2 {-# INLINE mkSymRng #-} +-- | mkSym generaized for strings +mkWord :: [Char] -> GenRegex l +mkWord = mkSeqs . map mkSym1 + -- | construct an r.e. for the set of all Unicode chars mkDot :: GenRegex l mkDot = Dot @@ -239,6 +249,10 @@ mkSeq (Seq e1 e2) e3 = mkSeq e1 (mkSeq e2 e3) mkSeq e1 e2 = Seq e1 e2 +-- | mkSeq extened to lists +mkSeqs :: [GenRegex l] -> GenRegex l +mkSeqs = foldr mkSeq mkUnit + -- | Construct repetition r{i,} mkRep :: Eq l => Int -> GenRegex l -> GenRegex l mkRep 0 e = mkStar e @@ -474,6 +488,34 @@ -- ------------------------------------------------------------ +-- | FIRST for regular expressions +-- +-- this is only an approximation, the real set of char may be smaller, +-- when the expression contains intersection, set difference or exor operators + +firstChars :: GenRegex l -> CharSet + +firstChars (Zero _) = emptyCS +firstChars Unit = emptyCS +firstChars (Sym p) = p +firstChars Dot = allCS + +firstChars (Star e1) = firstChars e1 +firstChars (Alt e1 e2) = firstChars e1 `unionCS` firstChars e2 +firstChars (Else e1 e2) = firstChars e1 `unionCS` firstChars e2 +firstChars (Seq e1 e2) + | nullable e1 = firstChars e1 `unionCS` firstChars e2 + | otherwise = firstChars e1 +firstChars (Rep _i e) = firstChars e +firstChars (Rng _i _j e) = firstChars e +firstChars (Diff e1 _e2) = firstChars e1 -- this is an approximation +firstChars (Isec e1 e2) = firstChars e1 `intersectCS` firstChars e2 -- this is an approximation +firstChars (Exor e1 e2) = firstChars e1 `unionCS` firstChars e2 -- this is an approximation +firstChars (Br _l e _s) = firstChars e +firstChars (Cbr e _ss) = firstChars e + +-- ------------------------------------------------------------ + delta1 :: Eq l => GenRegex l -> Char -> GenRegex l delta1 e@(Zero _) _ = e delta1 Unit c = mkZero $ @@ -485,6 +527,7 @@ delta1 Dot _ = mkUnit +delta1 e@(Star Dot) _ = e delta1 e@(Star e1) c = mkSeq (delta1 e1 c) e delta1 (Alt e1 e2) c = mkAlt (delta1 e1 c) (delta1 e2 c) @@ -545,6 +588,11 @@ (re', rest) <- splitWithRegex' (mkBr' re) inp return ( snd . nullable' $ re', rest) +splitWithRegexCS :: Eq l => GenRegex l -> CharSet -> String -> Maybe ([(Label l,String)], String) +splitWithRegexCS re cs inp = do + (re', rest) <- splitWithRegexCS' (mkBr' re) cs inp + return ( snd . nullable' $ re', rest) + -- | The main scanner function splitWithRegex' :: Eq l => GenRegex l -> String -> Maybe (GenRegex l, String) @@ -560,5 +608,22 @@ | nullable re = Just (re, inp) | otherwise = Nothing evalRes res = res + +-- | speedup version for splitWithRegex' +-- +-- This function checks whether the input starts with a char from FIRST re. +-- If this is not the case, the split fails. The FIRST set can be computed once +-- for a whole tokenizer and reused by every call of split + +splitWithRegexCS' :: Eq l => GenRegex l -> CharSet -> String -> Maybe (GenRegex l, String) + +splitWithRegexCS' re _cs "" + | nullable re = Just (re, "") + | otherwise = Nothing + +splitWithRegexCS' re cs inp@(c : _) + | c `elemCS` cs = splitWithRegex' re inp + | nullable re = Just (re, inp) + | otherwise = Nothing -- ------------------------------------------------------------ diff --git a/src/Text/Regex/XMLSchema/String/RegexParser.hs b/src/Text/Regex/XMLSchema/String/RegexParser.hs --- a/src/Text/Regex/XMLSchema/String/RegexParser.hs +++ b/src/Text/Regex/XMLSchema/String/RegexParser.hs @@ -127,7 +127,7 @@ seqList = do rs <- many piece - return $ foldr mkSeq mkUnit rs + return $ mkSeqs rs piece :: Parser Regex piece