diff options
| -rw-r--r-- | src/Parser.hs | 32 | ||||
| -rw-r--r-- | src/Test.hs | 6 |
2 files changed, 22 insertions, 16 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index 34bed52..77a2877 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -177,21 +177,6 @@ regex = label "regular expression" $ lexeme $ do _ <- eval expr -- test regex parsing with empty variables return expr -stringExpr :: TestParser (Expr Text) -stringExpr = label "string expression" $ do - SomeExpr e <- someExpr - maybe mzero return $ cast e - -boolExpr :: TestParser (Expr Bool) -boolExpr = do - x <- stringExpr - op <- choice - [ symbol "==" >> return (==) - , symbol "/=" >> return (/=) - ] - y <- stringExpr - return $ BinOp op x y - data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) data SomeUnOp = forall a b. (ExprType a, ExprType b) => SomeUnOp (a -> b) @@ -230,6 +215,13 @@ someExpr = join inner <?> "expression" , [ binary "+" $ [ SomeBinOp ((+) @Integer) ] , binary "-" $ [ SomeBinOp ((-) @Integer) ] ] + , [ binary "==" $ [ SomeBinOp ((==) @Integer) + , SomeBinOp ((==) @Text) + ] + , binary "/=" $ [ SomeBinOp ((/=) @Integer) + , SomeBinOp ((/=) @Text) + ] + ] ] prefix :: String -> [SomeUnOp] -> Operator TestParser (TestParser SomeExpr) @@ -263,6 +255,14 @@ someExpr = join inner <?> "expression" SomeVarValue (_ :: a) <- lookupVar name return $ return $ SomeExpr $ Variable @a name +typedExpr :: forall a. ExprType a => TestParser (Expr a) +typedExpr = do + off <- stateOffset <$> getParserState + SomeExpr e <- someExpr + let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ] + maybe err return $ cast e + class GInit f where ginit :: f x instance GInit U1 where ginit = U1 @@ -390,7 +390,7 @@ makeLenses ''GuardBuilder testGuard :: TestParser [TestStep] testGuard = command "guard" - [ Param "" guardBuilderExpr boolExpr + [ Param "" guardBuilderExpr typedExpr ] $ \s b -> Guard s <$> (maybe (fail "missing guard expression") return $ b ^. guardBuilderExpr) diff --git a/src/Test.hs b/src/Test.hs index 7b9be6f..7d932af 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -81,6 +81,12 @@ instance ExprType Text where textExprValue x = T.pack (show x) emptyVarValue = T.empty +instance ExprType Bool where + textExprType _ = T.pack "bool" + textExprValue True = T.pack "true" + textExprValue False = T.pack "false" + emptyVarValue = False + data SomeVarValue = forall a. ExprType a => SomeVarValue a fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a |