summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-08-22 22:46:17 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-08-22 22:48:16 +0200
commit85fe4fa7427ef67be9177e682e64bbe5fe8b6c59 (patch)
tree4fddf7f002918b7a02d0a189a0e8e114bb62e4f7 /src
parent2a77d6bd5d932865217509464c80c087bef5c9ae (diff)
Boolean operators and expression
Diffstat (limited to 'src')
-rw-r--r--src/Parser.hs32
-rw-r--r--src/Test.hs6
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