diff --git a/Hidden/ParseRegexStr.hs b/Hidden/ParseRegexStr.hs --- a/Hidden/ParseRegexStr.hs +++ b/Hidden/ParseRegexStr.hs @@ -8,65 +8,61 @@ , parseRegexStr ) where -import Hidden.RegexPRTypes ( RegexSrcParser, RegexAction(..), - reverseRegexAction, - getBR, modifyBR, - isModeI, isModeM, isModeX, setMode, - runRegexSrcParser ) -import Hidden.ParseLib( runParse, spot, token, mplus, mzero, tokens, - list, greedyList, optional, endOfInput ) -import Control.Monad.State( liftM ) -import Hidden.Tools ( isSymbol, (|||), isBit7On ) -import Data.Char ( isAlphaNum, isAlpha, isDigit, isSpace, - toUpper, toLower ) -import Hidden.SrcRegActList - ( plusesList, oneCharList, backSlashesList, parensesList, charClassList ) +import Hidden.RegexPRTypes ( RegexSrcParser, runRegexSrcParser, + RegexAction(..), reverseRegexAction, + getBR, modifyBR, + setMode, isModeI, isModeM, isModeX ) +import Hidden.ParseLib ( runParse, spot, token, mplus, mzero, token, tokens, + list, greedyList, optional, endOfInput ) +import Control.Monad.State ( liftM ) +import Hidden.Tools ( isSymbol, (|||), isBit7On, bifurcate, cat2funcL, + modifySnd, skipRet, (>..>) ) +import Data.Char ( isAlphaNum, isAlpha, isDigit, isSpace, + toUpper, toLower ) +import Data.Ix ( inRange ) +import Hidden.SrcRegActList( plusesList, oneCharList, backSlashesList, + parensesList, charClassList ) parseRegexStr :: String -> [RegexAction] -parseRegexStr - = fst . fst . head . (runParse $ runRegexSrcParser parseRegexStrParser) . - (,) [] +parseRegexStr = + fst . fst . head . (runParse $ runRegexSrcParser parseRegexStrParser) . (,) [] parseRegexStrParser, parseTokensOr, parseTokens :: RegexSrcParser [RegexAction] parseRegexStrParser = parseTokensOr >>= endOfInput parseTokensOr = parseTokens `mplus` - do { ra1 <- parseTokens; - token '|'; - ra2 <- parseTokensOr; + do { ra1 <- parseTokens; token '|'; ra2 <- parseTokensOr; return $ [ RegexOr ra1 ra2 ] } parseTokens = greedyList parseTokenPlus -parseTokenPlus, parseToken, parseAlpha :: RegexSrcParser RegexAction +parseTokenPlus, parseToken, parseAlphaNum :: RegexSrcParser RegexAction parseTokenPlus = do ra <- parseToken plus <- parsePluses plusesList `mplus` parseQuantifier return $ plus ra - parseQuantifier :: RegexSrcParser (RegexAction -> RegexAction) parseQuantifier = do { token '{'; - m <- list $ spot isDigit; + min <- list $ spot isDigit; max <- do { cma <- optional $ token ','; case cma of "" -> return Nothing - _ -> list (spot isDigit) >>= return . Just; }; + _ -> list (spot isDigit) >>= return . Just }; token '}'; nd <- optional (token '?') >>= return . null; - return $ (if nd then Repeat else RepeatNotGreedy) (read m) $ + return $ (if nd then Repeat else RepeatNotGreedy) (read min) $ case max of - Nothing -> Just $ read m + Nothing -> Just $ read min Just "" -> Nothing Just n -> Just $ read n } parseToken - = do parseAlpha - `mplus` - do { c <- spot isDigit; return $ Select (==c) } + = parseAlphaNum `mplus` - do { token '\\'; c <- spot isSymbol; return $ Select (==c) } + ( token '\\' >> spot isSymbol >>= return . Select . (==) ) `mplus` - do { token '\\'; optional $ token '{'; d1 <- spot isDigit; - d2 <- greedyList $ spot isDigit; optional $ token '}'; + do { token '\\'; optional (token '{'); + d1 <- spot isDigit; d2 <- greedyList (spot isDigit); + optional (token '}'); return $ BackReference $ read $ d1:d2 } `mplus` do { token '['; isNotNot <- optional (token '^') >>= return . null; @@ -79,13 +75,10 @@ do { tokens "(?"; list parseMode >>= mapM_ (uncurry setMode); token ')'; return NopRegex } `mplus` - do { tokens "(?"; - modes <- list parseMode; - mapM_ (uncurry setMode) modes; - token ':'; + do { tokens "(?"; modes <- list parseMode; token ':'; + flip mapM_ modes $ uncurry setMode; ras <- parseTokensOr; - mapM_ (\(m,b) -> setMode m $ not b) modes; - token ')'; + flip mapM_ modes $ uncurry setMode . modifySnd not; token ')'; return $ Parens ras } `mplus` do { m <- isModeM; @@ -103,21 +96,21 @@ `mplus` do { tokens "(?#"; c <- list $ spot (/=')'); token ')'; return $ Comment c } -parseAlpha - = do i <- isModeI - if i then do { c <- spot isAlpha; return $ Select $ flip elem - $ [toUpper c, toLower c] } - else do { c <- spot isAlpha; return $ Select (==c) } +parseAlphaNum = do + { i <- isModeI; + spot isAlpha >>= return . Select . + if i then flip elem . bifurcate (cat2funcL toUpper toLower) + else (==) } + `mplus` ( spot isDigit >>= return . Select . (==) ) parseMode :: RegexSrcParser (Char, Bool) parseMode = do b <- optional (token '-') >>= return . null spot (flip elem "imx") >>= return . flip (,) b parseTokenX :: RegexSrcParser RegexAction -parseTokenX = do { spot isSpace; return NopRegex } - `mplus` - do { token '#'; c <- list $ spot (/='\n'); token '\n'; - return $ Comment c } +parseTokenX = ( spot isSpace >> return NopRegex ) `mplus` + ( token '#' >> list (spot (/='\n')) >>= skipRet (token '\n') >>= + return . Comment ) parsePluses :: [ (String, RegexAction -> RegexAction) ] -> @@ -135,19 +128,17 @@ parseParenses :: [ (String, [RegexAction] -> RegexAction) ] -> RegexSrcParser RegexAction parseParenses - = foldr mplus mzero . map (\(t, act) -> do tokens ('(':t) - ras <- parseTokensOr - token ')' - return $ act ras) + = foldr mplus mzero . map ( \(t, act) -> + tokens ('(':t) >> parseTokensOr >>= skipRet (token ')') >>= return . act ) parseCharList :: RegexSrcParser (Char -> Bool) parseCharList = do - cl <- greedyList (parseChar `mplus` parseCharArea `mplus` parseCharClass) - return $ \c -> or $ zipWith ($) cl (repeat c) + cl <- greedyList (parseChar `mplus` parseCharArea `mplus` parseCharClass); + return $ or . zipWith ($) cl . repeat where parseChar = (spot isAlphaNum `mplus` (token '\\' >> spot isSymbol)) - >>= return . (==) - parseCharArea = do { b <- spot isAlphaNum; token '-'; e <- spot isAlphaNum; - return $ flip elem [b..e] } + >>= return . (==) + parseCharArea = (spot isAlphaNum >>= skipRet (token '-')) >..> + spot isAlphaNum >>= return . inRange parseCharClass = foldr mplus mzero $ - map (\(s, p) -> tokens ("[:"++s++":]") >> return p) charClassList - -- tokens "[:alnum:]" >> return isAlphaNum + map (\(s, p) -> tokens ("[:"++s++":]") >> return p) + charClassList diff --git a/Hidden/Tools.hs b/Hidden/Tools.hs --- a/Hidden/Tools.hs +++ b/Hidden/Tools.hs @@ -17,6 +17,10 @@ , (|||) , (&&&) , isBit7On +, bifurcate +, cat2funcL +, skipRet +, (>..>) ) where import Control.Monad.State( StateT(StateT, runStateT), lift, MonadTrans ) @@ -55,3 +59,15 @@ isBit7On :: Char -> Bool isBit7On c = ord c .&. (shiftL 1 7) /= 0 + +bifurcate :: (a -> a -> b) -> a -> b +bifurcate f x = f x x + +cat2funcL :: (a -> c) -> (b -> c) -> a -> b -> [c] +cat2funcL f g x y = [f x, g y ] + +skipRet :: Monad m => m b -> a -> m a +skipRet p x = p >> return x + +(>..>) :: Monad m => m a -> m b -> m (a, b) +m1 >..> m2 = do { x <- m1; y <- m2; return (x, y) } diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -3,6 +3,15 @@ import System.Exit(ExitCode(ExitSuccess)) import qualified Hidden.TestMain(main) +class Ret a where + ret :: a + +instance Ret () where + ret = () + +instance Ret ExitCode where + ret = ExitSuccess + main = defaultMainWithHooks defaultUserHooks { runTests = \_ _ _ _ -> Hidden.TestMain.main >> - return ExitSuccess } + return ret } diff --git a/regexpr.cabal b/regexpr.cabal --- a/regexpr.cabal +++ b/regexpr.cabal @@ -1,5 +1,5 @@ Name: regexpr -Version: 0.2.0 +Version: 0.2.1 License: GPL License-File: LICENSE Author: Yoshikuni Jujo