hxt-regex-xmlschema 9.1.0 → 9.2.0
raw patch · 19 files changed
+3472/−1811 lines, 19 filesdep +HUnitdep +bytestringdep +criteriondep ~basedep ~parsec
Dependencies added: HUnit, bytestring, criterion, deepseq, hxt-regex-xmlschema, text
Dependency ranges changed: base, parsec
Files
- hxt-regex-xmlschema.cabal +73/−16
- src/Text/Regex/Glob/Generic.hs +51/−0
- src/Text/Regex/Glob/Generic/RegexParser.hs +112/−0
- src/Text/Regex/Glob/String.hs +19/−12
- src/Text/Regex/Glob/String/RegexParser.hs +0/−113
- src/Text/Regex/XMLSchema/Generic.hs +106/−0
- src/Text/Regex/XMLSchema/Generic/Matching.hs +454/−0
- src/Text/Regex/XMLSchema/Generic/Regex.hs +728/−0
- src/Text/Regex/XMLSchema/Generic/RegexParser.hs +530/−0
- src/Text/Regex/XMLSchema/Generic/StringLike.hs +175/−0
- src/Text/Regex/XMLSchema/String.hs +47/−126
- src/Text/Regex/XMLSchema/String/Regex.hs +0/−665
- src/Text/Regex/XMLSchema/String/RegexParser.hs +0/−520
- test/.ghci +0/−2
- test/Benchmark.hs +74/−0
- test/Date.hs +633/−0
- test/Main.hs +0/−343
- test/Makefile +0/−14
- test/SimpleTest.hs +470/−0
hxt-regex-xmlschema.cabal view
@@ -1,16 +1,20 @@ Name: hxt-regex-xmlschema-Version: 9.1.0+Version: 9.2.0 Synopsis: A regular expression library for W3C XML Schema regular expressions Description: This library supports full W3C XML Schema regular expressions inclusive all Unicode character sets and blocks. The complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>. It is implemented by the technique of derivations of regular expressions.+ . The W3C syntax is extended to support not only union of regular sets, but also intersection, set difference, exor. Matching of subexpressions is also supported.+ . The library can be used for constricting lightweight scanners and tokenizers. It is a standalone library, no external regex libraries are used.- This package is a substitute for the old regex-xmlschema package.+ .+ Extensions in 9.2: The library does nor only support String's, but also+ ByteString's and Text in strict and lazy variants License: MIT License-file: LICENSE Author: Uwe Schmidt@@ -20,12 +24,9 @@ Category: Text Homepage: http://www.haskell.org/haskellwiki/Regular_expressions_for_XML_Schema Build-type: Simple-Cabal-version: >=1.6+Cabal-version: >=1.18 extra-source-files:- test/Main.hs- test/Makefile- test/.ghci examples/colorizeProgs/ColorizeSourceCode.hs examples/colorizeProgs/Makefile examples/performance/REtest.hs@@ -35,17 +36,73 @@ Library Exposed-modules:- Text.Regex.XMLSchema.String.RegexParser- Text.Regex.XMLSchema.String.Regex- Text.Regex.XMLSchema.String- Text.Regex.Glob.String.RegexParser Text.Regex.Glob.String+ Text.Regex.Glob.Generic+ Text.Regex.Glob.Generic.RegexParser+ Text.Regex.XMLSchema.String+ Text.Regex.XMLSchema.Generic+ Text.Regex.XMLSchema.Generic.Matching+ Text.Regex.XMLSchema.Generic.RegexParser+ Text.Regex.XMLSchema.Generic.Regex+ Text.Regex.XMLSchema.Generic.StringLike - hs-source-dirs: src+ hs-source-dirs: src - ghc-options: -Wall- ghc-prof-options: -auto-all -caf-all+ default-language: Haskell2010 - build-depends: base >= 4 && < 5,- parsec >= 2.1 && < 4,- hxt-charproperties >= 9 && < 10+ ghc-options: -threaded -rtsopts + -Wall -fwarn-tabs -funbox-strict-fields++ ghc-prof-options: -auto-all -caf-all++ build-depends: base >= 4 && < 5+ , bytestring >= 0.10+ , hxt-charproperties >= 9 && < 10+ , parsec >= 2.1 && < 4+ , text >= 0.10++test-suite SimpleMatch+ hs-source-dirs: test+ main-is: SimpleTest.hs+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -Wall++ build-depends: base+ , bytestring+ , hxt-regex-xmlschema+ , text+ , HUnit++test-suite Date+ hs-source-dirs: test+ main-is: Date.hs+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -Wall++ build-depends: base+ , bytestring+ , hxt-regex-xmlschema+ , parsec >= 2+ , text+ , HUnit++Benchmark Benchmark+ hs-source-dirs: test+ main-is: Benchmark.hs+ type: exitcode-stdio-1.0++ default-language: Haskell2010++ ghc-options: -Wall -O2 -rtsopts++ build-depends: base+ , bytestring+ , criterion >= 1+ , deepseq >= 1.2+ , hxt-regex-xmlschema+ , parsec >= 2+ , text++
+ src/Text/Regex/Glob/Generic.hs view
@@ -0,0 +1,51 @@+-- ------------------------------------------------------------++{- |+ Module : Text.Regex.Glob.String+ Copyright : Copyright (C) 2011- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt <uwe@fh-wedel.de>+ Stability : stable+ Portability: portable++ csh glob style pattern matcher+-}++-- ------------------------------------------------------------++module Text.Regex.Glob.Generic+ ( GenRegex+ , Regex+ , RegexText+ , RegexTextLazy+ , RegexByteString+ , RegexByteStringLazy+ , match+ , matchNoCase+ , parseRegex+ , parseRegexNoCase+ )+where++import Text.Regex.Glob.Generic.RegexParser (parseRegex, parseRegexNoCase)+import Text.Regex.XMLSchema.Generic.Regex (matchWithRegex)+import Text.Regex.XMLSchema.Generic.StringLike+import Text.Regex.XMLSchema.Generic (GenRegex,+ Regex,+ RegexText,+ RegexTextLazy,+ RegexByteString,+ RegexByteStringLazy+ )+ ++-- ------------------------------------------------------------++match :: StringLike s => s -> s -> Bool+match = matchWithRegex . parseRegex++matchNoCase :: StringLike s => s -> s -> Bool+matchNoCase = matchWithRegex . parseRegexNoCase++-- ------------------------------------------------------------
+ src/Text/Regex/Glob/Generic/RegexParser.hs view
@@ -0,0 +1,112 @@+-- ------------------------------------------------------------++{- |+ Copyright : Copyright (C) 2014- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : stable+ Portability: portable++ csh style Glob Pattern Parser for Regular Expressions+-}++-- ------------------------------------------------------------++module Text.Regex.Glob.Generic.RegexParser+ ( parseRegex+ , parseRegexNoCase+ )+where++import Data.Char ( isLower+ , isUpper+ , toLower+ , toUpper+ )++import Text.ParserCombinators.Parsec+import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.StringLike++-- ------------------------------------------------------------++-- | parse a glob pattern++parseRegex :: StringLike s => s -> GenRegex s+parseRegex+ = parseRegex' mkSymRng . toString++parseRegexNoCase :: StringLike s => s -> GenRegex s+parseRegexNoCase+ = parseRegex' mkNoCaseSymRng . toString++parseRegex' :: StringLike s => (Char -> Char -> GenRegex s) -> String -> GenRegex s+parseRegex' mkS+ = either (mkZero' . ("syntax error: " ++) . show) id+ .+ parse ( do+ r <- pattern mkS+ eof+ return r+ ) ""++-- ------------------------------------------------------------++pattern :: StringLike s => (Char -> Char -> GenRegex s) -> Parser (GenRegex s)+pattern mkS+ = many part >>= return . mkSeqs+ where+ -- part :: Parser (GenRegex s)+ part+ = ( many1 (noneOf "\\?*[{") >>= return . mkWord' )+ <|>+ ( char '?' >> return mkDot )+ <|>+ ( char '*' >> return mkAll )+ <|>+ ( between (char '{') (char '}') wordList )+ <|>+ ( between (char '[') (char ']') charSet )+ <|>+ ( do c <- char '\\' >> anyChar+ return $ mkS c c+ )+ mkWord'+ = mkSeqs . map (\ c -> mkS c c)++ -- wordList :: Parser (GenRegex s)+ wordList+ = sepBy (many1 (noneOf ",}")) (char ',')+ >>= return . foldr mkAlt (mkZero' "") . map mkWord'++ -- charSet :: Parser (GenRegex s)+ charSet+ = ( do p1 <- charSet' anyChar+ ps <- many $ charSet' (noneOf "]")+ return $ foldr mkAlt (mkZero' "") (p1 : ps)+ )+ where+ charSet' cp+ = do c1 <- cp+ c2 <- rest c1+ return $ mkS c1 c2+ rest c1+ = option c1 (char '-' >> anyChar)++-- ------------------------------------------------------------++mkNoCaseSymRng :: StringLike s => Char -> Char -> GenRegex s+mkNoCaseSymRng c1 c2+ | isLower c1+ &&+ isLower c2+ = mkAlt (mkSymRng (toUpper c1) (toUpper c2)) (mkSymRng c1 c2)+ | isUpper c1+ &&+ isUpper c2+ = mkAlt (mkSymRng (toLower c1) (toLower c2)) (mkSymRng c1 c2)+ | otherwise+ = mkSymRng c1 c2++-- ------------------------------------------------------------
src/Text/Regex/Glob/String.hs view
@@ -15,23 +15,30 @@ -- ------------------------------------------------------------ module Text.Regex.Glob.String- ( Regex- , match- , matchNoCase- , parseRegex- , parseRegexNoCase- )+ {-# DEPRECATED "use the more general 'Text.Regex.Glob.Generic' instead" #-}+ ( Regex+ , match+ , matchNoCase+ , parseRegex+ , parseRegexNoCase+ ) where -import Text.Regex.XMLSchema.String.Regex-import Text.Regex.Glob.String.RegexParser+import Text.Regex.Glob.Generic (Regex)+import qualified Text.Regex.Glob.Generic as G -- ------------------------------------------------------------ -match :: String -> String -> Bool-match = matchWithRegex . parseRegex+match :: String -> String -> Bool+match = G.match -matchNoCase :: String -> String -> Bool-matchNoCase = matchWithRegex . parseRegexNoCase+matchNoCase :: String -> String -> Bool+matchNoCase = G.matchNoCase++parseRegex :: String -> Regex+parseRegex = G.parseRegex++parseRegexNoCase :: String -> Regex+parseRegexNoCase = G.parseRegexNoCase -- ------------------------------------------------------------
− src/Text/Regex/Glob/String/RegexParser.hs
@@ -1,113 +0,0 @@--- --------------------------------------------------------------{- |- Module : Text.Regex.Glob.String.RegexParser- Copyright : Copyright (C) 2010- Uwe Schmidt- License : MIT-- Maintainer : Uwe Schmidt (uwe@fh-wedel.de)- Stability : stable- Portability: portable-- csh style Glob Pattern Parser for Regular Expressions--}---- --------------------------------------------------------------module Text.Regex.Glob.String.RegexParser- ( parseRegex- , parseRegexNoCase- )-where--import Data.Char ( isLower- , isUpper- , toLower- , toUpper- )--import Text.ParserCombinators.Parsec--import Text.Regex.XMLSchema.String.Regex----- ---------------------------------------------------------------- | parse a glob pattern--parseRegex :: String -> Regex-parseRegex- = parseRegex' mkSymRng--parseRegexNoCase :: String -> Regex-parseRegexNoCase- = parseRegex' mkNoCaseSymRng--parseRegex' :: (Char -> Char -> Regex) -> String -> Regex-parseRegex' mkS- = either (mkZero . ("syntax error: " ++) . show) id- .- parse ( do- r <- pattern mkS- eof- return r- ) ""---- --------------------------------------------------------------pattern :: (Char -> Char -> Regex) -> Parser Regex-pattern mkS- = many part >>= return . mkSeqs- where- part :: Parser Regex- part- = ( many1 (noneOf "\\?*[{") >>= return . mkWord' )- <|>- ( char '?' >> return mkDot )- <|>- ( char '*' >> return mkAll )- <|>- ( between (char '{') (char '}') wordList )- <|>- ( between (char '[') (char ']') charSet )- <|>- ( do c <- char '\\' >> anyChar- return $ mkS c c- )- mkWord'- = mkSeqs . map (\ c -> mkS c c)-- wordList :: Parser Regex- wordList- = sepBy (many1 (noneOf ",}")) (char ',') >>= return . foldr mkAlt (mkZero "") . map mkWord'-- charSet :: Parser Regex- charSet- = ( do p1 <- charSet' anyChar- ps <- many $ charSet' (noneOf "]")- return $ foldr mkAlt (mkZero "") (p1 : ps)- )- where- charSet' cp- = do c1 <- cp- c2 <- rest c1- return $ mkS c1 c2- rest c1- = option c1 (char '-' >> anyChar)---- --------------------------------------------------------------mkNoCaseSymRng :: Char -> Char -> Regex-mkNoCaseSymRng c1 c2- | isLower c1- &&- isLower c2- = mkAlt (mkSymRng (toUpper c1) (toUpper c2)) (mkSymRng c1 c2)- | isUpper c1- &&- isUpper c2- = mkAlt (mkSymRng (toLower c1) (toLower c2)) (mkSymRng c1 c2)- | otherwise- = mkSymRng c1 c2---- ------------------------------------------------------------
+ src/Text/Regex/XMLSchema/Generic.hs view
@@ -0,0 +1,106 @@+-- ------------------------------------------------------------++{- |+ Module : Text.Regex.XMLSchema.Generic+ Copyright : Copyright (C) 2014- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt <uwe@fh-wedel.de>+ Stability : stable+ Portability: portable++ Convenient functions for W3C XML Schema Regular Expression Matcher.+ For internals see 'Text.Regex.XMLSchema.Generic.Regex' and+ 'Text.Regex.XMLSchema.Generic.Matching'++ Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>+-}++-- ------------------------------------------------------------++module Text.Regex.XMLSchema.Generic+ ( GenRegex+ , Regex+ , RegexText+ , RegexTextLazy+ , RegexByteString+ , RegexByteStringLazy+ + , grep+ , grepExt+ , grepRE+ , grepREwithLineNum++ , match+ , matchExt+ , matchSubex++ , sed+ , sedExt++ , split+ , splitExt+ , splitSubex++ , tokenize+ , tokenizeExt+ , tokenize'+ , tokenizeExt'+ , tokenizeSubex++ , matchRE+ , matchSubexRE+ , sedRE+ , splitRE+ , splitSubexRE+ , tokenizeRE+ , tokenizeRE'+ , tokenizeSubexRE++ , mkZero+ , mkZero'+ , mkUnit+ , mkSym1+ , mkSymRng+ , mkWord+ , mkDot+ , mkStar+ , mkAll+ , mkAlt+ , mkElse+ , mkSeq+ , mkSeqs+ , mkRep+ , mkRng+ , mkOpt+ , mkDiff+ , mkIsect+ , mkExor+ , mkCompl+ , mkBr+ , mkBr'+ , isZero+ , errRegex++ , parseRegex+ , parseRegexExt+ , parseContextRegex+ )+where++import Text.Regex.XMLSchema.Generic.Matching+import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.RegexParser++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL++type Regex = GenRegex String+type RegexText = GenRegex T.Text+type RegexTextLazy = GenRegex TL.Text+type RegexByteString = GenRegex B.ByteString+type RegexByteStringLazy = GenRegex BL.ByteString++-- ------------------------------------------------------------
+ src/Text/Regex/XMLSchema/Generic/Matching.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE BangPatterns #-}++-- ------------------------------------------------------------++{- |+ Module : Text.Regex.XMLSchema.Generic+ Copyright : Copyright (C) 2014- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt <uwe@fh-wedel.de>+ Stability : stable+ Portability: portable++ Convenient functions for W3C XML Schema Regular Expression Matcher.+ For internals see 'Text.Regex.XMLSchema.Regex'++ Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>++-}++-- ------------------------------------------------------------++module Text.Regex.XMLSchema.Generic.Matching+ ( grep+ , grepExt+ , grepRE+ , grepREwithLineNum++ , match+ , matchExt+ , matchSubex++ , sed+ , sedExt++ , split+ , splitExt+ , splitSubex++ , tokenize+ , tokenizeExt+ , tokenize'+ , tokenizeExt'+ , tokenizeSubex++ , matchRE+ , matchSubexRE+ , sedRE+ , splitRE+ , splitSubexRE+ , tokenizeRE+ , tokenizeRE'+ , tokenizeSubexRE+ )+where++import Control.Arrow++import Data.Maybe++import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.RegexParser+import Text.Regex.XMLSchema.Generic.StringLike++{-+import Debug.Trace (traceShow)++trc :: Show a => String -> a -> a+trc msg x = traceShow (msg, x) x++-- -}+-- ------------------------------------------------------------++-- | split a string by taking the longest prefix matching a regular expression+--+-- @Nothing@ is returned in case there is no matching prefix,+-- else the pair of prefix and rest is returned++splitRE :: StringLike s => GenRegex s -> s -> Maybe (s, s)+splitRE re input+ = do+ (sms, rest) <- splitWithRegex re input+ return (snd . head $ sms, rest)++-- | convenient function for 'splitRE'+--+-- examples:+--+-- > split "a*b" "abc" = ("ab","c")+-- > split "a*" "bc" = ("", "bc") -- "a*" matches ""+-- > split "a+" "bc" = ("", "bc") -- "a+" does not match, no split+-- > split "[" "abc" = ("", "abc") -- "[" syntax error, no split++split :: StringLike s => s -> s -> (s, s)+split = split' parseRegex++-- | split with extended syntax++splitExt :: StringLike s => s -> s -> (s, s)+splitExt = split' parseRegexExt++split' :: StringLike s => (s -> GenRegex s) -> s -> s -> (s, s)+split' parseRe re input+ = fromMaybe (emptyS, input)+ . (splitRE . parseRe $ re) $ input++-- ------------------------------------------------------------++-- | split a string by removing the longest prefix matching a regular expression+-- and then return the list of subexpressions found in the matching part+--+-- @Nothing@ is returned in case of no matching prefix,+-- else the list of pairs of labels and submatches and the+-- rest is returned++splitSubexRE :: StringLike s => GenRegex s -> s -> Maybe ([(s, s)], s)+splitSubexRE re input+ = do+ (sms, rest) <- splitWithRegex re input+ return (map (first fromJust) . drop 1 $ sms, rest)++-- | convenient function for 'splitSubex', uses extended syntax+--+-- examples:+--+-- > splitSubex "({1}a*)b" "abc" = ([("1","a")],"c")+-- > splitSubex "({2}a*)" "bc" = ([("2","")], "bc")+-- > splitSubex "({1}a|b)+" "abc" = ([("1","a"),("1","b")],"c") -- subex 1 matches 2 times+-- >+-- > splitSubex ".*({x}a*)" "aa" = ([("x",""),("x","a"),("x","aa")],"")+-- > -- nondeterminism: 3 matches for a*+-- >+-- > splitSubex "({1}do)|({2}[a-z]+)" "do you know"+-- > = ([("1","do"),("2","do")]," you know")+-- > -- nondeterminism: 2 matches for do+-- >+-- > splitSubex "({1}do){|}({2}[a-z]+)" "do you know"+-- > = ([("1","do")]," you know")+-- > -- no nondeterminism with {|}: 1. match for do+-- >+-- > splitSubex "({1}a+)" "bcd" = ([], "bcd") -- no match+-- > splitSubex "[" "abc" = ([], "abc") -- syntax error+++splitSubex :: StringLike s => s -> s -> ([(s, s)], s)+splitSubex re inp+ = fromMaybe ([], inp) . (splitSubexRE . parseRegexExt $ re) $ inp++-- ------------------------------------------------------------++-- | The function, that does the real work for 'tokenize'++tokenizeRE :: StringLike s => GenRegex s -> s -> [s]+tokenizeRE re+ = token''+ where+ fcs = firstChars re+ re1 = mkDiff re mkUnit+ token'' = token' re fcs+ token1'' = token' re1 fcs++ -- token' :: StringLike s => GenRegex s -> CharSet -> s -> [s]+ token' re' fcs' inp+ | nullS inp = []+ | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp+ where+ evalRes Nothing+ = token'' (dropS 1 inp) -- re does not match any prefix++ evalRes (Just (toks, rest))+ | nullS tok = tok : token'' (dropS 1 rest) -- re is nullable and only the empty prefix matches+ -- discard one char and try again+ | otherwise = tok : token1'' rest -- real token found, next token must not be empty+ where+ tok = snd . head $ toks++-- | split a string into tokens (words) by giving a regular expression+-- which all tokens must match.+--+-- Convenient function for 'tokenizeRE'+--+-- This can be used for simple tokenizers.+-- It is recommended to use regular expressions where the empty word does not match.+-- Else there will appear a lot of probably useless empty tokens in the output.+-- All none matching chars are discarded. If the given regex contains syntax errors,+-- @Nothing@ is returned+--+-- examples:+--+-- > tokenize "a" "aabba" = ["a","a","a"]+-- > tokenize "a*" "aaaba" = ["aaa","a"]+-- > tokenize "a*" "bbb" = ["","",""]+-- > tokenize "a+" "bbb" = []+-- >+-- > tokenize "a*b" "" = []+-- > tokenize "a*b" "abc" = ["ab"]+-- > tokenize "a*b" "abaab ab" = ["ab","aab","ab"]+-- >+-- > tokenize "[a-z]{2,}|[0-9]{2,}|[0-9]+[.][0-9]+" "ab123 456.7abc"+-- > = ["ab","123","456.7","abc"]+-- >+-- > tokenize "[a-z]*|[0-9]{2,}|[0-9]+[.][0-9]+" "cab123 456.7abc"+-- > = ["cab","123","456.7","abc"]+-- >+-- > tokenize "[^ \t\n\r]*" "abc def\t\n\rxyz"+-- > = ["abc","def","xyz"]+-- >+-- > tokenize ".*" "\nabc\n123\n\nxyz\n"+-- > = ["","abc","123","","xyz"]+-- >+-- > tokenize ".*" = lines+-- >+-- > tokenize "[^ \t\n\r]*" = words++tokenize :: StringLike s => s -> s -> [s]+tokenize = tokenizeRE . parseRegex++-- | tokenize with extended syntax++tokenizeExt :: StringLike s => s -> s -> [s]+tokenizeExt = tokenizeRE . parseRegexExt++-- ------------------------------------------------------------++-- | split a string into tokens and delimierter by giving a regular expression+-- which all tokens must match+--+-- This is a generalisation of the above 'tokenizeRE' functions.+-- The none matching char sequences are marked with @Left@, the matching ones are marked with @Right@+--+-- If the regular expression contains syntax errors @Nothing@ is returned+--+-- The following Law holds:+--+-- > concat . map (either id id) . tokenizeRE' re == id++tokenizeRE' :: StringLike s => GenRegex s -> s -> [Either s s]+tokenizeRE' re inp0+ = token'' (inp0, 0) inp0+ where+ fcs = firstChars re+ re1 = mkDiff re mkUnit+ token'' = token' re fcs+ token1'' = token' re1 fcs++ -- token' :: StringLike s => GenRegex s -> CharSet -> (s, Int) -> s -> [Either s s]+ token' re' fcs' (uns, ! n) inp+ | nullS inp = addUnmatched []+ | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp+ where+ addUnmatched+ | n == 0 = id+ | otherwise = ((Left $ takeS n uns) :)++ addMatched t+ = addUnmatched . ((Right t) :)++ evalRes Nothing+ = token'' (uns, n + 1) (dropS 1 inp) -- re does not match any prefix++ evalRes (Just (toks, rest))+ | nullS tok = addMatched tok -- re is nullable and only the empty prefix matches+ $ token'' (rest, 1)+ (dropS 1 rest) -- discard one char and try again++ | otherwise = addMatched tok+ $ token1'' (rest, 0) rest -- real token found, next token must not be empty+ where+ tok = snd . head $ toks++-- | convenient function for 'tokenizeRE''+--+-- When the regular expression parses as Zero, @[Left input]@ is returned, that means no tokens are found++tokenize' :: StringLike s => s -> s -> [Either s s]+tokenize' = tokenizeRE' . parseRegex++tokenizeExt' :: StringLike s => s -> s -> [Either s s]+tokenizeExt' = tokenizeRE' . parseRegexExt++-- ------------------------------------------------------------++-- | split a string into tokens (pair of labels and words) by giving a regular expression+-- containing labeled subexpressions.+--+-- This function should not be called with regular expressions+-- without any labeled subexpressions. This does not make sense, because the result list+-- will always be empty.+--+-- Result is the list of matching subexpressions+-- This can be used for simple tokenizers.+-- At least one char is consumed by parsing a token.+-- The pairs in the result list contain the matching substrings.+-- All none matching chars are discarded. If the given regex contains syntax errors,+-- @Nothing@ is returned++tokenizeSubexRE :: StringLike s => GenRegex s -> s -> [(s, s)]+tokenizeSubexRE re+ = token''+ where+ fcs = firstChars re+ re1 = mkDiff re mkUnit+ token'' = token' re fcs+ token1'' = token' re1 fcs++ -- token' :: StringLike s => GenRegex s -> CharSet -> s -> [(s, s)]+ token' re' fcs' inp+ | nullS inp = []+ | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp+ where+ evalRes Nothing+ = token'' (dropS 1 inp) -- re does not match any prefix++ evalRes (Just (toks, rest))+ | nullS tok = res ++ token'' (dropS 1 rest) -- re is nullable and only the empty prefix matches+ | otherwise = res ++ token1'' rest -- token found, tokenize the rest+ where+ res = map (first fromJust) . tail $ toks+ tok = snd . head $ toks++-- | convenient function for 'tokenizeSubexRE' a string+--+-- examples:+--+-- > tokenizeSubex "({name}[a-z]+)|({num}[0-9]{2,})|({real}[0-9]+[.][0-9]+)"+-- > "cab123 456.7abc"+-- > = [("name","cab")+-- > ,("num","123")+-- > ,("real","456.7")+-- > ,("name","abc")]+-- >+-- > tokenizeSubex "({real}({n}[0-9]+)([.]({f}[0-9]+))?)"+-- > "12.34" = [("real","12.34")+-- > ,("n","12")+-- > ,("f","34")]+-- >+-- > tokenizeSubex "({real}({n}[0-9]+)([.]({f}[0-9]+))?)"+-- > "12 34" = [("real","12"),("n","12")+-- > ,("real","34"),("n","34")]+-- >+-- > tokenizeSubex "({real}({n}[0-9]+)(([.]({f}[0-9]+))|({f})))"+-- > "12 34.56" = [("real","12"),("n","12"),("f","")+-- > ,("real","34.56"),("n","34"),("f","56")]++tokenizeSubex :: StringLike s => s -> s -> [(s, s)]+tokenizeSubex = tokenizeSubexRE . parseRegexExt++-- ------------------------------------------------------------++-- | sed like editing function+--+-- All matching tokens are edited by the 1. argument, the editing function,+-- all other chars remain as they are++sedRE :: StringLike s => (s -> s) -> GenRegex s -> s -> s+sedRE edit re = concatS . map (either id edit) . tokenizeRE' re++-- | convenient function for 'sedRE'+--+-- examples:+--+-- > sed (const "b") "a" "xaxax" = "xbxbx"+-- > sed (\ x -> x ++ x) "a" "xax" = "xaax"+-- > sed undefined "[" "xxx" = "xxx"++sed :: StringLike s => (s -> s) -> s -> s -> s+sed edit = sedRE edit . parseRegex++sedExt :: StringLike s => (s -> s) -> s -> s -> s+sedExt edit = sedRE edit . parseRegexExt++-- ------------------------------------------------------------++-- | match a string with a regular expression++matchRE :: StringLike s => GenRegex s -> s -> Bool+matchRE = matchWithRegex++-- | convenient function for 'matchRE'+--+-- Examples:+--+-- > match "x*" "xxx" = True+-- > match "x" "xxx" = False+-- > match "[" "xxx" = False++match :: StringLike s => s -> s -> Bool+match = matchWithRegex . parseRegex++-- | match with extended regular expressions++matchExt :: StringLike s => s -> s -> Bool+matchExt = matchWithRegex . parseRegexExt++-- ------------------------------------------------------------++-- | match a string with a regular expression+-- and extract subexpression matches++matchSubexRE :: StringLike s => GenRegex s -> s -> [(s, s)]+matchSubexRE re = map (first fromJust) . fromMaybe [] . matchWithRegex' re++-- | convenient function for 'matchRE'+--+-- Examples:+--+-- > matchSubex "({1}x*)" "xxx" = [("1","xxx")]+-- > matchSubex "({1}x*)" "y" = []+-- > matchSubex "({w}[0-9]+)x({h}[0-9]+)" "800x600" = [("w","800"),("h","600")]+-- > matchSubex "[" "xxx" = []++matchSubex :: StringLike s => s -> s -> [(s, s)]+matchSubex = matchSubexRE . parseRegexExt++-- ------------------------------------------------------------++-- | 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 "\\<a" ["x a b", " ax ", " xa ", "xab"] => ["x a b", " ax "]+-- > grep "a\\>" ["x a b", " ax ", " xa ", "xab"] => ["x a b", " xa "]++grep :: StringLike s => s -> [s] -> [s]+grep = grep' parseRegex'++-- | grep with extended regular expressions++grepExt :: StringLike s => s -> [s] -> [s]+grepExt = grep' parseRegexExt'++grep' :: StringLike s => (String -> GenRegex s) -> s -> [s] -> [s]+grep' parseRe = grepRE . parseContextRegex parseRe++-- | grep with already prepared Regex (ususally with 'parseContextRegex')++grepRE :: StringLike s => GenRegex s-> [s] -> [s]+grepRE re = filter (matchRE re)++-- | grep with Regex and line numbers++grepREwithLineNum :: StringLike s => GenRegex s -> [s] -> [(Int, s)]+grepREwithLineNum re = filter (matchRE re . snd) . zip [(1::Int)..]++-- ------------------------------------------------------------
+ src/Text/Regex/XMLSchema/Generic/Regex.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}++-- ------------------------------------------------------------++{- |+ Copyright : Copyright (C) 2014 - Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt <uwe@fh-wedel.de>+ Stability : stable+ Portability: portable++ W3C XML Schema Regular Expression Matcher++ Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>++-}++-- ------------------------------------------------------------++module Text.Regex.XMLSchema.Generic.Regex+ ( GenRegex+ + , mkZero+ , mkZero'+ , mkUnit+ , mkSym+ , mkSym1+ , mkSymRng+ , mkWord+ , mkDot+ , mkStar+ , mkAll+ , mkAlt+ , mkElse+ , mkSeq+ , mkSeqs+ , mkRep+ , mkRng+ , mkOpt+ , mkDiff+ , mkIsect+ , mkExor+ , mkInterleave+ , mkCompl+ , mkBr+ , mkBr'++ , isZero+ , errRegex++ , nullable+ , nullable'++ , delta1+ , delta++ , firstChars++ , matchWithRegex+ , matchWithRegex'+ , splitWithRegex+ , splitWithRegex'+ , splitWithRegexCS+ , splitWithRegexCS'+ )+where++import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Set.CharSet+import Data.String (IsString(..))++import Text.Regex.XMLSchema.Generic.StringLike++{-+import Debug.Trace (traceShow)++trc :: Show a => String -> a -> a+trc msg x = traceShow (msg, x) x++-- -}+-- ------------------------------------------------------------++data GenRegex s+ = Zero s+ | Unit+ | Sym CharSet+ | Dot+ | Star (GenRegex s)+ | Alt (GenRegex s) (GenRegex s)+ | Else (GenRegex s) (GenRegex s)+ | Seq (GenRegex s) (GenRegex s)+ | Rep Int (GenRegex s) -- 1 or more repetitions+ | Rng Int Int (GenRegex s) -- n..m repetitions+ | Diff (GenRegex s) (GenRegex s) -- r1 - r2+ | Isec (GenRegex s) (GenRegex s) -- r1 n r2+ | Exor (GenRegex s) (GenRegex s) -- r1 xor r2+ | Intl (GenRegex s) (GenRegex s) -- r1 interleavedWith r2+ | Br (Label s) (GenRegex s) -- (...) not yet parsed+ | Obr (Label s) s !Int (GenRegex s) -- currently parsed (...)+ | Cbr [(Label s, s)] (GenRegex s) -- already completely parsed (...)+ deriving (Eq, Ord {-, Show -})++type Label s+ = Maybe s -- we need one special label for the whole expression+ -- see splitWithRegex+type SubexResults s+ = [(Label s, s)]+ +type Nullable s+ = (Bool, SubexResults s)++-- ------------------------------------------------------------++{- just for documentation++class Inv a where+ inv :: a -> Bool++instance Inv (GenRegex s) where+ inv (Zero _) = True+ inv Unit = True+ inv (Sym p) = not (nulCS p) && not (fullCS p)+ inv Dot = True+ inv (Star e) = inv e+ inv (Alt e1 e2) = inv e1 &&+ inv e2+ inv (Seq e1 e2) = inv e1 &&+ inv e2+ inv (Rep i e) = i > 0 && inv e+ inv (Rng i j e) = (i < j || (i == j && i > 1)) &&+ inv e+ inv (Diff e1 e2) = inv e1 &&+ inv e2+ inv (Isec e1 e2) = inv e1 &&+ inv e2+ inv (Exor e1 e2) = inv e1 &&+ inv e2+-}++-- ------------------------------------------------------------+--+-- smart constructors++-- | construct the r.e. for the empty set.+-- An (error-) message may be attached++mkZero :: s -> GenRegex s+mkZero = Zero+{-# INLINE mkZero #-}++mkZero' :: (StringLike s) =>+ String -> GenRegex s+mkZero' = Zero . fromString+{-# INLINE mkZero' #-}++-- | construct the r.e. for the set containing the empty word++mkUnit :: GenRegex s+mkUnit = Unit+{-# INLINE mkUnit #-}++-- | construct the r.e. for a set of chars++mkSym :: (StringLike s) =>+ CharSet -> GenRegex s+mkSym s+ | nullCS s = mkZero' "empty char range"+ | fullCS s = mkDot+ | otherwise = Sym s+{-# INLINE mkSym #-}++-- | construct an r.e. for a single char set+mkSym1 :: (StringLike s) =>+ Char -> GenRegex s+mkSym1 = mkSym . singleCS+{-# INLINE mkSym1 #-}++-- | construct an r.e. for an intervall of chars+mkSymRng :: (StringLike s) =>+ Char -> Char -> GenRegex s+mkSymRng c1 c2 = mkSym $ rangeCS c1 c2+{-# INLINE mkSymRng #-}++-- | mkSym generaized for strings+mkWord :: (StringLike s) =>+ [Char] -> GenRegex s+mkWord = mkSeqs . map mkSym1++-- | construct an r.e. for the set of all Unicode chars+mkDot :: GenRegex s+mkDot = Dot+{-# INLINE mkDot #-}++-- | construct an r.e. for the set of all Unicode words++mkAll :: (StringLike s) =>+ GenRegex s+mkAll = mkStar mkDot+{-# INLINE mkAll #-}+++-- | construct r.e. for r*+mkStar :: (StringLike s) =>+ GenRegex s -> GenRegex s+mkStar (Zero _) = mkUnit -- {}* == ()+mkStar e@Unit = e -- ()* == ()+mkStar e@(Star _e1) = e -- (r*)* == r*+mkStar (Rep 1 e1) = mkStar e1 -- (r+)* == r*+mkStar (Rep i e1)+ | i == 1+ ||+ nullable e1 = mkStar e1 -- (r{i,})* == r* when i == 1 or nullable r+mkStar e@(Rng _ _ e1)+ | nullable e = mkStar e1 -- (r{i,j})* == r* when i == 0 or nullable r+mkStar e@(Alt _ _) = Star (rmStar e) -- (a*|b)* == (a|b)*++ {- this is wrong, not generally applicable+mkStar (Br l r s) = mkBr0 l (mkStar r) s -- ({l}r)* == ({l}r*) because we want the longest match as result for the subexpression+ -}+mkStar e = Star e++rmStar :: (StringLike s) =>+ GenRegex s -> GenRegex s+rmStar (Alt e1 e2) = mkAlt (rmStar e1) (rmStar e2)+rmStar (Star e1) = rmStar e1+rmStar (Rep 1 e1) = rmStar e1+rmStar e1 = e1++-- | construct the r.e for r1|r2++mkAlt :: (StringLike s) =>+ GenRegex s -> GenRegex s -> GenRegex s+mkAlt e1 (Zero _) = e1 -- e1 u {} = e1+mkAlt (Zero _) e2 = e2 -- {} u e2 = e2+mkAlt (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates+mkAlt e1 e2@(Sym _) = mkAlt e2 e1 -- symmetry: predicates always first+mkAlt e1@(Sym _) (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates+mkAlt (Sym _) e2@Dot = e2 -- c|. = . for a c's+mkAlt e1@(Star Dot) _e2 = e1 -- A* u e1 = A*+mkAlt _e1 e2@(Star Dot) = e2 -- e1 u A* = A*+mkAlt (Alt e1 e2) e3 = mkAlt e1 (mkAlt e2 e3) -- associativity+mkAlt e1 e2+ | e1 == e2 = e1+ | otherwise = Alt e1 e2++-- | construct the r.e. for r1{|}r2 (r1 orElse r2).+--+-- This represents the same r.e. as r1|r2, but when+-- collecting the results of subexpressions in (...) and r1 succeeds, the+-- subexpressions of r2 are discarded, so r1 matches are prioritized+--+-- example+--+-- > splitSubex "({1}x)|({2}.)" "x" = ([("1","x"),("2","x")], "")+-- >+-- > splitSubex "({1}x){|}({2}.)" "x" = ([("1","x")], "")++mkElse :: (StringLike s) =>+ GenRegex s -> GenRegex s -> GenRegex s+mkElse e1 (Zero _) = e1 -- e1 u {} = e1+mkElse (Zero _) e2 = e2 -- {} u e2 = e2+mkElse (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates+ -- no symmetry allowed+mkElse e1@(Sym _) (Else e2@(Sym _) e3) = mkElse (mkElse e1 e2) e3 -- prepare melting of predicates+mkElse (Sym _) e2@Dot = e2 -- c|. = . for a c's+mkElse e1@(Star Dot) _e2 = e1 -- A* u e1 = A*+mkElse _e1 e2@(Star Dot) = e2 -- e1 u A* = A*+mkElse (Else e1 e2) e3 = mkElse e1 (mkElse e2 e3) -- associativity+mkElse e1 e2+ | e1 == e2 = e1+ | otherwise = Else e1 e2++-- | Construct the sequence r.e. r1.r2++mkSeq :: GenRegex s -> GenRegex s -> GenRegex s+mkSeq e1@(Zero _) _e2 = e1+mkSeq _e1 e2@(Zero _) = e2+mkSeq Unit e2 = e2+mkSeq (Cbr ss1 e1) e2 = mkCbr ss1 (mkSeq e1 e2) -- move finished submatches upwards+mkSeq e1 Unit = e1+mkSeq (Seq e1 e2) e3 = mkSeq e1 (mkSeq e2 e3)+mkSeq e1 e2 = Seq e1 e2++-- | mkSeq extened to lists+mkSeqs :: [GenRegex s] -> GenRegex s+mkSeqs = foldr mkSeq mkUnit++-- | Construct repetition r{i,}+mkRep :: (StringLike s) =>+ Int -> GenRegex s -> GenRegex s+mkRep 0 e = mkStar e+mkRep _ e@(Zero _) = e+mkRep _ e+ | nullable e = mkStar e+mkRep i (Rep j e) = mkRep (i * j) e+mkRep i e = Rep i e++-- | Construct range r{i,j}+mkRng :: (StringLike s) =>+ Int -> Int -> GenRegex s -> GenRegex s+mkRng 0 0 _e = mkUnit+mkRng 1 1 e = e+mkRng lb ub _e+ | lb > ub = mkZero' $+ "illegal range " +++ show lb ++ ".." ++ show ub+mkRng _l _u e@(Zero _) = e+mkRng _l _u e@Unit = e+mkRng lb ub e = Rng lb ub e++-- | Construct option r?+mkOpt :: (StringLike s) =>+ GenRegex s -> GenRegex s+mkOpt = mkRng 0 1+{-# INLINE mkOpt #-}++-- | Construct difference r.e.: r1 {\\} r2+--+-- example+--+-- > match "[a-z]+{\\}bush" "obama" = True+-- > match "[a-z]+{\\}bush" "clinton" = True+-- > match "[a-z]+{\\}bush" "bush" = False -- not important any more++mkDiff :: (StringLike s) =>+ GenRegex s -> GenRegex s -> GenRegex s+mkDiff e1@(Zero _) _e2 = e1 -- {} - r2 = {}+mkDiff e1 (Zero _) = e1 -- r1 - {} = r1+mkDiff _e1 (Star Dot) = mkZero' "empty set in difference expr" -- r1 - .* = {}+mkDiff Dot (Sym p) = mkSym $ compCS p -- . - s = ~s+mkDiff (Sym _) Dot = mkZero' "empty set in difference expr" -- x - . = {}+mkDiff (Sym p1) (Sym p2) = mkSym $ p1 `diffCS` p2 -- set diff+mkDiff e1 e2+ | e1 == e2 = mkZero' "empty set in difference expr" -- r1 - r1 = {}+ | otherwise = Diff e1 e2++-- | Construct the Complement of an r.e.: whole set of words - r++mkCompl :: (StringLike s) =>+ GenRegex s -> GenRegex s+mkCompl (Zero _) = mkAll+mkCompl (Star Dot) = mkZero' "empty set in compl expr"+mkCompl e = mkDiff (mkStar mkDot) e++-- | Construct r.e. for intersection: r1 {&} r2+--+-- example+--+-- > match ".*a.*{&}.*b.*" "-a-b-" = True+-- > match ".*a.*{&}.*b.*" "-b-a-" = True+-- > match ".*a.*{&}.*b.*" "-a-a-" = False+-- > match ".*a.*{&}.*b.*" "---b-" = False++mkIsect :: (StringLike s) =>+ GenRegex s -> GenRegex s -> GenRegex s+mkIsect e1@(Zero _) _e2 = e1 -- {} n r2 = {}+mkIsect _e1 e2@(Zero _) = e2 -- r1 n {} = {}+mkIsect e1@(Unit) e2 -- () n r2 = () if nullable r2+ | nullable e2 = e1 -- () n r2 = {} if not nullable r2+ | otherwise = mkZero' "intersection empty"+mkIsect e1 e2@(Unit) = mkIsect e2 e1 -- symmetric version of las 2 laws++mkIsect (Sym p1) (Sym p2) = mkSym $ p1 `intersectCS` p2 -- intersect sets+mkIsect e1@(Sym _) Dot = e1 -- x n . = x+mkIsect Dot e2@(Sym _) = e2 -- . n x = x++mkIsect (Star Dot) e2 = e2 -- .* n r2 = r2+mkIsect e1 (Star Dot) = e1 -- r1 n .* = r1+mkIsect e1 e2+ | e1 == e2 = e1 -- r1 n r1 = r1+ | otherwise = Isec e1 e2++-- | Construct r.e. for exclusive or: r1 {^} r2+--+-- example+--+-- > match "[a-c]+{^}[c-d]+" "abc" = True+-- > match "[a-c]+{^}[c-d]+" "acdc" = False+-- > match "[a-c]+{^}[c-d]+" "ccc" = False+-- > match "[a-c]+{^}[c-d]+" "cdc" = True++mkExor :: (StringLike s) =>+ GenRegex s -> GenRegex s -> GenRegex s+mkExor (Zero _) e2 = e2+mkExor e1 (Zero _) = e1+mkExor (Star Dot) _e2 = mkZero' "empty set in exor expr"+mkExor _e1 (Star Dot) = mkZero' "empty set in exor expr"+mkExor (Sym p1) (Sym p2) = mkSym $ p1 `exorCS` p2+mkExor (Sym p1) Dot = mkSym $ compCS p1+mkExor Dot (Sym p2) = mkSym $ compCS p2+mkExor e1 e2+ | e1 == e2 = mkZero' "empty set in exor expr" -- r1 xor r1 = {}+ | otherwise = Exor e1 e2++mkInterleave :: GenRegex s -> GenRegex s -> GenRegex s+mkInterleave e1@(Zero _) _ = e1+mkInterleave _ e2@(Zero _) = e2+mkInterleave (Unit) e2 = e2+mkInterleave e1 (Unit) = e1+mkInterleave e1 e2 = Intl e1 e2++-- | Construct a labeled subexpression: ({label}r)++mkBr :: s -> GenRegex s -> GenRegex s+mkBr l e = Br (Just l) e++mkBr' :: StringLike s =>+ String -> GenRegex s -> GenRegex s+mkBr' l e = Br (Just $ fromString l) e++mkBrN :: GenRegex s -> GenRegex s+mkBrN e = Br Nothing e++mkObr :: StringLike s =>+ Label s -> s -> Int -> GenRegex s -> GenRegex s+mkObr _ _ _ e@(Zero _) = e+mkObr l s n Unit = mkCbr [(l, takeS n s)] mkUnit+mkObr l s n e = Obr l s n e++mkCbr :: SubexResults s -> GenRegex s -> GenRegex s+mkCbr _ e@(Zero _) = e -- dead end, throw away subexpr matches+mkCbr ss (Cbr ss1 e) = mkCbr (ss <> ss1) e -- join inner and this subexpr match+mkCbr ss e = Cbr ss e++-- ------------------------------------------------------------+ +instance (StringLike s) => Show (GenRegex s) where+ show (Zero e) = "{" ++ toString e ++ "}"+ show Unit = "()"+ show (Sym p)+ | p == compCS (stringCS "\n\r")+ = "."+ | null (tail cs) &&+ rng1 (head cs)+ = escRng . head $ cs+ | otherwise = "[" ++ concat cs' ++ "]"+ where+ rng1 (x,y) = x == y+ cs = p -- charRngs . chars $ p+ cs' = map escRng p+ escRng (x, y)+ | x == y = esc x+ | succ x == y+ = esc x ++ esc y+ | otherwise+ = esc x ++ "-" ++ esc y+ esc x+ | x `elem` "\\-[]{}()*+?.^"+ = '\\':x:""+ | x >= ' ' && x <= '~'+ = x:""+ | otherwise+ = "&#" ++ show (fromEnum x) ++ ";"+ show Dot = "\\a"+ show (Star Dot) = "\\A"+ show (Star e) = "(" ++ show e ++ "*)"+ show (Alt e1 e2) = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"+ show (Else e1 e2) = "(" ++ show e1 ++ "{|}" ++ show e2 ++ ")"+ show (Seq e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"+ show (Rep 1 e) = "(" ++ show e ++ "+)"+ show (Rep i e) = "(" ++ show e ++ "{" ++ show i ++ ",})"+ show (Rng 0 1 e) = "(" ++ show e ++ "?)"+ show (Rng i j e) = "(" ++ show e ++ "{" ++ show i ++ "," ++ show j ++ "})"+ show (Diff e1 e2) = "(" ++ show e1 ++ "{\\}" ++ show e2 ++ ")"+ show (Isec e1 e2) = "(" ++ show e1 ++ "{&}" ++ show e2 ++ ")"+ show (Exor e1 e2) = "(" ++ show e1 ++ "{^}" ++ show e2 ++ ")"+ show (Intl e1 e2) = "(" ++ show e1 ++ "{:}" ++ show e2 ++ ")"+ show (Br l e) = "({" ++ showL l ++ "}" ++ show e ++ ")"+ show (Obr l s n e) = "({" ++ showL l ++ "=" ++ toString (takeS n s) ++ "}" ++ show e ++ ")"+ show (Cbr ss e) = "([" ++ intercalate "," (map (\ (l, s) -> showL l ++ "=" ++ toString s) ss) ++ "]"+ ++ show e +++ ")"++showL :: Show s => Label s -> String+showL = rmq . maybe "" show+ where+ rmq ('\"':xs) = init xs+ rmq xs = xs++-- ------------------------------------------------------------++isZero :: GenRegex s -> Bool+isZero (Zero _) = True+isZero _ = False+{-# INLINE isZero #-}++errRegex :: (StringLike s) =>+ GenRegex s -> s+errRegex (Zero e) = e+errRegex _ = emptyS++-- ------------------------------------------------------------++nullable :: (StringLike s) =>+ GenRegex s -> Bool+nullable = fst . nullable'+{-# INLINE nullable #-}++nullable' :: (StringLike s) =>+ GenRegex s -> Nullable s++nullable' (Zero _) = (False, [])+nullable' Unit = (True, [])+nullable' Dot = (False, [])+nullable' (Sym _x) = (False, [])++nullable' (Star _e) = (True, [])+nullable' (Rep _i e) = nullable' e+nullable' (Rng i _ e) = (i == 0, []) `unionN` nullable' e+nullable' (Seq e1 e2) = nullable' e1 `isectN` nullable' e2++nullable' (Alt e1 e2) = nullable' e1 `unionN` nullable' e2+nullable' (Else e1 e2) = nullable' e1 `orElseN` nullable' e2+nullable' (Isec e1 e2) = nullable' e1 `isectN` nullable' e2+nullable' (Diff e1 e2) = nullable' e1 `diffN` nullable' e2+nullable' (Exor e1 e2) = nullable' e1 `exorN` nullable' e2+nullable' (Intl e1 e2) = nullable' e1 `isectN` nullable' e2++nullable' (Br l e) = (True, [(l, emptyS )]) `isectN` nullable' e+nullable' (Obr l s n e) = (True, [(l, takeS n s)]) `isectN` nullable' e+nullable' (Cbr ss e) = (True, ss) `isectN` nullable' e++isectN :: Nullable s -> Nullable s -> Nullable s+isectN (True, ws1) (True, ws2) = (True, ws1 ++ ws2)+isectN _ _ = (False, [])++unionN :: Nullable s -> Nullable s -> Nullable s+unionN (False, _) (False, _) = (False, [])+unionN (_, ws1) (_, ws2) = (True, ws1 ++ ws2)++orElseN :: Nullable s -> Nullable s -> Nullable s+orElseN e1@(True, _ws1) _ = e1+orElseN _ e2 = e2++diffN :: Nullable s -> Nullable s -> Nullable s+diffN n1 (False, _) = n1+diffN _ _ = (False, [])++exorN :: Nullable s -> Nullable s -> Nullable s+exorN n1@(True, _) (False, _) = n1+exorN (False, _) n2@(True, _) = n2+exorN _ _ = (False, [])++-- ------------------------------------------------------------++-- | 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 :: (StringLike s) =>+ GenRegex s -> 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 (Intl e1 e2) = firstChars e1 `unionCS` firstChars e2+firstChars (Br _l e) = firstChars e+firstChars (Obr _l _s _n e) = firstChars e+firstChars (Cbr _ss e) = firstChars e++-- ------------------------------------------------------------++delta1 :: (StringLike s) => Char -> s -> GenRegex s -> GenRegex s+delta1 c inp e0+ = d' e0+ where+ d' e@(Zero _) = e+ d' Unit = mkZero' $+ "unexpected char " ++ show c+ d' (Sym p)+ | c `elemCS` p = mkUnit+ | otherwise = mkZero' $+ "unexpected char " ++ show c+ d' Dot = mkUnit+ d' e@(Star Dot) = e+ d' e@(Star e1) = mkSeq (d' e1) e+ d' (Alt e1 e2) = mkAlt (d' e1) (d' e2)+ d' (Else e1 e2) = mkElse (d' e1) (d' e2)+ d' (Seq e1@(Obr l s n e1') e2)+ | nu = mkAlt (mkSeq (d' e1) e2)+ (mkCbr ((l, takeS n s) : ws) (d' e2))+ where+ (nu, ws) = nullable' e1'+ d' (Seq e1 e2)+ | nullable e1 = mkAlt (mkSeq (d' e1) e2)+ (d' e2)+ | otherwise = mkSeq (d' e1) e2+ d' (Rep i e) = mkSeq (d' e) (mkRep (i-1) e)+ d' (Rng i j e) = mkSeq (d' e) (mkRng ((i-1) `max` 0) (j-1) e)+ d' (Diff e1 e2) = mkDiff (d' e1) (d' e2)+ d' (Isec e1 e2) = mkIsect (d' e1) (d' e2)+ d' (Exor e1 e2) = mkExor (d' e1) (d' e2)+ d' (Intl e1 e2) = mkAlt (mkInterleave (d' e1) e2 )+ (mkInterleave e1 (d' e2))+ + d' (Br l e) = d' (mkObr l inp 0 e) -- a subex parse starts+ d' (Obr l s n e) = mkObr l s (n + 1) (d' e) -- a subex parse cont.+ d' (Cbr ss e) = mkCbr ss (d' e) -- the results of a subex parse++-- ------------------------------------------------------------++delta :: (StringLike s) => s -> GenRegex s -> GenRegex s+delta inp@(uncons -> Just (c, inp')) e0+ = d' e0+ where+ d' e@(Zero _) = e -- don't process whole input, parse has failed+ d' e@(Star Dot) = e -- don't process input, derivative does not change+ d' e = delta inp' ( -- trc "delta1=" $+ delta1 c inp e)++delta _empty e+ = e+++matchWithRegex :: (StringLike s) =>+ GenRegex s -> s -> Bool+matchWithRegex e s+ = nullable $ delta s e++matchWithRegex' :: (StringLike s) =>+ GenRegex s -> s -> Maybe (SubexResults s)+matchWithRegex' e s+ = (\ (r, l) -> if r then Just l else Nothing) . nullable' $ delta s e++-- ------------------------------------------------------------++-- | This function wraps the whole regex in a subexpression before starting+-- the parse. This is done for getting access to+-- the whole parsed string. Therfore we need one special label, this label+-- is the Nothing value, all explicit labels are Just labels.++splitWithRegex :: (StringLike s) =>+ GenRegex s -> s -> Maybe (SubexResults s, s)+splitWithRegex re inp+ = do+ (re', rest) <- splitWithRegex' (mkBrN re) inp+ return ( snd . nullable' $ re', rest)++splitWithRegexCS :: (StringLike s) =>+ GenRegex s -> CharSet -> s -> Maybe (SubexResults s, s)+splitWithRegexCS re cs inp+ = do+ (re', rest) <- splitWithRegexCS' (mkBrN re) cs inp+ return ( snd . nullable' $ re', rest)++-- ----------------------------------------+--+-- | The main scanner function++{- linear recursive function, can lead to stack overflow++splitWithRegex' :: Eq l => GenRegex s -> String -> Maybe (GenRegex s, String)+splitWithRegex' re ""+ | nullable re = Just (re, "")+ | otherwise = Nothing++splitWithRegex' re inp@(c : inp')+ | isZero re = Nothing+ | otherwise = evalRes . splitWithRegex' (delta1 re c) $ inp'+ where+ evalRes Nothing+ | nullable re = Just (re, inp)+ | otherwise = Nothing+ evalRes res = res+-}++-- tail recursive version of above function++splitWithRegex' :: (StringLike s) =>+ GenRegex s -> s -> Maybe (GenRegex s, s)+splitWithRegex' re inp+ = splitWithRegex''+ ( if nullable re+ then Just (re, inp) -- first possible result: empty prefix+ else Nothing -- empty prefix not a result+ ) re inp++splitWithRegex'' :: (StringLike s) =>+ Maybe (GenRegex s, s) -> GenRegex s -> s -> Maybe (GenRegex s, s)++splitWithRegex'' lastRes re inp@(uncons -> Just (c, inp'))+ | isZero re = lastRes+ | otherwise = splitWithRegex'' nextRes re' $ inp'+ where+ re' = delta1 c inp re+ nextRes+ | nullable re' = Just (re', inp')+ | otherwise = lastRes++splitWithRegex'' lastRes _re _empty+ = lastRes++-- ----------------------------------------+--+-- | 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' :: (StringLike s) =>+ GenRegex s -> CharSet -> s -> Maybe (GenRegex s, s)+splitWithRegexCS' re cs inp@(uncons -> Just (c, _inp'))+ | c `elemCS` cs = splitWithRegex' re inp++splitWithRegexCS' re _cs inp+ | nullable re = Just (re, inp)+ | otherwise = Nothing++-- ------------------------------------------------------------+
+ src/Text/Regex/XMLSchema/Generic/RegexParser.hs view
@@ -0,0 +1,530 @@+-- ------------------------------------------------------------++{- |+ Module : Text.Regex.XMLSchema.RegexParser+ Copyright : Copyright (C) 2014- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : stable+ Portability: portable++ W3C XML Schema Regular Expression Parser++ This parser supports the full W3C standard, the+ complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>+ and extensions for all missing set operations, intersection,+ difference, exclusive or, interleave, complement++-}++-- ------------------------------------------------------------++module Text.Regex.XMLSchema.Generic.RegexParser+ ( parseRegex+ , parseRegexExt+ , parseRegex'+ , parseRegexExt'+ , parseContextRegex+ )+where++import Data.Char.Properties.UnicodeBlocks+import Data.Char.Properties.UnicodeCharProps+import Data.Char.Properties.XMLCharProps++import Data.List (isPrefixOf,+ isSuffixOf)+import Data.Maybe+import Data.Set.CharSet++import Text.ParserCombinators.Parsec+import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.StringLike++-- ------------------------------------------------------------++-- | parse a standard W3C XML Schema regular expression++parseRegex :: StringLike s => s -> GenRegex s+parseRegex = parseRegex' . toString++parseRegex' :: StringLike s => String -> GenRegex s+parseRegex' = parseRegex'' regExpStd++-- | parse an extended syntax W3C XML Schema regular expression+--+-- The Syntax of the W3C XML Schema spec is extended by+-- further useful set operations, like intersection, difference, exor.+-- Subexpression match becomes possible with \"named\" pairs of parentheses.+-- The multi char escape sequence \\a represents any Unicode char,+-- The multi char escape sequence \\A represents any Unicode word, (\\A = \\a*).+-- All syntactically wrong inputs are mapped to the Zero expression representing the+-- empty set of words. Zero contains as data field a string for an error message.+-- So error checking after parsing becomes possible by checking against Zero ('isZero' predicate)++parseRegexExt :: StringLike s => s -> GenRegex s+parseRegexExt = parseRegexExt' . toString++parseRegexExt' :: StringLike s => String -> GenRegex s+parseRegexExt' = parseRegex'' regExpExt++parseRegex'' :: StringLike s => Parser (GenRegex s) -> String -> GenRegex s+parseRegex'' regExp'+ = either (mkZero' . ("syntax error: " ++) . show) id+ . parse ( do+ r <- regExp'+ eof+ return r+ ) ""++-- ------------------------------------------------------------++-- | parse a regular expression surrounded by contenxt spec+--+-- a leading @^@ denotes start of text,+-- a trailing @$@ denotes end of text,+-- a leading @\\<@ denotes word start,+-- a trailing @\\>@ denotes word end.+--+-- The 1. param ist the regex parser ('parseRegex' or 'parseRegexExt')++parseContextRegex :: StringLike s => (String -> GenRegex s) -> s -> GenRegex s+parseContextRegex parseRe re0+ = re'+ where+ parseAW = parseRegexExt' "(\\A\\W)?"+ parseWA = parseRegexExt' "(\\W\\A)?"++ re = toString re0+ re' = mkSeqs . concat $ [ startContext+ , (:[]) . parseRe $ re2+ , endContext+ ]+ (startContext, re1)+ | "^" `isPrefixOf` re = ([], tail re)+ | "\\<" `isPrefixOf` re = ([parseAW], drop 2 re)+ | otherwise = ([mkStar mkDot], re)+ (endContext, re2)+ | "$" `isSuffixOf` re1 = ([], init re1)+ | "\\>" `isSuffixOf` re1 = ([parseWA], init . init $ re1)+ | otherwise = ([mkStar mkDot], re1)++-- ------------------------------------------------------------++regExpExt :: StringLike s => Parser (GenRegex s)+regExpExt = branchList orElseList++regExpStd :: StringLike s => Parser (GenRegex s)+regExpStd = branchList seqListStd++branchList :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)+branchList exParser+ = do+ r1 <- exParser+ rs <- many branchList1+ return (foldr1 mkAlt $ r1:rs) -- union is associative, so we use right ass.+ -- as with seq, alt and exor+ where+ branchList1+ = do+ _ <- char '|'+ exParser++orElseList :: StringLike s => Parser (GenRegex s)+orElseList+ = do+ r1 <- interleaveList+ rs <- many orElseList1+ return (foldr1 mkElse $ r1:rs) -- orElse is associative, so we choose right ass.+ -- as with seq and alt ops+ where+ orElseList1+ = do+ _ <- try (string "{|}")+ interleaveList++interleaveList :: StringLike s => Parser (GenRegex s)+interleaveList+ = do+ r1 <- exorList+ rs <- many interleaveList1+ return (foldr1 mkInterleave $ r1:rs) -- interleave is associative, so we choose right ass.+ -- as with seq and alt ops+ where+ interleaveList1+ = do+ _ <- try (string "{:}")+ exorList++exorList :: StringLike s => Parser (GenRegex s)+exorList+ = do+ r1 <- diffList+ rs <- many exorList1+ return (foldr1 mkExor $ r1:rs) -- exor is associative, so we choose right ass.+ where+ exorList1+ = do+ _ <- try (string "{^}")+ diffList++diffList :: StringLike s => Parser (GenRegex s)+diffList+ = do+ r1 <- intersectList+ rs <- many diffList1+ return (foldl1 mkDiff $ r1:rs) -- diff is not associative, so we choose left ass.+ where+ diffList1+ = do+ _ <- try (string "{\\}")+ intersectList++intersectList :: StringLike s => Parser (GenRegex s)+intersectList+ = do+ r1 <- seqListExt+ rs <- many intersectList1+ return (foldr1 mkIsect $ r1:rs)+ where+ intersectList1+ = do+ _ <- try (string "{&}")+ seqListExt++seqListExt :: StringLike s => Parser (GenRegex s)+seqListExt = seqList' regExpLabel multiCharEscExt++seqListStd :: StringLike s => Parser (GenRegex s)+seqListStd = seqList' regExpStd multiCharEsc++seqList' :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)+seqList' regExp' multiCharEsc'+ = do+ rs <- many piece+ return $ mkSeqs rs+ where+ -- piece :: StringLike s => Parser (GenRegex s)+ piece+ = do+ r <- atom+ quantifier r++ -- atom :: StringLike s => Parser (GenRegex s)+ atom+ = char1+ <|>+ charClass+ <|>+ between (char '(') (char ')') regExp'++ -- charClass :: StringLike s => Parser (GenRegex s)+ charClass+ = charClassEsc multiCharEsc'+ <|>+ charClassExpr multiCharEsc'+ <|>+ wildCardEsc++++quantifier :: StringLike s => GenRegex s -> Parser (GenRegex s)+quantifier r+ = ( do+ _ <- char '?'+ return $ mkOpt r )+ <|>+ ( do+ _ <- char '*'+ return $ mkStar r )+ <|>+ ( do+ _ <- char '+'+ return $ mkRep 1 r )+ <|>+ try ( do+ _ <- char '{'+ res <- quantity r+ _ <- char '}'+ return res+ )+ <|>+ ( return r )++quantity :: StringLike s => GenRegex s -> Parser (GenRegex s)+quantity r+ = do+ lb <- many1 digit+ quantityRest r (read lb)++quantityRest :: StringLike s => GenRegex s -> Int -> Parser (GenRegex s)+quantityRest r lb+ = ( do+ _ <- char ','+ ub <- many digit+ return ( if null ub+ then mkRep lb r+ else mkRng lb (read ub) r+ )+ )+ <|>+ ( return $ mkRng lb lb r)++regExpLabel :: StringLike s => Parser (GenRegex s)+regExpLabel+ = do+ lab <- option id (between (char '{') (char '}') label')+ r <- regExpExt+ return $ lab r+ where+ label'+ = do+ l <- many1 (satisfy isXmlNameChar)+ return $ mkBr' l++char1 :: StringLike s => Parser (GenRegex s)+char1+ = do+ c <- satisfy (`notElem` ".\\?*+{}()|[]")+ return $ mkSym1 c++charClassEsc :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)+charClassEsc multiCharEsc'+ = do+ _ <- char '\\'+ ( singleCharEsc+ <|>+ multiCharEsc'+ <|>+ catEsc+ <|>+ complEsc )++singleCharEsc :: StringLike s => Parser (GenRegex s)+singleCharEsc+ = do+ c <- singleCharEsc'+ return $ mkSym1 c++singleCharEsc' :: Parser Char+singleCharEsc'+ = do+ c <- satisfy (`elem` "nrt\\|.?*+(){}-[]^")+ return $ maybe c id . lookup c . zip "ntr" $ "\n\r\t"++multiCharEscExt :: StringLike s => Parser (GenRegex s)+multiCharEscExt+ = multiCharEsc+ <|>+ ( do -- extension: \a represents the whole alphabet inclusive newline chars: \a == .|\n|\r+ _ <- char 'a'+ return mkDot )+ <|>+ ( do -- extension: \A represents all words: \A == \a* or \A == (.|\n|\r)*+ _ <- char 'A'+ return mkAll )++multiCharEsc :: StringLike s => Parser (GenRegex s)+multiCharEsc+ = ( do+ c <- satisfy (`elem` es)+ return $ mkSym . fromJust . lookup c $ pm )+ where+ es = map fst pm+ pm = [ ('s', charPropXmlSpaceChar )+ , ('S', compCS charPropXmlSpaceChar )+ , ('i', charPropXmlNameStartChar )+ , ('I', compCS charPropXmlNameStartChar )+ , ('c', charPropXmlNameChar )+ , ('C', compCS charPropXmlNameChar )+ , ('d', charPropDigit )+ , ('D', compCS charPropDigit )+ , ('w', compCS charPropNotWord )+ , ('W', charPropNotWord )+ ]+ charPropDigit = rangeCS '0' '9'+ charPropNotWord = charPropUnicodeP+ `unionCS`+ charPropUnicodeZ+ `unionCS`+ charPropUnicodeC++catEsc :: StringLike s => Parser (GenRegex s)+catEsc+ = do+ _ <- char 'p'+ s <- between (char '{') (char '}') charProp+ return $ mkSym s++charProp :: Parser CharSet+charProp+ = isCategory+ <|>+ isBlock++isBlock :: Parser CharSet+isBlock+ = do+ _ <- string "Is"+ name <- many1 (satisfy legalChar)+ case lookup name codeBlocks of+ Just b -> return $ uncurry rangeCS b+ Nothing -> fail $ "unknown Unicode code block " ++ show name+ where+ legalChar c = 'A' <= c && c <= 'Z' ||+ 'a' <= c && c <= 'z' ||+ '0' <= c && c <= '9' ||+ '-' == c++isCategory :: Parser CharSet+isCategory+ = do+ pr <- isCategory'+ return $ fromJust (lookup pr categories)++categories :: [(String, CharSet)]+categories+ = [ ("C", charPropUnicodeC )+ , ("Cc", charPropUnicodeCc)+ , ("Cf", charPropUnicodeCf)+ , ("Co", charPropUnicodeCo)+ , ("Cs", charPropUnicodeCs)+ , ("L", charPropUnicodeL )+ , ("Ll", charPropUnicodeLl)+ , ("Lm", charPropUnicodeLm)+ , ("Lo", charPropUnicodeLo)+ , ("Lt", charPropUnicodeLt)+ , ("Lu", charPropUnicodeLu)+ , ("M", charPropUnicodeM )+ , ("Mc", charPropUnicodeMc)+ , ("Me", charPropUnicodeMe)+ , ("Mn", charPropUnicodeMn)+ , ("N", charPropUnicodeN )+ , ("Nd", charPropUnicodeNd)+ , ("Nl", charPropUnicodeNl)+ , ("No", charPropUnicodeNo)+ , ("P", charPropUnicodeP )+ , ("Pc", charPropUnicodePc)+ , ("Pd", charPropUnicodePd)+ , ("Pe", charPropUnicodePe)+ , ("Pf", charPropUnicodePf)+ , ("Pi", charPropUnicodePi)+ , ("Po", charPropUnicodePo)+ , ("Ps", charPropUnicodePs)+ , ("S", charPropUnicodeS )+ , ("Sc", charPropUnicodeSc)+ , ("Sk", charPropUnicodeSk)+ , ("Sm", charPropUnicodeSm)+ , ("So", charPropUnicodeSo)+ , ("Z", charPropUnicodeZ )+ , ("Zl", charPropUnicodeZl)+ , ("Zp", charPropUnicodeZp)+ , ("Zs", charPropUnicodeZs)+ ]++isCategory' :: Parser String+isCategory'+ = ( foldr1 (<|>) . map (uncurry prop) $+ [ ('L', "ultmo")+ , ('M', "nce")+ , ('N', "dlo")+ , ('P', "cdseifo")+ , ('Z', "slp")+ , ('S', "mcko")+ , ('C', "cfon")+ ]+ ) <?> "illegal Unicode character property"+ where+ prop c1 cs2+ = do+ _ <- char c1+ s2 <- option ""+ ( do+ c2 <- satisfy (`elem` cs2)+ return [c2] )+ return $ c1:s2++complEsc :: StringLike s => Parser (GenRegex s)+complEsc+ = do+ _ <- char 'P'+ s <- between (char '{') (char '}') charProp+ return $ mkSym $ compCS s++charClassExpr :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)+charClassExpr multiCharEsc'+ = between (char '[') (char ']') charGroup+ where++ -- charGroup :: StringLike s => Parser (GenRegex s)+ charGroup+ = do+ r <- ( negCharGroup -- a ^ at beginning denotes negation, not start of posCharGroup+ <|>+ posCharGroup+ )+ s <- option (mkZero' "") -- charClassSub+ ( do+ _ <- char '-'+ charClassExpr multiCharEsc'+ )+ return $ mkDiff r s++ -- posCharGroup :: StringLike s => Parser (GenRegex s)+ posCharGroup+ = do+ rs <- many1 (charRange <|> charClassEsc multiCharEsc')+ return $ foldr1 mkAlt rs++ -- negCharGroup :: StringLike s => Parser (GenRegex s)+ negCharGroup+ = do+ _ <- char '^'+ r <- posCharGroup+ return $ mkDiff mkDot r++charRange :: StringLike s => Parser (GenRegex s)+charRange+ = try seRange+ <|>+ xmlCharIncDash++seRange :: StringLike s => Parser (GenRegex s)+seRange+ = do+ c1 <- charOrEsc'+ _ <- char '-'+ c2 <- charOrEsc'+ return $ mkSymRng c1 c2++charOrEsc' :: Parser Char+charOrEsc'+ = ( do+ _ <- char '\\'+ singleCharEsc'+ )+ <|>+ satisfy (`notElem` "\\-[]")++xmlCharIncDash :: StringLike s => Parser (GenRegex s)+xmlCharIncDash+ = try ( do -- dash is only allowed if not followed by a [, else charGroup differences do not parse correctly+ _ <- char '-'+ notFollowedBy (char '[')+ return $ mkSym1 '-'+ )+ <|>+ ( do+ c <- satisfy (`notElem` "-\\[]")+ return $ mkSym1 c+ )++wildCardEsc :: StringLike s => Parser (GenRegex s)+wildCardEsc+ = do+ _ <- char '.'+ return . mkSym . compCS $ stringCS "\n\r"+++-- ------------------------------------------------------------
+ src/Text/Regex/XMLSchema/Generic/StringLike.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- ------------------------------------------------------------++{- |+ Copyright : Copyright (C) 2014- Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt <uwe@fh-wedel.de>+ Stability : stable+-}++-- ------------------------------------------------------------++module Text.Regex.XMLSchema.Generic.StringLike+where++import Data.Maybe+import Data.String (IsString(..))++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL++-- ------------------------------------------------------------++-- | /WARNING/: This StringLike class is /not/ intended for use outside this regex library.+-- It provides an abstraction for String's as used inside this library.+-- It allows the library to work with String (list of Char),+-- ByteString.Char8, ByteString.Lazy.Char8,+-- Data.Text and Data.Text.Lazy.+--+-- The class is similar to the StringLike class in the tagsoup package++class (Eq a, IsString a, Show a) => StringLike a where+ emptyS :: a+ uncons :: a -> Maybe (Char, a)+ nullS :: a -> Bool+ headS :: a -> Char+ takeS :: Int -> a -> a+ dropS :: Int -> a -> a+ appendS :: a -> a -> a+ concatS :: [a] -> a+ toString :: a -> String++ nullS = isNothing . uncons+ headS (uncons -> Just (c, _))+ = c+ headS _ = error "headS: empty StringLike"+ concatS = foldl appendS emptyS+ + {-# INLINE nullS #-}+ {-# INLINE headS #-}+ {-# INLINE concatS #-}+ +-- ------------------------------------------------------------++instance StringLike String where+ emptyS = []+ uncons (x : xs) = Just (x, xs)+ uncons "" = Nothing+ nullS = null+ headS = head+ takeS = take+ dropS = drop+ appendS = (++)+ concatS = concat+ toString = id++ {-# INLINE emptyS #-}+ {-# INLINE uncons #-}+ {-# INLINE nullS #-}+ {-# INLINE takeS #-}+ {-# INLINE dropS #-}+ {-# INLINE appendS #-}+ {-# INLINE concatS #-}+ {-# INLINE toString #-}++-- ------------------------------------------------------------++instance StringLike T.Text where+ emptyS = T.empty+ uncons = T.uncons+ nullS = T.null+ headS = T.head+ takeS = T.take+ dropS = T.drop+ appendS = T.append+ concatS = T.concat+ toString = T.unpack++ {-# INLINE emptyS #-}+ {-# INLINE uncons #-}+ {-# INLINE nullS #-}+ {-# INLINE takeS #-}+ {-# INLINE dropS #-}+ {-# INLINE appendS #-}+ {-# INLINE concatS #-}+ {-# INLINE toString #-}++-- ------------------------------------------------------------++instance StringLike TL.Text where+ emptyS = TL.empty+ uncons = TL.uncons+ nullS = TL.null+ headS = TL.head+ takeS = TL.take . toEnum+ dropS = TL.drop . toEnum+ appendS = TL.append+ concatS = TL.concat+ toString = TL.unpack++ {-# INLINE emptyS #-}+ {-# INLINE uncons #-}+ {-# INLINE nullS #-}+ {-# INLINE takeS #-}+ {-# INLINE dropS #-}+ {-# INLINE appendS #-}+ {-# INLINE concatS #-}+ {-# INLINE toString #-}++-- ------------------------------------------------------------++instance StringLike B.ByteString where+ emptyS = B.empty+ uncons = B.uncons+ nullS = B.null+ headS = B.head+ takeS = B.take+ dropS = B.drop+ appendS = B.append+ concatS = B.concat+ toString = B.unpack++ {-# INLINE emptyS #-}+ {-# INLINE uncons #-}+ {-# INLINE nullS #-}+ {-# INLINE takeS #-}+ {-# INLINE dropS #-}+ {-# INLINE appendS #-}+ {-# INLINE concatS #-}+ {-# INLINE toString #-}++-- ------------------------------------------------------------++instance StringLike BL.ByteString where+ emptyS = BL.empty+ uncons = BL.uncons+ nullS = BL.null+ headS = BL.head+ takeS = BL.take . toEnum+ dropS = BL.drop . toEnum+ appendS = BL.append+ concatS = BL.concat+ toString = BL.unpack++ {-# INLINE emptyS #-}+ {-# INLINE uncons #-}+ {-# INLINE nullS #-}+ {-# INLINE takeS #-}+ {-# INLINE dropS #-}+ {-# INLINE appendS #-}+ {-# INLINE concatS #-}+ {-# INLINE toString #-}++-- ------------------------------------------------------------++
src/Text/Regex/XMLSchema/String.hs view
@@ -1,7 +1,6 @@ -- ------------------------------------------------------------ {- |- Module : Text.Regex.XMLSchema.String Copyright : Copyright (C) 2010- Uwe Schmidt License : MIT @@ -9,18 +8,18 @@ Stability : stable Portability: portable - Convenient functions for W3C XML Schema Regular Expression Matcher.- For internals see 'Text.Regex.XMLSchema.String.Regex'+ Convenient functions for W3C XML Schema Regular Expression Matcher for Strings.+ A specialisation of Text.Regex.XMLSchema.Generic as+ compatibility module to old non generic version Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>- -} -- ------------------------------------------------------------ module Text.Regex.XMLSchema.String- ( GenRegex- , Regex+ {-# DEPRECATED "use the more general 'Text.Regex.XMLSchema.Generic' instead" #-}+ ( Regex , grep , grepExt@@ -53,6 +52,7 @@ , tokenizeRE' , tokenizeSubexRE + -- Text.Regex.XMLSchema.Generic.Regex , mkZero , mkUnit , mkSym1@@ -76,18 +76,17 @@ , isZero , errRegex - , parseRegex -- re-export of Text.Regex.XMLSchema.String.RegexParser+ -- Text.Regex.XMLSchema.Generic.RegexParser+ , parseRegex , parseRegexExt , parseContextRegex ) where -import Control.Arrow--import Data.Maybe--import Text.Regex.XMLSchema.String.Regex-import Text.Regex.XMLSchema.String.RegexParser+import Text.Regex.XMLSchema.Generic (Regex)+import qualified Text.Regex.XMLSchema.Generic as G+import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.RegexParser -- ------------------------------------------------------------ @@ -96,11 +95,8 @@ -- @Nothing@ is returned in case there is no matching prefix, -- else the pair of prefix and rest is returned -splitRE :: (Eq l, Show l) => GenRegex l -> String -> Maybe (String, String)-splitRE re input- = do- (sms, rest) <- splitWithRegex re input- return (snd . head $ sms, rest)+splitRE :: Regex -> String -> Maybe (String, String)+splitRE = G.splitRE -- | convenient function for 'splitRE' --@@ -112,17 +108,12 @@ -- > split "[" "abc" = ("", "abc") -- "[" syntax error, no split split :: String -> String -> (String, String)-split = split' parseRegex+split = G.split -- | split with extended syntax splitExt :: String -> String -> (String, String)-splitExt = split' parseRegexExt--split' :: (String -> Regex) -> String -> String -> (String, String)-split' parseRegex' re input- = fromMaybe ("", input)- . (splitRE . parseRegex' $ re) $ input+splitExt = G.splitExt -- ------------------------------------------------------------ @@ -133,11 +124,8 @@ -- else the list of pairs of labels and submatches and the -- rest is returned -splitSubexRE :: (Eq l, Show l) => GenRegex l -> String -> Maybe ([(l, String)], String)-splitSubexRE re input- = do- (sms, rest) <- splitWithRegex re input- return (map (first fromJust) . drop 1 $ sms, rest)+splitSubexRE :: Regex -> String -> Maybe ([(String, String)], String)+splitSubexRE = G.splitSubexRE -- | convenient function for 'splitSubex', uses extended syntax --@@ -163,34 +151,14 @@ splitSubex :: String -> String -> ([(String,String)], String)-splitSubex re inp- = fromMaybe ([], inp) . (splitSubexRE . parseRegexExt $ re) $ inp+splitSubex = G.splitSubex -- ------------------------------------------------------------ -- | The function, that does the real work for 'tokenize' -tokenizeRE :: (Eq l, Show l) => GenRegex l -> String -> [String]-tokenizeRE re- = token''- where- re1 = mkDiff re mkUnit- token'' = token' re fcs- token1'' = token' re1 fcs- fcs = firstChars re-- -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> [String]- token' re' fcs' inp- | null inp = []- | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp- where- evalRes Nothing = token'' (tail inp) -- re does not match any prefix- evalRes (Just (toks, rest))- | null tok = tok : token'' (tail rest) -- re is nullable and only the empty prefix matches- -- discard one char and try again- | otherwise = tok : token1'' rest -- real token found, next token must not be empty- where- tok = snd . head $ toks+tokenizeRE :: Regex -> String -> [String]+tokenizeRE = G.tokenizeRE -- | split a string into tokens (words) by giving a regular expression -- which all tokens must match.@@ -231,12 +199,12 @@ -- > tokenize "[^ \t\n\r]*" = words tokenize :: String -> String -> [String]-tokenize = tokenizeRE . parseRegex+tokenize = G.tokenize -- | tokenize with extended syntax tokenizeExt :: String -> String -> [String]-tokenizeExt = tokenizeRE . parseRegexExt+tokenizeExt = G.tokenizeExt -- ------------------------------------------------------------ @@ -252,44 +220,19 @@ -- -- > concat . map (either id id) . tokenizeRE' re == id -tokenizeRE' :: (Eq l, Show l) => GenRegex l -> String -> [Either String String]-tokenizeRE' re- = token'' ""- where- re1 = mkDiff re mkUnit- token'' = token' re fcs- token1'' = token' re1 fcs- fcs = firstChars re-- -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> String -> [Either String String]- token' re' fcs' unmatched inp- | null inp = addUnmatched []- | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp- where- addUnmatched- | null unmatched = id- | otherwise = ((Left . reverse $ unmatched) :)-- addMatched t = addUnmatched . ((Right t) :)-- evalRes Nothing = token'' ((head inp) : unmatched) (tail inp) -- re does not match any prefix-- evalRes (Just (toks, rest))- | null tok = addMatched tok $ token'' (take 1 rest) (tail rest) -- re is nullable and only the empty prefix matches- -- discard one char and try again- | otherwise = addMatched tok $ token1'' "" rest -- real token found, next token must not be empty- where- tok = snd . head $ toks+tokenizeRE' :: Regex -> String -> [Either String String]+tokenizeRE' = G.tokenizeRE' -- | convenient function for 'tokenizeRE'' ----- When the regular expression parses as Zero, @[Left input]@ is returned, that means no tokens are found+-- When the regular expression parses as Zero,+-- @[Left input]@ is returned, that means no tokens are found tokenize' :: String -> String -> [Either String String]-tokenize' = tokenizeRE' . parseRegex+tokenize' = G.tokenize' tokenizeExt' :: String -> String -> [Either String String]-tokenizeExt' = tokenizeRE' . parseRegexExt+tokenizeExt' = G.tokenizeExt' -- ------------------------------------------------------------ @@ -307,27 +250,8 @@ -- All none matching chars are discarded. If the given regex contains syntax errors, -- @Nothing@ is returned -tokenizeSubexRE :: (Eq l, Show l) => GenRegex l -> String -> [(l, String)]-tokenizeSubexRE re- = token''- where- re1 = mkDiff re mkUnit- token'' = token' re fcs- token1'' = token' re1 fcs- fcs = firstChars re-- -- token' :: (Eq l, Show l) => GenRegex l -> CharSet -> String -> [(l,String)]- token' re' fcs' inp- | null inp = []- | otherwise = evalRes . splitWithRegexCS re' fcs' $ inp- where- evalRes Nothing = token'' (tail inp) -- re does not match any prefix- evalRes (Just (toks, rest))- | null tok = res ++ token'' (tail rest) -- re is nullable and only the empty prefix matches- | otherwise = res ++ token1'' rest -- token found, tokenize the rest- where- res = map (first fromJust) . tail $ toks- tok = snd . head $ toks+tokenizeSubexRE :: Regex -> String -> [(String, String)]+tokenizeSubexRE = G.tokenizeSubexRE -- | convenient function for 'tokenizeSubexRE' a string --@@ -354,7 +278,7 @@ -- > ,("real","34.56"),("n","34"),("f","56")] tokenizeSubex :: String -> String -> [(String,String)]-tokenizeSubex = tokenizeSubexRE . parseRegexExt+tokenizeSubex = G.tokenizeSubex -- ------------------------------------------------------------ @@ -363,8 +287,8 @@ -- All matching tokens are edited by the 1. argument, the editing function, -- all other chars remain as they are -sedRE :: (Eq l, Show l) => (String -> String) -> GenRegex l -> String -> String-sedRE edit re = concatMap (either id edit) . tokenizeRE' re+sedRE :: (String -> String) -> Regex -> String -> String+sedRE = G.sedRE -- | convenient function for 'sedRE' --@@ -375,17 +299,17 @@ -- > sed undefined "[" "xxx" = "xxx" sed :: (String -> String) -> String -> String -> String-sed edit = sedRE edit . parseRegex+sed = G.sed sedExt :: (String -> String) -> String -> String -> String-sedExt edit = sedRE edit . parseRegexExt+sedExt = G.sedExt -- ------------------------------------------------------------ -- | match a string with a regular expression -matchRE :: (Eq l, Show l) => GenRegex l -> String -> Bool-matchRE = matchWithRegex+matchRE :: Regex -> String -> Bool+matchRE = G.matchRE -- | convenient function for 'matchRE' --@@ -396,20 +320,20 @@ -- > match "[" "xxx" = False match :: String -> String -> Bool-match = matchWithRegex . parseRegex+match = G.match -- | match with extended regular expressions matchExt :: String -> String -> Bool-matchExt = matchWithRegex . parseRegexExt+matchExt = G.matchExt -- ------------------------------------------------------------ -- | match a string with a regular expression -- and extract subexpression matches -matchSubexRE :: (Eq l, Show l) => GenRegex l -> String -> [(l, String)]-matchSubexRE re = map (first fromJust) . fromMaybe [] . matchWithRegex' re+matchSubexRE :: Regex -> String -> [(String, String)]+matchSubexRE = G.matchSubexRE -- | convenient function for 'matchRE' --@@ -421,7 +345,7 @@ -- > matchSubex "[" "xxx" = [] matchSubex :: String -> String -> [(String, String)]-matchSubex = matchSubexRE . parseRegexExt+matchSubex = G.matchSubex -- ------------------------------------------------------------ @@ -442,24 +366,21 @@ -- > grep "a\\>" ["x a b", " ax ", " xa ", "xab"] => ["x a b", " xa "] grep :: String -> [String] -> [String]-grep = grep' parseRegex+grep = G.grep -- | grep with extended regular expressions grepExt :: String -> [String] -> [String]-grepExt = grep' parseRegexExt--grep' :: (String -> Regex) -> String -> [String] -> [String]-grep' parseRegex' = grepRE . parseContextRegex parseRegex'+grepExt = G.grepExt -- | grep with already prepared Regex (ususally with 'parseContextRegex') grepRE :: Regex -> [String] -> [String]-grepRE re = filter (matchRE re)+grepRE = G.grepRE -- | grep with Regex and line numbers grepREwithLineNum :: Regex -> [String] -> [(Int,String)]-grepREwithLineNum re = filter (matchRE re . snd) . zip [(1::Int)..]+grepREwithLineNum = G.grepREwithLineNum -- ------------------------------------------------------------
− src/Text/Regex/XMLSchema/String/Regex.hs
@@ -1,665 +0,0 @@--- --------------------------------------------------------------{- |- Module : Text.Regex.XMLSchema.String.Regex- Copyright : Copyright (C) 2010 - Uwe Schmidt- License : MIT-- Maintainer : Uwe Schmidt <uwe@fh-wedel.de>- Stability : stable- Portability: portable-- W3C XML Schema Regular Expression Matcher-- Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>---}---- --------------------------------------------------------------module Text.Regex.XMLSchema.String.Regex- ( Regex- , GenRegex-- , mkZero- , mkUnit- , mkSym- , mkSym1- , mkSymRng- , mkWord- , mkDot- , mkStar- , mkAll- , mkAlt- , mkElse- , mkSeq- , mkSeqs- , mkRep- , mkRng- , mkOpt- , mkDiff- , mkIsect- , mkExor- , mkInterleave- , mkCompl- , mkBr-- , isZero- , errRegex-- , nullable- , nullable'-- , delta1- , delta-- , firstChars-- , matchWithRegex- , matchWithRegex'- , splitWithRegex- , splitWithRegex'- , splitWithRegexCS- , splitWithRegexCS'- )-where--import Data.List -- ( intercalate )--import Data.Set.CharSet---- --------------------------------------------------------------data GenRegex l = Zero String- | Unit- | Sym CharSet- | Dot- | Star (GenRegex l)- | Alt (GenRegex l) (GenRegex l)- | Else (GenRegex l) (GenRegex l)- | Seq (GenRegex l) (GenRegex l)- | Rep Int (GenRegex l) -- 1 or more repetitions- | Rng Int Int (GenRegex l) -- n..m repetitions- | Diff (GenRegex l) (GenRegex l) -- r1 - r2- | Isec (GenRegex l) (GenRegex l) -- r1 n r2- | Exor (GenRegex l) (GenRegex l) -- r1 xor r2- | Intl (GenRegex l) (GenRegex l) -- r1 interleavedWith r2- | Br (Label l) (GenRegex l) String -- currently parsed (...)- | Cbr (GenRegex l) [(Label l, String)] --already completely parsed (...)- deriving (Eq, Ord {-, Show -})--type Regex = GenRegex String-type Label l = Maybe l -- we need one special label for the whole expression- -- see splitWithRegex-type Nullable l = (Bool, [(Label l, String)])---- --------------------------------------------------------------{- just for documentation--class Inv a where- inv :: a -> Bool--instance Inv (GenRegex l) where- inv (Zero _) = True- inv Unit = True- inv (Sym p) = not (nulCS p) && not (fullCS p)- inv Dot = True- inv (Star e) = inv e- inv (Alt e1 e2) = inv e1 &&- inv e2- inv (Seq e1 e2) = inv e1 &&- inv e2- inv (Rep i e) = i > 0 && inv e- inv (Rng i j e) = (i < j || (i == j && i > 1)) &&- inv e- inv (Diff e1 e2) = inv e1 &&- inv e2- inv (Isec e1 e2) = inv e1 &&- inv e2- inv (Exor e1 e2) = inv e1 &&- inv e2--}---- ------------------------------------------------------------------ smart constructors---- | construct the r.e. for the empty set.--- An (error-) message may be attached--mkZero :: String -> GenRegex l-mkZero = Zero-{-# INLINE mkZero #-}---- | construct the r.e. for the set containing the empty word--mkUnit :: GenRegex l-mkUnit = Unit-{-# INLINE mkUnit #-}---- | construct the r.e. for a set of chars--mkSym :: CharSet -> GenRegex l-mkSym s- | nullCS s = mkZero $ "empty char range"- | fullCS s = mkDot- | otherwise = Sym s-{-# INLINE mkSym #-}---- | construct an r.e. for a single char set-mkSym1 :: Char -> GenRegex l-mkSym1 = mkSym . singleCS-{-# INLINE mkSym1 #-}---- | construct an r.e. for an intervall of chars-mkSymRng :: Char -> Char -> GenRegex l-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-{-# INLINE mkDot #-}---- | construct an r.e. for the set of all Unicode words--mkAll :: Eq l => GenRegex l-mkAll = mkStar mkDot-{-# INLINE mkAll #-}----- | construct r.e. for r*-mkStar :: Eq l => GenRegex l -> GenRegex l-mkStar (Zero _) = mkUnit -- {}* == ()-mkStar e@Unit = e -- ()* == ()-mkStar e@(Star _e1) = e -- (r*)* == r*-mkStar (Rep 1 e1) = mkStar e1 -- (r+)* == r*-mkStar (Rep i e1)- | i == 1- ||- nullable e1 = mkStar e1 -- (r{i,})* == r* when i == 1 or nullable r-mkStar e@(Rng _ _ e1)- | nullable e = mkStar e1 -- (r{i,j})* == r* when i == 0 or nullable r-mkStar e@(Alt _ _) = Star (rmStar e) -- (a*|b)* == (a|b)*-{- this is wrong, not generally applicable-mkStar (Br l r s) = mkBr0 l (mkStar r) s -- ({l}r)* == ({l}r*) because we want the longest match as result for the subexpression--}-mkStar e = Star e--rmStar :: Eq l => GenRegex l -> GenRegex l-rmStar (Alt e1 e2) = mkAlt (rmStar e1) (rmStar e2)-rmStar (Star e1) = rmStar e1-rmStar (Rep 1 e1) = rmStar e1-rmStar e1 = e1---- | construct the r.e for r1|r2--mkAlt :: Eq l => GenRegex l -> GenRegex l -> GenRegex l-mkAlt e1 (Zero _) = e1 -- e1 u {} = e1-mkAlt (Zero _) e2 = e2 -- {} u e2 = e2-mkAlt (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates-mkAlt e1 e2@(Sym _) = mkAlt e2 e1 -- symmetry: predicates always first-mkAlt e1@(Sym _) (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates-mkAlt (Sym _) e2@Dot = e2 -- c|. = . for a c's-mkAlt e1@(Star Dot) _e2 = e1 -- A* u e1 = A*-mkAlt _e1 e2@(Star Dot) = e2 -- e1 u A* = A*-mkAlt (Alt e1 e2) e3 = mkAlt e1 (mkAlt e2 e3) -- associativity-mkAlt e1 e2- | e1 == e2 = e1- | otherwise = Alt e1 e2---- | construct the r.e. for r1{|}r2 (r1 orElse r2).------ This represents the same r.e. as r1|r2, but when--- collecting the results of subexpressions in (...) and r1 succeeds, the--- subexpressions of r2 are discarded, so r1 matches are prioritized------ example------ > splitSubex "({1}x)|({2}.)" "x" = ([("1","x"),("2","x")], "")--- >--- > splitSubex "({1}x){|}({2}.)" "x" = ([("1","x")], "")--mkElse :: Eq l => GenRegex l -> GenRegex l -> GenRegex l-mkElse e1 (Zero _) = e1 -- e1 u {} = e1-mkElse (Zero _) e2 = e2 -- {} u e2 = e2-mkElse (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates- -- no symmetry allowed-mkElse e1@(Sym _) (Else e2@(Sym _) e3) = mkElse (mkElse e1 e2) e3 -- prepare melting of predicates-mkElse (Sym _) e2@Dot = e2 -- c|. = . for a c's-mkElse e1@(Star Dot) _e2 = e1 -- A* u e1 = A*-mkElse _e1 e2@(Star Dot) = e2 -- e1 u A* = A*-mkElse (Else e1 e2) e3 = mkElse e1 (mkElse e2 e3) -- associativity-mkElse e1 e2- | e1 == e2 = e1- | otherwise = Else e1 e2---- | Construct the sequence r.e. r1.r2--mkSeq :: GenRegex l -> GenRegex l -> GenRegex l-mkSeq e1@(Zero _) _e2 = e1-mkSeq _e1 e2@(Zero _) = e2-mkSeq Unit e2 = e2-mkSeq (Cbr e1 ss1) e2 = mkCbr (mkSeq e1 e2) ss1 -- move finished submatches upwards-mkSeq e1 Unit = e1-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-mkRep _ e@(Zero _) = e-mkRep _ e- | nullable e = mkStar e-mkRep i (Rep j e) = mkRep (i * j) e-mkRep i e = Rep i e---- | Construct range r{i,j}-mkRng :: Int -> Int -> GenRegex l -> GenRegex l-mkRng 0 0 _e = mkUnit-mkRng 1 1 e = e-mkRng lb ub _e- | lb > ub = Zero $- "illegal range " ++- show lb ++ ".." ++ show ub-mkRng _l _u e@(Zero _) = e-mkRng _l _u e@Unit = e-mkRng lb ub e = Rng lb ub e---- | Construct option r?-mkOpt :: GenRegex l -> GenRegex l-mkOpt = mkRng 0 1-{-# INLINE mkOpt #-}---- | Construct difference r.e.: r1 {\\} r2------ example------ > match "[a-z]+{\\}bush" "obama" = True--- > match "[a-z]+{\\}bush" "clinton" = True--- > match "[a-z]+{\\}bush" "bush" = False -- not important any more--mkDiff :: Eq l => GenRegex l -> GenRegex l -> GenRegex l-mkDiff e1@(Zero _) _e2 = e1 -- {} - r2 = {}-mkDiff e1 (Zero _) = e1 -- r1 - {} = r1-mkDiff _e1 (Star Dot) = mkZero "empty set in difference expr" -- r1 - .* = {}-mkDiff Dot (Sym p) = mkSym $ compCS p -- . - s = ~s-mkDiff (Sym _) Dot = mkZero "empty set in difference expr" -- x - . = {}-mkDiff (Sym p1) (Sym p2) = mkSym $ p1 `diffCS` p2 -- set diff-mkDiff e1 e2- | e1 == e2 = mkZero "empty set in difference expr" -- r1 - r1 = {}- | otherwise = Diff e1 e2---- | Construct the Complement of an r.e.: whole set of words - r--mkCompl :: Eq l => GenRegex l -> GenRegex l-mkCompl (Zero _) = mkAll-mkCompl (Star Dot) = mkZero "empty set in compl expr"-mkCompl e = mkDiff (mkStar mkDot) e---- | Construct r.e. for intersection: r1 {&} r2------ example------ > match ".*a.*{&}.*b.*" "-a-b-" = True--- > match ".*a.*{&}.*b.*" "-b-a-" = True--- > match ".*a.*{&}.*b.*" "-a-a-" = False--- > match ".*a.*{&}.*b.*" "---b-" = False--mkIsect :: Eq l => GenRegex l -> GenRegex l -> GenRegex l-mkIsect e1@(Zero _) _e2 = e1 -- {} n r2 = {}-mkIsect _e1 e2@(Zero _) = e2 -- r1 n {} = {}-mkIsect e1@(Unit) e2 -- () n r2 = () if nullable r2- | nullable e2 = e1 -- () n r2 = {} if not nullable r2- | otherwise = mkZero "intersection empty"-mkIsect e1 e2@(Unit) = mkIsect e2 e1 -- symmetric version of las 2 laws--mkIsect (Sym p1) (Sym p2) = mkSym $ p1 `intersectCS` p2 -- intersect sets-mkIsect e1@(Sym _) Dot = e1 -- x n . = x-mkIsect Dot e2@(Sym _) = e2 -- . n x = x--mkIsect (Star Dot) e2 = e2 -- .* n r2 = r2-mkIsect e1 (Star Dot) = e1 -- r1 n .* = r1-mkIsect e1 e2- | e1 == e2 = e1 -- r1 n r1 = r1- | otherwise = Isec e1 e2---- | Construct r.e. for exclusive or: r1 {^} r2------ example------ > match "[a-c]+{^}[c-d]+" "abc" = True--- > match "[a-c]+{^}[c-d]+" "acdc" = False--- > match "[a-c]+{^}[c-d]+" "ccc" = False--- > match "[a-c]+{^}[c-d]+" "cdc" = True--mkExor :: Eq l => GenRegex l -> GenRegex l -> GenRegex l-mkExor (Zero _) e2 = e2-mkExor e1 (Zero _) = e1-mkExor (Star Dot) _e2 = mkZero "empty set in exor expr"-mkExor _e1 (Star Dot) = mkZero "empty set in exor expr"-mkExor (Sym p1) (Sym p2) = mkSym $ p1 `exorCS` p2-mkExor (Sym p1) Dot = mkSym $ compCS p1-mkExor Dot (Sym p2) = mkSym $ compCS p2-mkExor e1 e2- | e1 == e2 = mkZero "empty set in exor expr" -- r1 xor r1 = {}- | otherwise = Exor e1 e2--mkInterleave :: GenRegex l -> GenRegex l -> GenRegex l-mkInterleave e1@(Zero _) _ = e1-mkInterleave _ e2@(Zero _) = e2-mkInterleave (Unit) e2 = e2-mkInterleave e1 (Unit) = e1-mkInterleave e1 e2 = Intl e1 e2--mkBr0 :: Label l -> GenRegex l -> String -> GenRegex l-mkBr0 _ e@(Zero _) _ = e-mkBr0 l Unit s = mkCbr mkUnit [(l,reverse s)]-mkBr0 l e s = Br l e s---- | Construct a labeled subexpression: ({label}r)--mkBr :: l -> GenRegex l -> GenRegex l-mkBr l e = mkBr0 (Just l) e ""--mkBr' :: GenRegex l -> GenRegex l-mkBr' e = mkBr0 Nothing e ""--mkCbr :: GenRegex l -> [(Label l, String)] -> GenRegex l-mkCbr e@(Zero _) _ = e -- dead end, throw away subexpr matches-mkCbr (Cbr e ss1) ss = mkCbr e (ss ++ ss1) -- join inner and this subexpr match-mkCbr e ss = Cbr e ss---- --------------------------------------------------------------instance Show l => Show (GenRegex l) where- show (Zero e) = "{" ++ e ++ "}"- show Unit = "()"- show (Sym p)- | p == compCS (stringCS "\n\r")- = "."- | null (tail cs) &&- rng1 (head cs)- = escRng . head $ cs- | otherwise = "[" ++ concat cs' ++ "]"- where- rng1 (x,y) = x == y- cs = p -- charRngs . chars $ p- cs' = map escRng p- escRng (x, y)- | x == y = esc x- | succ x == y- = esc x ++ esc y- | otherwise- = esc x ++ "-" ++ esc y- esc x- | x `elem` "\\-[]{}()*+?.^"- = '\\':x:""- | x >= ' ' && x <= '~'- = x:""- | otherwise- = "&#" ++ show (fromEnum x) ++ ";"- show Dot = "\\a"- show (Star Dot) = "\\A"- show (Star e) = "(" ++ show e ++ "*)"- show (Alt e1 e2) = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"- show (Else e1 e2) = "(" ++ show e1 ++ "{|}" ++ show e2 ++ ")"- show (Seq e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"- show (Rep 1 e) = "(" ++ show e ++ "+)"- show (Rep i e) = "(" ++ show e ++ "{" ++ show i ++ ",})"- show (Rng 0 1 e) = "(" ++ show e ++ "?)"- show (Rng i j e) = "(" ++ show e ++ "{" ++ show i ++ "," ++ show j ++ "})"- show (Diff e1 e2) = "(" ++ show e1 ++ "{\\}" ++ show e2 ++ ")"- show (Isec e1 e2) = "(" ++ show e1 ++ "{&}" ++ show e2 ++ ")"- show (Exor e1 e2) = "(" ++ show e1 ++ "{^}" ++ show e2 ++ ")"- show (Intl e1 e2) = "(" ++ show e1 ++ "{:}" ++ show e2 ++ ")"- show (Br l e s) = "({" ++ showL l ++ (if null s- then ""- else "=" ++ reverse s- ) ++ "}" ++ show e ++ ")"- show (Cbr e ss) = "([" ++ intercalate "," (map (\(l,s) -> showL l ++ "=" ++ s) ss) ++ "]"- ++ show e ++- ")"--showL :: Show l => Label l -> String-showL = rmq . maybe "" show- where- rmq ('\"':xs) = init xs- rmq xs = xs---- --------------------------------------------------------------isZero :: GenRegex l -> Bool-isZero (Zero _) = True-isZero _ = False-{-# INLINE isZero #-}--errRegex :: GenRegex l -> String-errRegex (Zero e) = e-errRegex _ = ""---- --------------------------------------------------------------nullable :: GenRegex l -> Bool-nullable = fst . nullable'-{-# INLINE nullable #-}--nullable' :: GenRegex l -> Nullable l--nullable' (Zero _) = (False, [])-nullable' Unit = (True, [])-nullable' Dot = (False, [])-nullable' (Sym _x) = (False, [])--nullable' (Star _e) = (True, [])-nullable' (Rep _i e) = nullable' e-nullable' (Rng i _ e) = (i == 0, []) `unionN` nullable' e-nullable' (Seq e1 e2) = nullable' e1 `isectN` nullable' e2--nullable' (Alt e1 e2) = nullable' e1 `unionN` nullable' e2-nullable' (Else e1 e2) = nullable' e1 `orElseN` nullable' e2-nullable' (Isec e1 e2) = nullable' e1 `isectN` nullable' e2-nullable' (Diff e1 e2) = nullable' e1 `diffN` nullable' e2-nullable' (Exor e1 e2) = nullable' e1 `exorN` nullable' e2-nullable' (Intl e1 e2) = nullable' e1 `isectN` nullable' e2--nullable' (Br l e s) = (True, [(l, reverse s)]) `isectN` nullable' e-nullable' (Cbr e ss) = (True, ss) `isectN` nullable' e--isectN :: Nullable l -> Nullable l -> Nullable l-isectN (True, ws1) (True, ws2) = (True, ws1 ++ ws2)-isectN _ _ = (False, [])--unionN :: Nullable l -> Nullable l -> Nullable l-unionN (False, _) (False, _) = (False, [])-unionN (_, ws1) (_, ws2) = (True, ws1 ++ ws2)--orElseN :: Nullable l -> Nullable l -> Nullable l-orElseN e1@(True, _ws1) _ = e1-orElseN _ e2 = e2--diffN :: Nullable l -> Nullable l -> Nullable l-diffN n1 (False, _) = n1-diffN _ _ = (False, [])--exorN :: Nullable l -> Nullable l -> Nullable l-exorN n1@(True, _) (False, _) = n1-exorN (False, _) n2@(True, _) = n2-exorN _ _ = (False, [])---- ---------------------------------------------------------------- | 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 (Intl e1 e2) = firstChars e1 `unionCS` firstChars e2-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 $- "unexpected char " ++ show c-delta1 (Sym p) c- | c `elemCS` p = mkUnit- | otherwise = mkZero $- "unexpected char " ++ show c--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)--delta1 (Else e1 e2) c = mkElse (delta1 e1 c) (delta1 e2 c)--delta1 (Seq e1@(Br l e1' s) e2) c- | n = mkAlt (mkSeq (delta1 e1 c) e2)- (mkCbr (delta1 e2 c) ((l, reverse s) : ws))- where- (n, ws) = nullable' e1'-delta1 (Seq e1 e2) c- | nullable e1 = mkAlt (mkSeq (delta1 e1 c) e2)- (delta1 e2 c)- | otherwise = mkSeq (delta1 e1 c) e2--delta1 (Rep i e) c = mkSeq (delta1 e c) (mkRep (i-1) e)--delta1 (Rng i j e) c = mkSeq (delta1 e c) (mkRng ((i-1) `max` 0) (j-1) e)--delta1 (Diff e1 e2) c = mkDiff (delta1 e1 c) (delta1 e2 c)--delta1 (Isec e1 e2) c = mkIsect (delta1 e1 c) (delta1 e2 c)--delta1 (Exor e1 e2) c = mkExor (delta1 e1 c) (delta1 e2 c)--delta1 (Intl e1 e2) c = mkAlt (mkInterleave (delta1 e1 c) e2 )- (mkInterleave e1 (delta1 e2 c))--delta1 (Br l e s) c = mkBr0 l (delta1 e c) (c:s)--delta1 (Cbr e ss) c = mkCbr (delta1 e c) ss---- --------------------------------------------------------------delta :: Eq l => GenRegex l -> String -> GenRegex l-delta e [] = e-delta e@(Zero _) _xs = e-delta e@(Star Dot) _xs = e-delta e (x : xs) = delta (delta1 e x) xs--matchWithRegex :: Eq l => GenRegex l -> String -> Bool-matchWithRegex e = nullable . delta e--matchWithRegex' :: Eq l => GenRegex l -> String -> Maybe [(Label l,String)]-matchWithRegex' e = (\ (r, l) -> if r then Just l else Nothing) . nullable' . delta e---- ---------------------------------------------------------------- | This function wraps the whole regex in a subexpression before starting--- the parse. This is done for getting acces to--- the whole parsed string. Therfore we need one special label, this label--- is the Nothing value, all explicit labels are Just labels.--splitWithRegex :: Eq l => GenRegex l -> String -> Maybe ([(Label l,String)], String)-splitWithRegex re inp = do- (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--{- linear recursive function, can lead to stack overflow--splitWithRegex' :: Eq l => GenRegex l -> String -> Maybe (GenRegex l, String)-splitWithRegex' re ""- | nullable re = Just (re, "")- | otherwise = Nothing--splitWithRegex' re inp@(c : inp')- | isZero re = Nothing- | otherwise = evalRes . splitWithRegex' (delta1 re c) $ inp'- where- evalRes Nothing- | nullable re = Just (re, inp)- | otherwise = Nothing- evalRes res = res--}---- tail recursive version of above function--splitWithRegex' :: Eq l => GenRegex l -> String -> Maybe (GenRegex l, String)-splitWithRegex' re inp = splitWithRegex''- ( if nullable re- then Just (re, inp) -- first possible result: empty prefix- else Nothing -- empty prefix not a result- ) re inp--splitWithRegex'' :: Eq l => Maybe (GenRegex l, String) -> GenRegex l -> String -> Maybe (GenRegex l, String)-splitWithRegex'' lastRes _re "" = lastRes--splitWithRegex'' lastRes re (c : inp')- | isZero re = lastRes- | otherwise = splitWithRegex'' nextRes re' $ inp'- where- re' = delta1 re c- nextRes- | nullable re' = Just (re', inp')- | otherwise = lastRes---- ---------------------------------------------- | 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 inp@(c : _)- | c `elemCS` cs = splitWithRegex' re inp--splitWithRegexCS' re _cs inp- | nullable re = Just (re, inp)- | otherwise = Nothing---- ------------------------------------------------------------
− src/Text/Regex/XMLSchema/String/RegexParser.hs
@@ -1,520 +0,0 @@--- --------------------------------------------------------------{- |- Module : Text.Regex.XMLSchema.String.RegexParser- Copyright : Copyright (C) 2010- Uwe Schmidt- License : MIT-- Maintainer : Uwe Schmidt (uwe@fh-wedel.de)- Stability : stable- Portability: portable-- W3C XML Schema Regular Expression Parser-- This parser supports the full W3C standard, the- complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>- and extensions for all missing set operations, intersection, difference, exclusive or, interleave, complement---}---- --------------------------------------------------------------module Text.Regex.XMLSchema.String.RegexParser- ( parseRegex- , parseRegexExt- , parseContextRegex- )-where--import Data.Char.Properties.UnicodeBlocks-import Data.Char.Properties.UnicodeCharProps-import Data.Char.Properties.XMLCharProps--import Data.List ( isPrefixOf, isSuffixOf )--import Data.Maybe--import Data.Set.CharSet--import Text.ParserCombinators.Parsec--import Text.Regex.XMLSchema.String.Regex----- ---------------------------------------------------------------- | parse a standard W3C XML Schema regular expression--parseRegex :: String -> Regex-parseRegex = parseRegex' regExpStd---- | parse an extended syntax W3C XML Schema regular expression------ The Syntax of the W3C XML Schema spec is extended by--- further useful set operations, like intersection, difference, exor.--- Subexpression match becomes possible with \"named\" pairs of parentheses.--- The multi char escape sequence \\a represents any Unicode char,--- The multi char escape sequence \\A represents any Unicode word, (\\A = \\a*).--- All syntactically wrong inputs are mapped to the Zero expression representing the--- empty set of words. Zero contains as data field a string for an error message.--- So error checking after parsing becomes possible by checking against Zero ('isZero' predicate)--parseRegexExt :: String -> Regex-parseRegexExt = parseRegex' regExpExt--parseRegex' :: Parser Regex -> String -> Regex-parseRegex' regExp' = either (mkZero . ("syntax error: " ++) . show) id- .- parse ( do- r <- regExp'- eof- return r- ) ""---- ---------------------------------------------------------------- | parse a regular expression surrounded by contenxt spec------ a leading @^@ denotes start of text,--- a trailing @$@ denotes end of text,--- a leading @\\<@ denotes word start,--- a trailing @\\>@ denotes word end.------ The 1. param ist the regex parser ('parseRegex' or 'parseRegexExt')--parseContextRegex :: (String -> Regex) -> String -> Regex-parseContextRegex parseRe re- = re'- where- re' = mkSeqs . concat $ [ startContext- , (:[]) . parseRe $ re2- , endContext- ]- (startContext, re1)- | "^" `isPrefixOf` re = ([], tail re)- | "\\<" `isPrefixOf` re = ([parseRegexExt "(\\A\\W)?"], drop 2 re)- | otherwise = ([mkStar mkDot], re)- (endContext, re2)- | "$" `isSuffixOf` re1 = ([], init re1)- | "\\>" `isSuffixOf` re1 = ([parseRegexExt "(\\W\\A)?"], init . init $ re1)- | otherwise = ([mkStar mkDot], re1)----- --------------------------------------------------------------regExpExt :: Parser Regex-regExpExt = branchList orElseList--regExpStd :: Parser Regex-regExpStd = branchList seqListStd--branchList :: Parser Regex -> Parser Regex-branchList exParser- = do- r1 <- exParser- rs <- many branchList1- return (foldr1 mkAlt $ r1:rs) -- union is associative, so we use right ass.- -- as with seq, alt and exor- where- branchList1- = do- _ <- char '|'- exParser--orElseList :: Parser Regex-orElseList- = do- r1 <- interleaveList- rs <- many orElseList1- return (foldr1 mkElse $ r1:rs) -- orElse is associative, so we choose right ass.- -- as with seq and alt ops- where- orElseList1- = do- _ <- try (string "{|}")- interleaveList--interleaveList :: Parser Regex-interleaveList- = do- r1 <- exorList- rs <- many interleaveList1- return (foldr1 mkInterleave $ r1:rs) -- interleave is associative, so we choose right ass.- -- as with seq and alt ops- where- interleaveList1- = do- _ <- try (string "{:}")- exorList--exorList :: Parser Regex-exorList- = do- r1 <- diffList- rs <- many exorList1- return (foldr1 mkExor $ r1:rs) -- exor is associative, so we choose right ass.- where- exorList1- = do- _ <- try (string "{^}")- diffList--diffList :: Parser Regex-diffList- = do- r1 <- intersectList- rs <- many diffList1- return (foldl1 mkDiff $ r1:rs) -- diff is not associative, so we choose left ass.- where- diffList1- = do- _ <- try (string "{\\}")- intersectList--intersectList :: Parser Regex-intersectList- = do- r1 <- seqListExt- rs <- many intersectList1- return (foldr1 mkIsect $ r1:rs)- where- intersectList1- = do- _ <- try (string "{&}")- seqListExt--seqListExt :: Parser Regex-seqListExt = seqList' regExpLabel multiCharEscExt--seqListStd :: Parser Regex-seqListStd = seqList' regExpStd multiCharEsc--seqList' :: Parser Regex -> Parser Regex -> Parser Regex-seqList' regExp' multiCharEsc'- = do- rs <- many piece- return $ mkSeqs rs- where- piece :: Parser Regex- piece- = do- r <- atom- quantifier r-- atom :: Parser Regex- atom- = char1- <|>- charClass- <|>- between (char '(') (char ')') regExp'-- charClass :: Parser Regex- charClass- = charClassEsc multiCharEsc'- <|>- charClassExpr multiCharEsc'- <|>- wildCardEsc----quantifier :: Regex -> Parser Regex-quantifier r- = ( do- _ <- char '?'- return $ mkOpt r )- <|>- ( do- _ <- char '*'- return $ mkStar r )- <|>- ( do- _ <- char '+'- return $ mkRep 1 r )- <|>- try ( do- _ <- char '{'- res <- quantity r- _ <- char '}'- return res- )- <|>- ( return r )--quantity :: Regex -> Parser Regex-quantity r- = do- lb <- many1 digit- quantityRest r (read lb)--quantityRest :: Regex -> Int -> Parser Regex-quantityRest r lb- = ( do- _ <- char ','- ub <- many digit- return ( if null ub- then mkRep lb r- else mkRng lb (read ub) r- )- )- <|>- ( return $ mkRng lb lb r)--regExpLabel :: Parser Regex-regExpLabel- = do- lab <- option id (between (char '{') (char '}') label')- r <- regExpExt- return $ lab r- where- label'- = do- l <- many1 (satisfy isXmlNameChar)- return $ mkBr l--char1 :: Parser Regex-char1- = do- c <- satisfy (`notElem` ".\\?*+{}()|[]")- return $ mkSym1 c--charClassEsc :: Parser Regex -> Parser Regex-charClassEsc multiCharEsc'- = do- _ <- char '\\'- ( singleCharEsc- <|>- multiCharEsc'- <|>- catEsc- <|>- complEsc )--singleCharEsc :: Parser Regex-singleCharEsc- = do- c <- singleCharEsc'- return $ mkSym1 c--singleCharEsc' :: Parser Char-singleCharEsc'- = do- c <- satisfy (`elem` "nrt\\|.?*+(){}-[]^")- return $ maybe c id . lookup c . zip "ntr" $ "\n\r\t"--multiCharEscExt :: Parser Regex-multiCharEscExt- = multiCharEsc- <|>- ( do -- extension: \a represents the whole alphabet inclusive newline chars: \a == .|\n|\r- _ <- char 'a'- return mkDot )- <|>- ( do -- extension: \A represents all words: \A == \a* or \A == (.|\n|\r)*- _ <- char 'A'- return mkAll )--multiCharEsc :: Parser Regex-multiCharEsc- = ( do- c <- satisfy (`elem` es)- return $ mkSym . fromJust . lookup c $ pm )- where- es = map fst pm- pm = [ ('s', charPropXmlSpaceChar )- , ('S', compCS charPropXmlSpaceChar )- , ('i', charPropXmlNameStartChar )- , ('I', compCS charPropXmlNameStartChar )- , ('c', charPropXmlNameChar )- , ('C', compCS charPropXmlNameChar )- , ('d', charPropDigit )- , ('D', compCS charPropDigit )- , ('w', compCS charPropNotWord )- , ('W', charPropNotWord )- ]- charPropDigit = rangeCS '0' '9'- charPropNotWord = charPropUnicodeP- `unionCS`- charPropUnicodeZ- `unionCS`- charPropUnicodeC--catEsc :: Parser Regex-catEsc- = do- _ <- char 'p'- s <- between (char '{') (char '}') charProp- return $ mkSym s--charProp :: Parser CharSet-charProp- = isCategory- <|>- isBlock--isBlock :: Parser CharSet-isBlock- = do- _ <- string "Is"- name <- many1 (satisfy legalChar)- case lookup name codeBlocks of- Just b -> return $ uncurry rangeCS b- Nothing -> fail $ "unknown Unicode code block " ++ show name- where- legalChar c = 'A' <= c && c <= 'Z' ||- 'a' <= c && c <= 'z' ||- '0' <= c && c <= '9' ||- '-' == c--isCategory :: Parser CharSet-isCategory- = do- pr <- isCategory'- return $ fromJust (lookup pr categories)--categories :: [(String, CharSet)]-categories- = [ ("C", charPropUnicodeC )- , ("Cc", charPropUnicodeCc)- , ("Cf", charPropUnicodeCf)- , ("Co", charPropUnicodeCo)- , ("Cs", charPropUnicodeCs)- , ("L", charPropUnicodeL )- , ("Ll", charPropUnicodeLl)- , ("Lm", charPropUnicodeLm)- , ("Lo", charPropUnicodeLo)- , ("Lt", charPropUnicodeLt)- , ("Lu", charPropUnicodeLu)- , ("M", charPropUnicodeM )- , ("Mc", charPropUnicodeMc)- , ("Me", charPropUnicodeMe)- , ("Mn", charPropUnicodeMn)- , ("N", charPropUnicodeN )- , ("Nd", charPropUnicodeNd)- , ("Nl", charPropUnicodeNl)- , ("No", charPropUnicodeNo)- , ("P", charPropUnicodeP )- , ("Pc", charPropUnicodePc)- , ("Pd", charPropUnicodePd)- , ("Pe", charPropUnicodePe)- , ("Pf", charPropUnicodePf)- , ("Pi", charPropUnicodePi)- , ("Po", charPropUnicodePo)- , ("Ps", charPropUnicodePs)- , ("S", charPropUnicodeS )- , ("Sc", charPropUnicodeSc)- , ("Sk", charPropUnicodeSk)- , ("Sm", charPropUnicodeSm)- , ("So", charPropUnicodeSo)- , ("Z", charPropUnicodeZ )- , ("Zl", charPropUnicodeZl)- , ("Zp", charPropUnicodeZp)- , ("Zs", charPropUnicodeZs)- ]--isCategory' :: Parser String-isCategory'- = ( foldr1 (<|>) . map (uncurry prop) $- [ ('L', "ultmo")- , ('M', "nce")- , ('N', "dlo")- , ('P', "cdseifo")- , ('Z', "slp")- , ('S', "mcko")- , ('C', "cfon")- ]- ) <?> "illegal Unicode character property"- where- prop c1 cs2- = do- _ <- char c1- s2 <- option ""- ( do- c2 <- satisfy (`elem` cs2)- return [c2] )- return $ c1:s2--complEsc :: Parser Regex-complEsc- = do- _ <- char 'P'- s <- between (char '{') (char '}') charProp- return $ mkSym $ compCS s--charClassExpr :: Parser Regex -> Parser Regex-charClassExpr multiCharEsc'- = between (char '[') (char ']') charGroup- where-- charGroup :: Parser Regex- charGroup- = do- r <- ( negCharGroup -- a ^ at beginning denotes negation, not start of posCharGroup- <|>- posCharGroup- )- s <- option (mkZero "") -- charClassSub- ( do- _ <- char '-'- charClassExpr multiCharEsc'- )- return $ mkDiff r s-- posCharGroup :: Parser Regex- posCharGroup- = do- rs <- many1 (charRange <|> charClassEsc multiCharEsc')- return $ foldr1 mkAlt rs-- negCharGroup :: Parser Regex- negCharGroup- = do- _ <- char '^'- r <- posCharGroup- return $ mkDiff mkDot r--charRange :: Parser Regex-charRange- = try seRange- <|>- xmlCharIncDash--seRange :: Parser Regex-seRange- = do- c1 <- charOrEsc'- _ <- char '-'- c2 <- charOrEsc'- return $ mkSymRng c1 c2--charOrEsc' :: Parser Char-charOrEsc'- = ( do- _ <- char '\\'- singleCharEsc'- )- <|>- satisfy (`notElem` "\\-[]")--xmlCharIncDash :: Parser Regex-xmlCharIncDash- = try ( do -- dash is only allowed if not followed by a [, else charGroup differences do not parse correctly- _ <- char '-'- notFollowedBy (char '[')- return $ mkSym1 '-'- )- <|>- ( do- c <- satisfy (`notElem` "-\\[]")- return $ mkSym1 c- )--wildCardEsc :: Parser Regex-wildCardEsc- = do- _ <- char '.'- return . mkSym . compCS $ stringCS "\n\r"----- ------------------------------------------------------------
− test/.ghci
@@ -1,2 +0,0 @@-:set -i../../src-:load Main
+ test/Benchmark.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- ------------------------------------------------------------++module Main+where++import Control.DeepSeq++import Criterion.Main++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Text.Regex.XMLSchema.Generic+import Text.Regex.XMLSchema.Generic.StringLike++-- import Debug.Trace++-- ------------------------------------------------------------++type BS = B.ByteString+type BL = BL.ByteString+type Text = T.Text+type TextL = TL.Text++-- ------------------------------------------------------------++benchSTB :: String ->+ (forall s . (NFData s, StringLike s) => s -> [s]) ->+ (String, String -> [String]) ->+ String ->+ Benchmark+benchSTB name fct ref inp+ = benchSTB' name fct ref $! mkInput inp++benchSTB' :: String ->+ (forall s . (NFData s, StringLike s) => s -> [s]) ->+ (String, String -> [String]) ->+ (String, Text, TextL, BS, BL) ->+ Benchmark+benchSTB' name fct (refName, ref) (s, t, tl, bs, bl)+ = bgroup name+ [ bench refName $ nf ref s+ , bench "String" $ nf fct s+ , bench "Text" $ nf fct t+ , bench "Text.Lazy" $ nf fct tl+ , bench "ByteString" $ nf fct bs+ , bench "ByteString.Lazy" $ nf fct bl+ ]++mkInput :: String -> (String, Text, TextL, BS, BL)+mkInput s+ = rnf t5 `seq` t5+ where+ t5 = (s, fromString s, fromString s, fromString s, fromString s)+ +words' :: StringLike s => s -> [s]+words' inp+ = tokenize (fromString "\\w+") inp++ +main :: IO ()+main+ = do+ defaultMain [ benchSTB "100,000-words" words' ("words", words)+ $ unwords (replicate 100000 "1234567890")+ ]++-- ------------------------------------------------------------
+ test/Date.hs view
@@ -0,0 +1,633 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Main+where++import Control.Arrow ( (***), second )++import Data.Char ( toLower, toUpper )+import Data.List ( isPrefixOf )+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import System.Exit (ExitCode (..), exitWith)++import Test.HUnit++import Text.Parsec+import Text.Regex.XMLSchema.Generic+import Text.Regex.XMLSchema.Generic.StringLike++-- ------------------------------------------------------------++newtype Test' a = Test' {unTest' :: Test}++type BS = B.ByteString+type BL = BL.ByteString+type Text = T.Text+type TextL = TL.Text++-- ------------------------------------------------------------+-- some little helpers for building r.e.s++star :: String -> String+star = (++ "*") . pars++plus :: String -> String+plus = (++ "+") . pars++opt :: String -> String+opt = (++ "?") . pars++dot :: String -> String+dot = (++ "\\.")++pars :: String -> String+pars = ("(" ++) . (++ ")")++orr :: String -> String -> String+orr x y = pars $ pars x ++ "|" ++ pars y++xor :: String -> String -> String+xor x y = pars $ pars x ++ "{|}" ++ pars y++nocase :: String -> String+nocase (x:xs) = '[' : toUpper x : toLower x : ']' : xs+nocase [] = error "nocase with empty list"++alt :: [String] -> String+alt = pars . foldr1 orr++altNC :: [String] -> String+altNC = pars . alt . map nocase++subex :: String -> String -> String+subex n e = pars $ "{" ++ n ++ "}" ++ pars e++ws :: String+ws = "\\s"++ws0 :: String+ws0 = star ws++ws1 :: String+ws1 = plus ws++s0 :: String -> String -> String+s0 x y = x ++ ws0 ++ y++-- the date and time r.e.s++day :: String+day = "(0?[1-9]|[12][0-9]|3[01])"++month :: String+month = "(0?[1-9]|1[0-2])"++year2 :: String+year2 = "[0-5][0-9]"++year4 :: String+year4 = "20" ++ year2++year :: String+year = year4 `orr` year2++year' :: String+year' = "'" ++ year2++dayD :: String+dayD = dot day+monthD :: String+monthD = dot month++dayMonthYear :: String+dayMonthYear = dayD `s0` monthD `s0` year+dayMonth :: String+dayMonth = dayD `s0` monthD++dayOfWeekL :: String+dayOfWeekL = altNC+ [ "montag"+ , "dienstag"+ , "mittwoch"+ , "donnerstag"+ , "freitag"+ , "samstag"+ , "sonnabend"+ , "sonntag"+ ]++dayOfWeekA :: String+dayOfWeekA = alt . map dot $+ [ "Mo", "Di", "Mi", "Do", "Fr", "Sa", "So"]++dayOfWeek :: String+dayOfWeek = dayOfWeekL `orr` dayOfWeekA++monthL :: String+monthL = altNC+ [ "januar"+ , "februar"+ , "märz"+ , "april"+ , "mai"+ , "juni"+ , "juli"+ , "august"+ , "september"+ , "oktober"+ , "november"+ , "dezember"+ ]++monthA :: String+monthA = altNC . map dot $ map snd monthAbr++monthAbr :: [(Integer, String)]+monthAbr = (9, "sept") :+ zip [1..12]+ [ "jan", "feb", "mär", "apr", "mai", "jun", "jul", "aug", "sep", "okt", "nov", "dez"]++monthN :: String+monthN = pars $ monthL `orr` monthA++hour :: String+hour = pars "([0-1]?[0-9])|(2[0-4])"++minute :: String+minute = pars "(0?[0-9])|([1-5][0-9])"++uhr :: String+uhr = ws0 ++ nocase "uhr"++hourMin :: String+hourMin = hour ++ ":" ++ minute ++ opt uhr++wsyear :: String+wsyear = year ++ "/[0-9]{2}"++wsem :: String+wsem = ("Wi?Se?" `orr` nocase "Wintersemester") ++ ws0 ++ wsyear++ssem :: String+ssem = ("So?Se?" `orr` nocase "Sommersemester") ++ ws0 ++ year++sem :: String+sem = wsem `orr` ssem++num :: String+num = "\\d+"++-- the token types++tokenRE :: String+tokenRE = foldr1 xor $+ map (uncurry subex) $+ [ ( "ddmmyyyy", dayMonthYear )+ , ( "ddMonthyyyy", dayD `s0` monthN `s0` (year `orr` year') )+ , ( "ddmm", dayMonth)+ , ( "ddMonth", dayD `s0` monthN )+ , ( "yyyymmdd", year ++ "[-/]" ++ month ++ "[-/]" ++ day )+ , ( "yyyy", year4 `orr` ("'" ++ year2) )+ , ( "month", monthN )+ , ( "weekday", dayOfWeek )+ , ( "HHMM", hourMin ++ opt uhr )+ , ( "HH", hour ++ uhr )+ , ( "wsem", wsem)+ , ( "ssem", ssem)+ , ( "word", "[\\w\\d]+")+ , ( "del", "[^\\w\\d]+")+ ]+++-- ------------------------------------------------------------++type Token = (String, String)+type TokenStream = [Token]++type DateParser a = Parsec [(String, String)] () a++type StringFct = String -> String -- for fast concatenation++-- must be extended for weekday or semester, if neccessay++data DateVal = DT { _year :: ! Int+ , _month :: ! Int+ , _day :: ! Int+ , _hour :: ! Int+ , _min :: ! Int+ }+ deriving (Eq, Show)++data DateParse = DP { _pre :: StringFct+ , _rep :: StringFct+ , _dat :: ! DateVal+ }++-- just a helper for result output+data DateRep = DR { _p :: String+ , _r :: String+ , _d :: ! DateVal+ }+ deriving (Eq, Show)++-- ------------------------------------------------------------++emptyText :: StringFct+emptyText = id++mkText :: String -> StringFct+mkText = (++)++concText :: StringFct -> StringFct -> StringFct+concText = (.)++textToString :: StringFct -> String+textToString = ($ [])++emptyDateVal :: DateVal+emptyDateVal = DT { _year = -1+ , _month = -1+ , _day = -1+ , _hour = -1+ , _min = -1+ }++emptyDateParse :: DateParse+emptyDateParse = DP { _pre = emptyText+ , _rep = emptyText+ , _dat = emptyDateVal+ }++appPre :: String -> DateParse -> DateParse+appPre s d = d { _pre = _pre d `concText` mkText s }++appRep :: String -> DateParse -> DateParse+appRep s d = d { _rep = _rep d `concText` mkText s }++setDay :: Int -> Int -> Int -> DateParse -> DateParse+setDay j m t d = d { _dat = setDateVal j m t (-1) (-1) (_dat d) }++setHour :: Int -> Int -> DateParse -> DateParse+setHour h m d = d { _dat = setDateVal (-1) (-1) (-1) h m (_dat d) }++setDateVal :: Int -> Int -> Int -> Int -> Int -> DateVal -> DateVal+setDateVal j m t s i (DT j' m' t' s' i' )+ = DT j'' m'' t'' s'' i''+ where+ j'' | j < 0 = j' -- year not there+ | j < 100 = j + 2000 -- 2 digit year+ | otherwise = j -- 4 digit year+ m'' = m `max` m'+ t'' = t `max` t'+ s'' = s `max` s'+ i'' = i `max` i'++datePToDateRep :: DateParse -> DateRep+datePToDateRep dp+ = DR { _p = textToString $ _pre dp+ , _r = textToString $ _rep dp+ , _d = _dat dp+ }++-- ------------------------------------------------------------++-- a simple helper for showing the results++dateSearch' :: TokenStream -> [DateRep]+dateSearch' = map datePToDateRep .+ dateSearch++-- look for a sequence of date specs, the last entry in the list+-- does not contain a valid date, but just the context behind the last real date++dateSearch :: TokenStream -> [DateParse]+dateSearch = either (const []) id .+ parse (many (dateParser emptyDateParse)) ""++-- all date parsers thread a state the subparsers to accumulate+-- the parts of a date, the context, the external representation and+-- the pure data, year, month, day, ...++dateParser :: DateParse -> DateParser DateParse+dateParser d = ( do+ s <- fillTok+ dateParser0 (appPre s d)+ )+ <|>+ parseDate d -- here is the hook for the real date parser+ <|>+ ( do+ s <- textTok -- the default case: if parseDate fails+ dateParser0 (appPre s d) -- the token is handled like a normal word+ )++dateParser0 :: DateParse -> DateParser DateParse+dateParser0 d = dateParser d <|> return d+++parseDate :: DateParse -> DateParser DateParse+parseDate d = parseDate0 d+ <|>+ try+ ( do+ d1 <- parseWeekDay d+ lookAheadN 3 parseDate0 d1 -- Freitag, den 13.+ )++-- parse a date optionally followed by a time+parseDate0 :: DateParse -> DateParser DateParse+parseDate0 d = ( do+ d1 <- parseDay d+ option d1 (parseFollowingHour d1)+ )++-- parse a simple token for a day+parseDay :: DateParse -> DateParser DateParse+parseDay d = ( do+ (s, d') <- parseDateTok "ddmmyyyy" d+ let [t, m, j] = tokenize num s+ return $ setDay (read j) (read m) (read t) d'+ )+ <|>+ ( do+ (s, d') <- parseDateTok "ddMonthyyyy" d+ let s' = sed ((++ ".") . monthToM) monthN s+ let [t, m, j] = tokenize num s'+ return $ setDay (read j) (read m) (read t) d'+ )+ <|>+ ( do+ (s, d') <- parseDateTok "ddmm" d+ let [t, m] = tokenize num s+ return $ setDay (-1) (read m) (read t) d'+ )+ <|>+ ( do+ (s, d') <- parseDateTok "ddMonth" d+ let s' = sed ((++ ".") . monthToM) monthN s+ let [t, m] = tokenize num s'+ return $ setDay (-1) (read m) (read t) d'+ )+ <|>+ ( do+ (s, d') <- parseDateTok "yyyymmdd" d+ let [j, m, t] = tokenize num s+ return $ setDay (read j) (read m) (read t) d'+ )++parseYear :: DateParse -> DateParser DateParse+parseYear d = ( do+ (s, d') <- parseDateTok "yyyy" d+ let [j] = tokenize num s+ return $ setDay (read j) (-1) (-1) d'+ )++-- parse a weekday and add it to the external rep.++parseWeekDay :: DateParse -> DateParser DateParse+parseWeekDay d = ( do+ (_s, d') <- parseDateTok "weekday" d+ return d'+ )++-- parse a following hour spec, 5 fill tokens, words or delimiters are possible++parseFollowingHour :: DateParse -> DateParser DateParse+parseFollowingHour+ = try . -- backtracking becomes neccessary+ lookAheadN 5 parseHour -- max 2 words and 3 delimiters++-- parse the simple time formats+parseHour :: DateParse -> DateParser DateParse+parseHour d = ( do+ (s, d') <- parseDateTok "HHMM" d+ let [h, m] = tokenize num s+ return $ setHour (read h) (read m) d'+ )+ <|>+ ( do+ (s, d') <- parseDateTok "HH" d+ let [h] = tokenize num s+ return $ setHour (read h) 0 d'+ )++-- ------------------------------------------------------------+--+-- auxiliary parser combinators++-- parse a token of a given type and add the text to the external rep.++parseDateTok :: String -> DateParse -> DateParser (String, DateParse)+parseDateTok tty d+ = dateTok (isTokType (== tty)) d++dateTok :: DateParser String -> DateParse -> DateParser (String, DateParse)+dateTok t d = ( do+ s <- t+ return (s, appRep s d)+ )++-- try to apply a parser, but first skip a given # of fill tokens++lookAheadN :: Int -> (DateParse -> DateParser DateParse) -> DateParse -> DateParser DateParse+lookAheadN n p d+ | n <= 0 = p d+ | otherwise = do+ (_, d1) <- dateTok fillTok d+ ( lookAheadN (n - 1) p d1 <|> p d1 )++-- ------------------------------------------------------------+--+-- basic token parsers++-- the interface to the primitive parsec token parser+tok :: (Token -> Bool) -> DateParser Token+tok prd = tokenPrim showTok nextPos testTok+ where+ showTok = show . fst+ nextPos pos _tok _ts = incSourceColumn pos 1+ testTok tk = if prd tk then Just tk else Nothing++-- check for specific token type and in case of success return the text value+isTokType :: (String -> Bool) -> DateParser String+isTokType isT = tok (isT . fst) >>= return . snd++-- parse an arbitrary token and return the text value+textTok :: DateParser String+textTok = isTokType (const True)++-- a word+wordTok :: DateParser String+wordTok = isTokType (== "word")++-- a delimiter, whitespace is normalized, sequences are reduced to a single space char+delTok :: DateParser String+delTok = isTokType (== "del")+ >>=+ return . sed (const " ") ws1++-- tokens that don't contain date info++fillTok :: DateParser String+fillTok = delTok <|> wordTok++-- semester tokens, not yet interpreted+semTok' :: String -> DateParser (String, Int, Bool)+semTok' sem' = do v <- isTokType (== sem')+ return (v, read . head . tokenizeExt year $ v, sem' == "ssem")++semTok :: DateParser (String, Int, Bool)+semTok = semTok' "ssem" <|> semTok' "wsem"++-- ------------------------------------------------------------++-- conversion from month names to 1..12+monthToM :: String -> String+monthToM m+ = show .+ (\ l -> if null l then 99 else head l) .+ map fst .+ filter ((== True) . snd) .+ map (second (`isPrefixOf` map toLower m)) $+ monthAbr++-- ------------------------------------------------------------++ts :: String+ts = "Am Sonntag, dem 17. Februar '03 findet um 9 Uhr ein wichtiger Termin für das Sommersemester 2000 statt. "+ ++ "Dieser wird allerdings auf Montag verschoben. Und zwar auf den ersten Montag im Wintersemester 11/12, 12:30. "+ ++ "Ein wichtiger Termin findet im SoSe 2011 statt. Im Jahr '12 gibt es Termine, aber auch in WS 2010/11. "+ ++ "Ein weiterer Termin ist am 2.4.11 um 12 Uhr. Oder war es doch Di. der 3.4.? Egal. "+ ++ "Ein weiterer wichtiger Termin findet am 2001-3-4 statt bzw. generell zwischen 01/3/4 - 01/6/4 um 13 Uhr. "+ ++ "Am kommenden Mittwoch findet Changemanagement in HS5 statt. Dies gilt dann auch für den 7. Juni "+ ++ "des Jahres 2011. Noch ein wichtiger Termin findet um 16:15 Uhr am Do., 1.2.03 statt. "+ ++ "Freitag, der 13. Juli ist kein Glückstag"+ ++ "und Freitag, der 13. Juli um 11:55 Uhr ist es zu spät."++rrr :: [String]+rrr = map _r . dateSearch' . tokenizeSubex tokenRE $ ts++ddd :: [DateVal]+ddd = map _d . dateSearch' . tokenizeSubex tokenRE $ ts++aaa :: [DateRep]+aaa = dateSearch' . tokenizeSubex tokenRE $ ts++tt :: String -> [(String, String)]+tt = tokenizeSubex tokenRE++dd :: String -> [DateVal]+dd = map _d . dateSearch' . tt++rr :: String -> [String]+rr = map _r . dateSearch' . tt++pp :: String -> [String]+pp = map _p . dateSearch' . tt++-- ------------------------------------------------------------++testDate :: forall a . StringLike a => Test' a+testDate+ = Test' $+ TestLabel "date and time extraction from free text" $+ TestList $+ zipWith parseT toks exx+ where+ parseT res ok+ = TestCase $+ assertEqual (show res ++ " == " ++ show ok) res ok+ + toks :: [(a, a)]+ toks = tokenizeSubex (fromString tokenRE) (fromString ts)++ exx :: [(a, a)]+ exx = map (fromString *** fromString) $+ [("word","Am"),("del"," "),("weekday","Sonntag"),("del",", "),("word","dem"),("del"," ")+ ,("ddMonthyyyy","17. Februar '03"),("del"," "),("word","findet"),("del"," "),("word","um")+ ,("del"," "),("HH","9 Uhr"),("del"," "),("word","ein"),("del"," "),("word","wichtiger")+ ,("del"," "),("word","Termin"),("del"," "),("word","f\252r"),("del"," "),("word","das")+ ,("del"," "),("ssem","Sommersemester 2000"),("del"," "),("word","statt"),("del",". ")+ ,("word","Dieser"),("del"," "),("word","wird"),("del"," "),("word","allerdings")+ ,("del"," "),("word","auf"),("del"," "),("weekday","Montag"),("del"," ")+ ,("word","verschoben"),("del",". "),("word","Und"),("del"," "),("word","zwar")+ ,("del"," "),("word","auf"),("del"," "),("word","den"),("del"," "),("word","ersten")+ ,("del"," "),("weekday","Montag"),("del"," "),("word","im"),("del"," ")+ ,("wsem","Wintersemester 11/12"),("del",", "),("HHMM","12:30"),("del",". ")+ ,("word","Ein"),("del"," "),("word","wichtiger"),("del"," "),("word","Termin")+ ,("del"," "),("word","findet"),("del"," "),("word","im"),("del"," "),("ssem","SoSe 2011")+ ,("del"," "),("word","statt"),("del",". "),("word","Im"),("del"," "),("word","Jahr")+ ,("del"," '"),("word","12"),("del"," "),("word","gibt"),("del"," "),("word","es")+ ,("del"," "),("word","Termine"),("del",", "),("word","aber"),("del"," "),("word","auch")+ ,("del"," "),("word","in"),("del"," "),("wsem","WS 2010/11"),("del",". "),("word","Ein")+ ,("del"," "),("word","weiterer"),("del"," "),("word","Termin"),("del"," "),("word","ist")+ ,("del"," "),("word","am"),("del"," "),("ddmmyyyy","2.4.11"),("del"," "),("word","um")+ ,("del"," "),("HH","12 Uhr"),("del",". "),("word","Oder"),("del"," "),("word","war")+ ,("del"," "),("word","es"),("del"," "),("word","doch"),("del"," "),("weekday","Di.")+ ,("del"," "),("word","der"),("del"," "),("ddmm","3.4."),("del","? "),("word","Egal")+ ,("del",". "),("word","Ein"),("del"," "),("word","weiterer"),("del"," ")+ ,("word","wichtiger"),("del"," "),("word","Termin"),("del"," "),("word","findet")+ ,("del"," "),("word","am"),("del"," "),("yyyymmdd","2001-3-4"),("del"," ")+ ,("word","statt"),("del"," "),("word","bzw"),("del",". "),("word","generell")+ ,("del"," "),("word","zwischen"),("del"," "),("yyyymmdd","01/3/4"),("del"," - ")+ ,("yyyymmdd","01/6/4"),("del"," "),("word","um"),("del"," "),("HH","13 Uhr")+ ,("del",". "),("word","Am"),("del"," "),("word","kommenden"),("del"," ")+ ,("weekday","Mittwoch"),("del"," "),("word","findet"),("del"," ")+ ,("word","Changemanagement"),("del"," "),("word","in"),("del"," "),("word","HS5")+ ,("del"," "),("word","statt"),("del",". "),("word","Dies"),("del"," "),("word","gilt")+ ,("del"," "),("word","dann"),("del"," "),("word","auch"),("del"," "),("word","f\252r")+ ,("del"," "),("word","den"),("del"," "),("ddMonth","7. Juni"),("del"," "),("word","des")+ ,("del"," "),("word","Jahres"),("del"," "),("yyyy","2011"),("del",". "),("word","Noch")+ ,("del"," "),("word","ein"),("del"," "),("word","wichtiger"),("del"," "),("word","Termin")+ ,("del"," "),("word","findet"),("del"," "),("word","um"),("del"," "),("HHMM","16:15 Uhr")+ ,("del"," "),("word","am"),("del"," "),("weekday","Do."),("del",", "),("ddmmyyyy","1.2.03")+ ,("del"," "),("word","statt"),("del",". "),("weekday","Freitag"),("del",", ")+ ,("word","der"),("del"," "),("ddMonth","13. Juli"),("del"," "),("word","ist"),("del"," ")+ ,("word","kein"),("del"," "),("word","Gl\252ckstagund"),("del"," "),("weekday","Freitag")+ ,("del",", "),("word","der"),("del"," "),("ddMonth","13. Juli"),("del"," "),("word","um")+ ,("del"," "),("HHMM","11:55 Uhr"),("del"," "),("word","ist"),("del"," "),("word","es")+ ,("del"," "),("word","zu"),("del"," "),("word","sp\228t"),("del",".")+ ]++ +-- ------------------------------------------------------------++genericTest :: (forall a . StringLike a => Test' a) -> Test+genericTest t+ = TestList $+ [ TestLabel "Test with 'String'" $ unTest' (t :: Test' String)+ , TestLabel "Test with 'Text'" $ unTest' (t :: Test' Text)+ , TestLabel "Test with 'Text.Lazy'" $ unTest' (t :: Test' TextL)+ , TestLabel "Test with 'ByteString'" $ unTest' (t :: Test' BS)+ , TestLabel "Test with 'ByteString.Lazy'" $ unTest' (t :: Test' BL)+ ]++allTests :: Test+allTests+ = TestList+ [ genericTest testDate ]++main :: IO ()+main+ = do+ c <- runTestTT allTests+ putStrLn $ show c+ let errs = errors c+ fails = failures c+ exitWith (codeGet errs fails)++codeGet :: Int -> Int -> ExitCode+codeGet errs fails+ | fails > 0 = ExitFailure 2+ | errs > 0 = ExitFailure 1+ | otherwise = ExitSuccess++-- ------------------------------------------------------------
− test/Main.hs
@@ -1,343 +0,0 @@-module Main-where--import Control.Arrow--import System--import Text.Regex.XMLSchema.String-import Text.Regex.XMLSchema.String.Regex--import Test.HUnit---- --------------------------------------------------------------parseTestsStd :: Test-parseTestsStd- = TestLabel "standard XML parse tests" $- TestList $- map parseTest $ tests- where- parseTest (re, rep)- = TestCase $- assertEqual (show re ++ " must be parsed as " ++ show rep)- rep- (show . parseRegexExt $ re)-- tests = [ ("", "()")- , (".", ".")- , (".*", "(.*)")- , ("(())", "()")- , ("(a*)*", "(a*)")- , ("(a*)+", "(a*)")- , ("(a+)*", "(a*)")- , ("(a+)+", "(a+)")- , ("(a?){2,}", "(a*)")- , ("((a?){2,}){0,}", "(a*)")- , ("((a?){2,}){3,}", "(a*)")- , ("(a{0,}){2,}", "(a*)")- , ("(a{2,}){3,}", "(a{6,})")- , ("[9-0]", "{empty char range}")- , ("[0-9]", "[0-9]")- , ("[0-99-0]", "[0-9]")- , ("[abc]", "[a-c]")- , ("[\0-\1114111]", "\\a")- , ("[\0-\1114111]|[0-9]", "\\a")- , ("[\0-\1114110]", "[�-]" )- , ("[abc-[b]]", "[ac]" )- , ("a|b|c|d", "[a-d]" )- , ("(a|b)|c", "[a-c]" )- , ("a|(b|c)", "[a-c]" )- , ("abc", "(a(bc))" ) -- seq is right ass- , ("({1}a+)", "({1}(a+))" ) -- extension: labeled subexpressions- , ("({1}({2}({3}a)))", "({1}({2}({3}a)))" )- ]--parseTestsExt :: Test-parseTestsExt- = TestLabel "extended parse tests" $- TestList $- map parseTest $ tests- where- parseTest (re, rep)- = TestCase $- assertEqual (show re ++ " must be parsed as " ++ show rep)- rep- (show . parseRegexExt $ re)-- tests = [ ("", "()")- , (".", ".")- , (".*", "(.*)")- , ("\\a", "\\a")- , ("\\A", "\\A")- , ("(())", "()")- , ("(a*)*", "(a*)")- , ("(a*)+", "(a*)")- , ("(a+)*", "(a*)")- , ("(a+)+", "(a+)")- , ("(a?){2,}", "(a*)")- , ("((a?){2,}){0,}", "(a*)")- , ("((a?){2,}){3,}", "(a*)")- , ("(a{0,}){2,}", "(a*)")- , ("(a{2,}){3,}", "(a{6,})")- , ("[9-0]", "{empty char range}")- , ("[0-9]", "[0-9]")- , ("[0-99-0]", "[0-9]")- , ("[abc]", "[a-c]")- , ("[\0-\1114111]", "\\a")- , ("[\0-\1114111]|[0-9]", "\\a")- , ("[\0-\1114110]", "[�-]" )- , ("[abc-[b]]", "[ac]" )- , ("a|b|c|d", "[a-d]" )- , ("(a|b)|c", "[a-c]" )- , ("a|(b|c)", "[a-c]" )- , ("abc", "(a(bc))" ) -- seq is right ass- , ("a*{^}b*", "((a*){^}(b*))" ) -- extension: exor- , ("a*{^}b*{^}c*", "((a*){^}((b*){^}(c*)))")- , ("a*{&}b*", "((a*){&}(b*))" ) -- extension: intersection- , ("a*{&}b*{&}c*", "((a*){&}((b*){&}(c*)))")- , ("a*{\\}b*", "((a*){\\}(b*))" ) -- extension: set difference- , ("a*{\\}b*{\\}c*", "(((a*){\\}(b*)){\\}(c*))" )- , ("(a|b)*{\\}(.*aa.*)", "(([ab]*){\\}((.*)(a(a(.*)))))" )- , ("({1}a+)", "({1}(a+))" ) -- extension: labeled subexpressions- , ("({1}({2}({3}a)))", "({1}({2}({3}a)))" )- , ("({1}do){|}({2}[a-z]+)", "(({1}(do)){|}({2}([a-z]+)))" ) -- deterministic choice of submatches- , ("a{:}b{:}c", "(a{:}(b{:}c))" ) -- interleave- ]--simpleMatchTests :: Test-simpleMatchTests- = TestLabel "simple match tests" $- TestList $- concatMap matchTest $ tests- where- matchTest (re, ok, er)- = map (matchOK re) ok- ++- map (matchErr re) er- matchOK re s = TestCase $ assertBool (show s ++ " must match " ++ show re) (matchExt re s)- matchErr re s = TestCase $ assertBool (show s ++ " must not match " ++ show re) (not (matchExt re s))-- tests = [ ( ""- , [""]- , ["a"]- )- , ( "a"- , ["a"]- , ["", "b", "ab"]- )- , ( "()"- , [""]- , ["a"]- )- , ( "ab"- , ["ab"]- , ["", "b", "abc"]- )- , ( "."- , [".","a","\0","\1114111"]- , ["\n","\r","",".."]- )- , ( "\\a"- , [".","a","\n","\r","\0","\1114111"]- , ["",".."]- )- , ( "\\A"- , ["",".","a","\n","\r","\0","\1114111",".."]- , []- )- , ( "a*"- , ["", "a", "aa"]- , ["b", "ab", "aab"]- )- , ( "a+"- , ["a", "aa", "aaa"]- , ["", "b", "ab"]- )- , ( "a?"- , ["", "a"]- , ["b", "ab"]- )- , ( "a{2}"- , ["aa"]- , ["", "a", "aaa"]- )- , ( "a{2,}"- , ["aa","aaa"]- , ["", "a", "aaab"]- )- , ( "a{2,4}"- , ["aa", "aaa", "aaaa"]- , ["", "a", "aaaaa", "ab"]- )- , ( "a|b"- , ["a", "b"]- , ["", "c", "ab", "abc"]- )- , ( "[0-9]"- , ["0", "5", "9"]- , ["", "a", "00"]- )- , ( "[^0-9]"- , ["a"]- , ["", "0", "9", "00"])- , ( "\32"- , [" "]- , []- )- , ( "[\0-\1114111]"- , ["\0","\1114111","a"]- , ["","aaa"]- )- , ( "[^\0-\1114111]"- , []- , ["","aaa","\0","\1114111","a"]- )- , ( ".*a.*|.*b.*|.*c.*"- , ["a", "abc", "acdc"]- , ["", "dddd"]- )- , ( ".*a.*{&}.*b.*{&}.*c.*"- , ["abc", "abcd", "abcabcd"]- , ["", "a", "bc", "acdc", "dddd"]- )- , ( ".*a.*{&}.*b.*{&}.*c.*{&}.{3}" -- all permutations of "abc"- , ["abc", "acb", "bac", "bca", "cab", "cba"]- , ["", "a", "bc", "acd", "aaaa", "aba"]- )- , ( ".*a.*{&}.*b.*{&}.*c.*" -- all words containing at least 1 a, 1 b and 1 c- , ["abc", "acb", "bac", "bca", "cab", "cba", "abcd", "abcabc"]- , ["", "a", "bc", "acd", "aaaa"]- )- , ( ".*a.*{^}.*b.*" -- all words containing at least 1 a or 1 b but not both a's and b's- , ["a", "b", "ac", "bc", "aaaa", "bbb", "aacc", "ccbb", "acdc"]- , ["", "ab", "abc", "dddd"]- )- , ( "/[*](.*{\\}(.*[*]/.*))[*]/" -- single line C comment of form /*...*/, but without any */ in the comment body- -- this is the way to specify none greedy expessions- -- if multi-line comment are required, substitute .* by \A, so newlines are allowed- , ["/**/","/***/","/*x*/","/*///*/"]- , ["", "/", "/*", "/*/", "/**/*/", "/*xxx*/xxx*/"]- )- , ( "a{:}b{:}c"- , ["abc", "acb", "bac", "bca", "cab", "cba"]- , ["", "a", "ab", "abcc", "abca", "aba"]- )- ]---- --------------------------------------------------------------simpleSplitTests :: Test-simpleSplitTests- = TestLabel "simple split tests" $- TestList $- map splitTest $ tests- where- splitTest (re, inp, tok, rest)- = TestCase $- assertEqual ("split " ++ show re ++ " " ++ show inp ++ " = " ++ show (tok, rest))- (tok, rest)- (split re inp)- tests = [ ("", "a", "", "a" )- , ("a*b", "abc", "ab", "c" )- , ("a*", "bc", "", "bc" )- , ("a+", "bc", "", "bc" )- , ("[", "bc", "", "bc" )- , ("a{2}", "aaa", "aa", "a" )- , ("a{2,}", "aaa", "aaa", "" )- , ("a|b", "ab", "a", "b" )- , ("a|b*", "bbba", "bbb", "a" )- , ("abc", "abcd", "abc", "d" )- ]---- --------------------------------------------------------------simpleTokenTests :: Test-simpleTokenTests- = TestLabel "simple token tests" $- TestList $- map tokenTest $ tests- where- tokenTest (re, inp, toks)- = TestCase $- assertEqual ("tokenize " ++ show re ++ " " ++ show inp ++ " = " ++ show toks)- toks- (tokenize re inp)- tests = [ ("", "", [] )- , ("a", "aba", ["a", "a"] )- , ("a", "b", [] )- , ("a", "ba", ["a"] )- , ("a*", "a", ["a"] )- , ("a*", "ba", ["","a"] )- , ("a*", "aba", ["a", "a"] )- , ("a*", "abba", ["a", "", "a"] )- , ("a+", "abba", ["a", "a"] )- , ("a*b", "abba", ["ab", "b"] )- , (".*", "a\n\nb", ["a", "", "b"] )- , (".*", "a\n\nb\n", ["a", "", "b"] )- , ("\\w+", "a\n\nb\n", ["a", "b"] )- , ("\\w|ab", "aaa\n\nabc\n", ["a", "a", "a", "ab", "c"] )- , ("\\w|ab", "aaa abc", ["a", "a", "a", "ab", "c"] )- ]---- --------------------------------------------------------------allTests :: Test-allTests- = TestList- [ parseTestsStd- , parseTestsExt- , simpleMatchTests- , simpleSplitTests- , simpleTokenTests- ]--main :: IO ()-main- = do- c <- runTestTT allTests- putStrLn $ show c- let errs = errors c- fails = failures c- System.exitWith (codeGet errs fails)--codeGet :: Int -> Int -> ExitCode-codeGet errs fails- | fails > 0 = ExitFailure 2- | errs > 0 = ExitFailure 1- | otherwise = ExitSuccess---- --------------------------------------------------------------deltaTrc :: Regex -> String -> [(String, Regex)]-deltaTrc re "" = [("", re)]-deltaTrc re s@(c:cs) = (s, re)- :- ( if isZero re'- then [("",re')]- else deltaTrc re' cs- )- where- re' = delta1 re c--matchTrc :: String -> String -> (Bool, [(String, Regex)])-matchTrc re = ( parseRegex >>> deltaTrc$ re )- >>>- ( (last >>> snd >>> nullable) &&& id )---trcMatch :: String -> String -> IO()-trcMatch re = putStrLn . showTrc . matchTrc re- where- showTrc =- ( (show >>> (++ "\n"))- ***- (concatMap ( ((++ "\t") *** (show >>> (++"\n")))- >>> uncurry (++)- )- )- )- >>>- uncurry (flip (++))---- ------------------------------------------------------------
− test/Makefile
@@ -1,14 +0,0 @@-prog = ./main--all : $(prog)--$(prog) : Main.hs- ghc --make -Wall -O2 -o $@ $<--test : $(prog)- $(prog)--clean :- rm -f $(prog) *.hi *.o--.PHONY : all test clean
+ test/SimpleTest.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- ------------------------------------------------------------++module Main+where++import Control.Arrow++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import System.Exit (ExitCode (..),+ exitWith)++import Text.Regex.XMLSchema.Generic+import Text.Regex.XMLSchema.Generic.Regex+import Text.Regex.XMLSchema.Generic.StringLike++import Test.HUnit++-- ------------------------------------------------------------++newtype Test' a = Test' {unTest' :: Test}++type BS = B.ByteString+type BL = BL.ByteString+type Text = T.Text+type TextL = TL.Text++-- ------------------------------------------------------------++parseTestsStdLatin1 :: forall s . StringLike s => Test' s+parseTestsStdLatin1 = parseTestsStd' testsLatin1++parseTestsStdUnicode :: forall s . StringLike s => Test' s+parseTestsStdUnicode = parseTestsStd' testsUnicode++parseTestsStd' :: forall s . StringLike s => [(String, String)] -> Test' s+parseTestsStd' tests+ = Test' $+ TestLabel "standard XML parse tests" $+ TestList $+ map parseTest $ tests+ where+ parseTest (re0, rep)+ = TestCase $+ assertEqual (show re ++ " must be parsed as " ++ show rep)+ rep+ (show . parseRegexExt $ re)+ where+ re :: s+ re = fromString re0++testsLatin1 :: [(String, String)]+testsLatin1+ = [ ("", "()")+ , (".", ".")+ , (".*", "(.*)")+ , ("(())", "()")+ , ("(a*)*", "(a*)")+ , ("(a*)+", "(a*)")+ , ("(a+)*", "(a*)")+ , ("(a+)+", "(a+)")+ , ("(a?){2,}", "(a*)")+ , ("((a?){2,}){0,}", "(a*)")+ , ("((a?){2,}){3,}", "(a*)")+ , ("(a{0,}){2,}", "(a*)")+ , ("(a{2,}){3,}", "(a{6,})")+ , ("[9-0]", "{empty char range}")+ , ("[0-9]", "[0-9]")+ , ("[0-99-0]", "[0-9]")+ , ("[abc]", "[a-c]")+ , ("[abc-[b]]", "[ac]" )+ , ("a|b|c|d", "[a-d]" )+ , ("(a|b)|c", "[a-c]" )+ , ("a|(b|c)", "[a-c]" )+ , ("abc", "(a(bc))" ) -- seq is right ass+ , ("({1}a+)", "({1}(a+))" ) -- extension: labeled subexpressions+ , ("({1}({2}({3}a)))", "({1}({2}({3}a)))" )+ ]++testsUnicode :: [(String, String)]+testsUnicode+ = [ ("[\0-\1114111]", "\\a")+ , ("[\0-\1114111]|[0-9]", "\\a")+ , ("[\0-\1114110]", "[�-]" )+ ]++parseTestsExtLatin1 :: forall s . StringLike s => Test' s+parseTestsExtLatin1 = parseTestsExt' testsExtLatin1++parseTestsExtUnicode :: forall s . StringLike s => Test' s+parseTestsExtUnicode = parseTestsExt' testsExtUnicode++parseTestsExt' :: forall s . StringLike s => [(String, String)] -> Test' s+parseTestsExt' tests+ = Test' $+ TestLabel "extended parse tests" $+ TestList $+ map parseTest $ tests+ where+ parseTest (re0, rep)+ = TestCase $+ assertEqual (show re ++ " must be parsed as " ++ show rep)+ rep+ (show . parseRegexExt $ re)+ where+ re :: s+ re = fromString re0++testsExtLatin1 :: [(String, String)]+testsExtLatin1+ = [ ("", "()")+ , (".", ".")+ , (".*", "(.*)")+ , ("\\a", "\\a")+ , ("\\A", "\\A")+ , ("(())", "()")+ , ("(a*)*", "(a*)")+ , ("(a*)+", "(a*)")+ , ("(a+)*", "(a*)")+ , ("(a+)+", "(a+)")+ , ("(a?){2,}", "(a*)")+ , ("((a?){2,}){0,}", "(a*)")+ , ("((a?){2,}){3,}", "(a*)")+ , ("(a{0,}){2,}", "(a*)")+ , ("(a{2,}){3,}", "(a{6,})")+ , ("[9-0]", "{empty char range}")+ , ("[0-9]", "[0-9]")+ , ("[0-99-0]", "[0-9]")+ , ("[abc]", "[a-c]")+ , ("[abc-[b]]", "[ac]" )+ , ("a|b|c|d", "[a-d]" )+ , ("(a|b)|c", "[a-c]" )+ , ("a|(b|c)", "[a-c]" )+ , ("abc", "(a(bc))" ) -- seq is right ass+ , ("a*{^}b*", "((a*){^}(b*))" ) -- extension: exor+ , ("a*{^}b*{^}c*", "((a*){^}((b*){^}(c*)))")+ , ("a*{&}b*", "((a*){&}(b*))" ) -- extension: intersection+ , ("a*{&}b*{&}c*", "((a*){&}((b*){&}(c*)))")+ , ("a*{\\}b*", "((a*){\\}(b*))" ) -- extension: set difference+ , ("a*{\\}b*{\\}c*", "(((a*){\\}(b*)){\\}(c*))" )+ , ("(a|b)*{\\}(.*aa.*)", "(([ab]*){\\}((.*)(a(a(.*)))))" )+ , ("({1}a+)", "({1}(a+))" ) -- extension: labeled subexpressions+ , ("({1}({2}({3}a)))", "({1}({2}({3}a)))" )+ , ("({1}do){|}({2}[a-z]+)", "(({1}(do)){|}({2}([a-z]+)))" ) -- deterministic choice of submatches+ , ("a{:}b{:}c", "(a{:}(b{:}c))" ) -- interleave+ ]++testsExtUnicode :: [(String, String)]+testsExtUnicode+ = [ ("[\0-\1114111]", "\\a")+ , ("[\0-\1114111]|[0-9]", "\\a")+ , ("[\0-\1114110]", "[�-]" )+ , ("[abc-[b]]", "[ac]" )+ , ("a|b|c|d", "[a-d]" )+ , ("(a|b)|c", "[a-c]" )+ , ("a|(b|c)", "[a-c]" )+ , ("abc", "(a(bc))" ) -- seq is right ass+ , ("a*{^}b*", "((a*){^}(b*))" ) -- extension: exor+ , ("a*{^}b*{^}c*", "((a*){^}((b*){^}(c*)))")+ , ("a*{&}b*", "((a*){&}(b*))" ) -- extension: intersection+ , ("a*{&}b*{&}c*", "((a*){&}((b*){&}(c*)))")+ , ("a*{\\}b*", "((a*){\\}(b*))" ) -- extension: set difference+ , ("a*{\\}b*{\\}c*", "(((a*){\\}(b*)){\\}(c*))" )+ , ("(a|b)*{\\}(.*aa.*)", "(([ab]*){\\}((.*)(a(a(.*)))))" )+ , ("({1}a+)", "({1}(a+))" ) -- extension: labeled subexpressions+ , ("({1}({2}({3}a)))", "({1}({2}({3}a)))" )+ , ("({1}do){|}({2}[a-z]+)", "(({1}(do)){|}({2}([a-z]+)))" ) -- deterministic choice of submatches+ , ("a{:}b{:}c", "(a{:}(b{:}c))" ) -- interleave+ ]++simpleMatchTests :: forall a . StringLike a => Test' a+simpleMatchTests+ = Test' $+ TestLabel "simple match tests" $+ TestList $+ concatMap matchTest $ testsMatch+ where+ matchTest :: (String, [String], [String]) -> [Test]+ matchTest (re0, ok, er)+ = map (matchOK re . fromString) ok+ +++ map (matchErr re . fromString) er+ where+ re :: a+ re = fromString re0++ matchOK :: a -> a -> Test+ matchOK re xs+ = TestCase $ assertBool (show xs ++ " must match " ++ show re) (matchExt re xs)+ matchErr re xs+ = TestCase $ assertBool (show xs ++ " must not match " ++ show re) (not (matchExt re xs))++testsMatch :: [(String, [String], [String])]+testsMatch+ = [ ( ""+ , [""]+ , ["a"]+ )+ , ( "a"+ , ["a"]+ , ["", "b", "ab"]+ )+ , ( "()"+ , [""]+ , ["a"]+ )+ , ( "ab"+ , ["ab"]+ , ["", "b", "abc"]+ )+ , ( "."+ , [".","a","\0","\1114111"]+ , ["\n","\r","",".."]+ )+ , ( "\\a"+ , [".","a","\n","\r","\0","\1114111"]+ , ["",".."]+ )+ , ( "\\A"+ , ["",".","a","\n","\r","\0","\1114111",".."]+ , []+ )+ , ( "a*"+ , ["", "a", "aa"]+ , ["b", "ab", "aab"]+ )+ , ( "a+"+ , ["a", "aa", "aaa"]+ , ["", "b", "ab"]+ )+ , ( "a?"+ , ["", "a"]+ , ["b", "ab"]+ )+ , ( "a{2}"+ , ["aa"]+ , ["", "a", "aaa"]+ )+ , ( "a{2,}"+ , ["aa","aaa"]+ , ["", "a", "aaab"]+ )+ , ( "a{2,4}"+ , ["aa", "aaa", "aaaa"]+ , ["", "a", "aaaaa", "ab"]+ )+ , ( "a|b"+ , ["a", "b"]+ , ["", "c", "ab", "abc"]+ )+ , ( "[0-9]"+ , ["0", "5", "9"]+ , ["", "a", "00"]+ )+ , ( "[^0-9]"+ , ["a"]+ , ["", "0", "9", "00"])+ , ( "\32"+ , [" "]+ , []+ )+ , ( "[\0-\1114111]"+ , ["\0","\1114111","a"]+ , ["","aaa"]+ )+ , ( "[^\0-\1114111]"+ , []+ , ["","aaa","\0","\1114111","a"]+ )+ , ( ".*a.*|.*b.*|.*c.*"+ , ["a", "abc", "acdc"]+ , ["", "dddd"]+ )+ , ( ".*a.*{&}.*b.*{&}.*c.*"+ , ["abc", "abcd", "abcabcd"]+ , ["", "a", "bc", "acdc", "dddd"]+ )+ , ( ".*a.*{&}.*b.*{&}.*c.*{&}.{3}" -- all permutations of "abc"+ , ["abc", "acb", "bac", "bca", "cab", "cba"]+ , ["", "a", "bc", "acd", "aaaa", "aba"]+ )+ , ( ".*a.*{&}.*b.*{&}.*c.*" -- all words containing at least 1 a, 1 b and 1 c+ , ["abc", "acb", "bac", "bca", "cab", "cba", "abcd", "abcabc"]+ , ["", "a", "bc", "acd", "aaaa"]+ )+ , ( ".*a.*{^}.*b.*" -- all words containing at least 1 a or 1 b but not both a's and b's+ , ["a", "b", "ac", "bc", "aaaa", "bbb", "aacc", "ccbb", "acdc"]+ , ["", "ab", "abc", "dddd"]+ )+ , ( "/[*](.*{\\}(.*[*]/.*))[*]/" -- single line C comment of form /*...*/, but without any */ in the comment body+ -- this is the way to specify none greedy expessions+ -- if multi-line comment are required, substitute .* by \A, so newlines are allowed+ , ["/**/","/***/","/*x*/","/*///*/"]+ , ["", "/", "/*", "/*/", "/**/*/", "/*xxx*/xxx*/"]+ )+ , ( "a{:}b{:}c"+ , ["abc", "acb", "bac", "bca", "cab", "cba"]+ , ["", "a", "ab", "abcc", "abca", "aba"]+ )+ ]++-- ------------------------------------------------------------++simpleSplitTests :: forall a . StringLike a => Test' a+simpleSplitTests+ = Test' $+ TestLabel "simple split tests" $+ TestList $+ map splitTest $ testsSplit+ where+ splitTest (re0, inp0, tok0, rest0)+ = TestCase $+ assertEqual+ ("split " ++ show re ++ " " ++ show inp0 ++ " = " ++ show (tok, rest))+ (tok, rest)+ (split re (fromString inp0))+ where+ re, tok, rest :: a+ re = fromString re0+ tok = fromString tok0+ rest = fromString rest0++testsSplit :: [(String, String, String, String)]+testsSplit+ = [ ("", "a", "", "a" )+ , ("a*b", "abc", "ab", "c" )+ , ("a*", "bc", "", "bc" )+ , ("a+", "bc", "", "bc" )+ , ("[", "bc", "", "bc" )+ , ("a{2}", "aaa", "aa", "a" )+ , ("a{2,}", "aaa", "aaa", "" )+ , ("a|b", "ab", "a", "b" )+ , ("a|b*", "bbba", "bbb", "a" )+ , ("abc", "abcd", "abc", "d" )+ ]++-- ------------------------------------------------------------++simpleTokenTests :: forall a . StringLike a => Test' a+simpleTokenTests+ = Test' $+ TestLabel "simple token tests" $+ TestList $+ map tokenTest $ testsToken+ where+ tokenTest (re0, inp0, toks0)+ = TestCase $+ assertEqual+ ("tokenize " ++ show re ++ " " ++ show inp ++ " = " ++ show toks)+ toks+ (tokenize re inp)+ where+ re, inp :: a+ re = fromString re0+ inp = fromString inp0+ toks :: [a]+ toks = map fromString toks0++testsToken :: [(String, String, [String])]+testsToken+ = [ ("", "", [] )+ , ("a", "aba", ["a", "a"] )+ , ("a", "b", [] )+ , ("a", "ba", ["a"] )+ , ("a*", "a", ["a"] )+ , ("a*", "ba", ["","a"] )+ , ("a*", "aba", ["a", "a"] )+ , ("a*", "abba", ["a", "", "a"] )+ , ("a+", "abba", ["a", "a"] )+ , ("a*b", "abba", ["ab", "b"] )+ , (".*", "a\n\nb", ["a", "", "b"] )+ , (".*", "a\n\nb\n", ["a", "", "b"] )+ , ("\\w+", "a\n\nb\n", ["a", "b"] )+ , ("\\w|ab", "aaa\n\nabc\n", ["a", "a", "a", "ab", "c"] )+ , ("\\w|ab", "aaa abc", ["a", "a", "a", "ab", "c"] )+ ]++-- ------------------------------------------------------------++genericTest :: (forall a . StringLike a => Test' a) -> Test+genericTest t+ = TestList $+ [ TestLabel "Test with 'String'" $ unTest' (t :: Test' String)+ , TestLabel "Test with 'Text'" $ unTest' (t :: Test' Text)+ , TestLabel "Test with 'Text.Lazy'" $ unTest' (t :: Test' TextL)+ , TestLabel "Test with 'ByteString'" $ unTest' (t :: Test' BS)+ , TestLabel "Test with 'ByteString.Lazy'" $ unTest' (t :: Test' BL)+ ]++unicodeTest :: (forall a . StringLike a => Test' a) -> Test+unicodeTest t+ = TestList $+ [ TestLabel "Test with 'String'" $ unTest' (t :: Test' String)+ , TestLabel "Test with 'Text'" $ unTest' (t :: Test' Text)+ , TestLabel "Test with 'Text.Lazy'" $ unTest' (t :: Test' TextL)+ ]++allTests :: Test+allTests+ = TestList+ [ genericTest parseTestsStdLatin1+ , unicodeTest parseTestsStdUnicode+ , genericTest parseTestsExtLatin1+ , unicodeTest parseTestsExtUnicode+ , genericTest simpleMatchTests+ , genericTest simpleSplitTests+ , genericTest simpleTokenTests+ ]++main :: IO ()+main+ = do+ c <- runTestTT allTests+ putStrLn $ show c+ let errs = errors c+ fails = failures c+ exitWith (codeGet errs fails)++codeGet :: Int -> Int -> ExitCode+codeGet errs fails+ | fails > 0 = ExitFailure 2+ | errs > 0 = ExitFailure 1+ | otherwise = ExitSuccess++-- ------------------------------------------------------------++deltaTrc :: StringLike s => s -> GenRegex s -> [(s, GenRegex s)]+deltaTrc s@(uncons -> Just (c, cs)) re+ = (s, re)+ :+ ( if isZero re'+ then [(emptyS,re')]+ else deltaTrc cs re'+ )+ where+ re' = delta1 c s re+deltaTrc _ re = [(emptyS, re)]++matchTrc :: StringLike s => s -> s -> (Bool, [(s, GenRegex s)])+matchTrc re s = (nullable . snd . last $ res, res)+ where+ res = deltaTrc s (parseRegex re)+++trcMatch :: StringLike s => s -> s -> IO()+trcMatch re = putStrLn . showTrc . matchTrc re+ where+ showTrc =+ ( (show >>> (++ "\n"))+ ***+ (concatMap ( ( (toString >>> (++ "\t"))+ ***+ (show >>> (++"\n"))+ )+ >>> uncurry (++)+ )+ )+ )+ >>>+ uncurry (flip (++))++-- ------------------------------------------------------------