summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-02-20 22:28:55 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-02-20 22:28:55 +0100
commitb27bbb421aa9806d1f3d6a524968a2f2df092b8e (patch)
tree48071f31a2d85c36cafa6a745e99e1eb272e41c4
parent82e4bdcaaefa88913a0dacf3496747251909219f (diff)
Range enumeration syntax for lists
-rw-r--r--src/Parser.hs31
-rw-r--r--src/Test.hs11
2 files changed, 38 insertions, 4 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 9ba702b..0bc5995 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -75,7 +75,7 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar)
wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc
operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)
-operatorChar = satisfy $ (`elem` ['+', '-', '*', '/', '='])
+operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])
{-# INLINE operatorChar #-}
localState :: TestParser a -> TestParser a
@@ -212,13 +212,36 @@ list :: TestParser SomeExpr
list = label "list" $ do
symbol "["
SomeExpr x <- someExpr
+
+ let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "list range enumeration not defined for '" <> textExprType x <> "'"
choice
[do symbol "]"
return $ SomeExpr $ UnOp (:[]) x
- ,do symbol ","
- xs <- listOf typedExpr
+
+ ,do off <- stateOffset <$> getParserState
+ osymbol ".."
+ ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x
+ y <- typedExpr
symbol "]"
- return $ SomeExpr $ foldr (BinOp (:)) (Literal []) (x:xs)
+ return $ SomeExpr $ UnOp fromTo x `App` y
+
+ ,do symbol ","
+ y <- typedExpr
+
+ choice
+ [do off <- stateOffset <$> getParserState
+ osymbol ".."
+ ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x
+ z <- typedExpr
+ symbol "]"
+ return $ SomeExpr $ UnOp fromThenTo x `App` y `App` z
+
+ ,do symbol ","
+ xs <- listOf typedExpr
+ symbol "]"
+ return $ SomeExpr $ foldr (BinOp (:)) (Literal []) (x:y:xs)
+ ]
]
data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
diff --git a/src/Test.hs b/src/Test.hs
index 6460daf..2acd7eb 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -9,6 +9,7 @@ module Test (
SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
RecordSelector(..),
ExprListUnpacker(..),
+ ExprEnumerator(..),
Expr(..), eval, gatherVars,
Regex(RegexPart, RegexString), regexMatch,
@@ -75,11 +76,16 @@ class Typeable a => ExprType a where
exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a)
exprListUnpacker _ = Nothing
+ exprEnumerator :: proxy a -> Maybe (ExprEnumerator a)
+ exprEnumerator _ = Nothing
+
instance ExprType Integer where
textExprType _ = T.pack "integer"
textExprValue x = T.pack (show x)
emptyVarValue = 0
+ exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo
+
instance ExprType Scientific where
textExprType _ = T.pack "number"
textExprValue x = T.pack (show x)
@@ -121,10 +127,13 @@ textSomeVarValue (SomeVarValue value) = textExprValue value
data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
+data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
+
data Expr a where
Variable :: ExprType a => VarName -> Expr a
Literal :: ExprType a => a -> Expr a
+ App :: Expr (a -> b) -> Expr a -> Expr b
Concat :: [Expr Text] -> Expr Text
Regex :: [Expr Regex] -> Expr Regex
UnOp :: (b -> a) -> Expr b -> Expr a
@@ -134,6 +143,7 @@ data Expr a where
eval :: MonadEval m => Expr a -> m a
eval (Variable name) = fromSomeVarValue name =<< lookupVar name
eval (Literal value) = return value
+eval (App f x) = eval f <*> eval x
eval (Concat xs) = T.concat <$> mapM eval xs
eval (Regex xs) = mapM eval xs >>= \case
[re@RegexCompiled {}] -> return re
@@ -150,6 +160,7 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
helper :: forall b. Expr b -> m [(VarName, SomeVarValue)]
helper (Variable var) = (:[]) . (var,) <$> lookupVar var
helper (Literal _) = return []
+ helper (App f x) = (++) <$> helper f <*> helper x
helper (Concat es) = concat <$> mapM helper es
helper (Regex es) = concat <$> mapM helper es
helper (UnOp _ e) = helper e