summaryrefslogtreecommitdiff
path: root/src/Test.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Test.hs')
-rw-r--r--src/Test.hs48
1 files changed, 31 insertions, 17 deletions
diff --git a/src/Test.hs b/src/Test.hs
index 9175589..cfc144b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -9,10 +9,9 @@ module Test (
SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
RecordSelector(..),
Expr(..), eval, gatherVars,
- Regex,
-) where
-import Control.Monad
+ Regex(RegexPart, RegexString), regexMatch,
+) where
import Data.Char
import Data.List
@@ -20,8 +19,8 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
-import Text.Regex.TDFA
-import Text.Regex.TDFA.Text
+import Text.Regex.TDFA qualified as RE
+import Text.Regex.TDFA.Text qualified as RE
import {-# SOURCE #-} Network
import {-# SOURCE #-} Process
@@ -86,7 +85,7 @@ instance ExprType Text where
instance ExprType Regex where
textExprType _ = T.pack "regex"
textExprValue _ = T.pack "<regex>"
- emptyVarValue = either error id $ compile defaultCompOpt defaultExecOpt T.empty
+ emptyVarValue = either error id $ regexCompile T.empty
data SomeVarValue = forall a. ExprType a => SomeVarValue a
@@ -104,7 +103,7 @@ data Expr a where
Variable :: ExprType a => VarName -> Expr a
Literal :: ExprType a => a -> Expr a
Concat :: [Expr Text] -> Expr Text
- Regex :: [Expr Text] -> Expr Regex
+ Regex :: [Expr Regex] -> Expr Regex
UnOp :: (b -> a) -> Expr b -> Expr a
BinOp :: (b -> c -> a) -> Expr b -> Expr c -> Expr a
@@ -112,16 +111,9 @@ eval :: MonadEval m => Expr a -> m a
eval (Variable name) = fromSomeVarValue name =<< lookupVar name
eval (Literal value) = return value
eval (Concat xs) = T.concat <$> mapM eval xs
-eval (Regex xs) = do
- parts <- forM xs $ \case
- Literal value | Just str <- cast value -> return str
- | otherwise -> fail $ "regex expansion not defined for " ++ T.unpack (textExprType $ Just value)
- expr -> T.concatMap escapeChar <$> eval expr
- where
- escapeChar c | isAlphaNum c = T.singleton c
- | c `elem` "`'<>" = T.singleton c
- | otherwise = T.pack ['\\', c]
- case compile defaultCompOpt defaultExecOpt $ T.concat $ concat [[T.singleton '^'], parts, [T.singleton '$']] of
+eval (Regex xs) = mapM eval xs >>= \case
+ [re@RegexCompiled {}] -> return re
+ parts -> case regexCompile $ T.concat $ map regexSource parts of
Left err -> fail err
Right re -> return re
eval (UnOp f x) = f <$> eval x
@@ -137,3 +129,25 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
helper (Regex es) = concat <$> mapM helper es
helper (UnOp _ e) = helper e
helper (BinOp _ e f) = (++) <$> helper e <*> helper f
+
+
+data Regex = RegexCompiled Text RE.Regex
+ | RegexPart Text
+ | RegexString Text
+
+regexCompile :: Text -> Either String Regex
+regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $
+ T.singleton '^' <> src <> T.singleton '$'
+
+regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text]))
+regexMatch (RegexCompiled _ re) text = RE.regexec re text
+regexMatch _ _ = Left "regex not compiled"
+
+regexSource :: Regex -> Text
+regexSource (RegexCompiled src _) = src
+regexSource (RegexPart src) = src
+regexSource (RegexString str) = T.concatMap escapeChar str
+ where
+ escapeChar c | isAlphaNum c = T.singleton c
+ | c `elem` "`'<>" = T.singleton c
+ | otherwise = T.pack ['\\', c]