diff options
| -rw-r--r-- | src/Parser.hs | 31 | ||||
| -rw-r--r-- | src/Test.hs | 11 |
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 |