summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-07 13:41:11 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-07 18:27:33 +0200
commit409e9dc95aa9f17770f21d11a65ec839da699f16 (patch)
tree47799d2cca2d5a9fc4d9325ab4ffc6f3aaa47cee /src/Parser.hs
parentbc688a7abf7f0d04429885084ed14bdf32b2d087 (diff)
Regex expansion
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs26
1 files changed, 15 insertions, 11 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 35f28c5..22928c3 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -132,17 +132,14 @@ someExpansion = do
, between (char '{') (char '}') someExpr
]
-stringExpansion :: Text -> TestParser (Expr Text)
-stringExpansion tname = do
+stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
+stringExpansion tname conv = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
[ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
- maybe err return $ listToMaybe $ catMaybes
- [ cast e
- , UnOp (T.pack . show @Integer) <$> cast e
- ]
+ maybe err return $ listToMaybe $ catMaybes $ conv e
integerLiteral :: TestParser (Expr Integer)
integerLiteral = Literal . read . TL.unpack <$> takeWhile1P (Just "integer") isDigit
@@ -163,7 +160,10 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Literal (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string")
+ ,do e <- stringExpansion (T.pack "string") $ \e ->
+ [ cast e
+ , UnOp (T.pack . show @Integer) <$> cast e
+ ]
(e:) <$> inner
]
Concat <$> inner
@@ -173,14 +173,18 @@ regex = label "regular expression" $ lexeme $ do
void $ char '/'
let inner = choice
[ char '/' >> return []
- , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (Literal (TL.toStrict s) :) <$> inner
+ , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (Literal (RegexPart (TL.toStrict s)) :) <$> inner
,do void $ char '\\'
s <- choice
- [ char '/' >> return (Literal $ T.singleton '/')
- , anySingle >>= \c -> return (Literal $ T.pack ['\\', c])
+ [ char '/' >> return (Literal $ RegexPart $ T.singleton '/')
+ , anySingle >>= \c -> return (Literal $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex")
+ ,do e <- stringExpansion (T.pack "regex") $ \e ->
+ [ cast e
+ , UnOp RegexString <$> cast e
+ , UnOp (RegexString . T.pack . show @Integer) <$> cast e
+ ]
(e:) <$> inner
]
expr <- Regex <$> inner