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
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