summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-09-28 09:30:36 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-09-28 10:17:39 +0200
commit08d319f0105ed4b2fd217e0a9e96333e4c786095 (patch)
treed0f87ec3b495d21dd0f0ef32a03682f7f9f3a4ca
parentafd550dc8245e61ab6b148c72cdf133e6b7836d1 (diff)
Require parentheses around complex command arguments
-rw-r--r--src/Parser/Expr.hs44
-rw-r--r--src/Parser/Statement.hs5
2 files changed, 26 insertions, 23 deletions
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 4b1a89e..322bb9b 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -7,6 +7,8 @@ module Parser.Expr (
someExpr,
typedExpr,
+ literal,
+ variable,
functionArguments,
) where
@@ -221,9 +223,7 @@ someExpr = join inner <?> "expression"
, return <$> variable
]
- table = [ [ recordSelector
- ]
- , [ prefix "-" $ [ SomeUnOp (negate @Integer)
+ table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer)
, SomeUnOp (negate @Scientific)
]
]
@@ -324,19 +324,11 @@ someExpr = join inner <?> "expression"
region (const err) $
foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops
- recordSelector :: Operator TestParser (TestParser SomeExpr)
- recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do
- void $ osymbol "."
- off <- stateOffset <$> getParserState
- m <- identifier
- return $ \p -> do
- SomeExpr e <- p
- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]
- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers
-
- applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr
- applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
+typedExpr :: forall a. ExprType a => TestParser (Expr a)
+typedExpr = do
+ off <- stateOffset <$> getParserState
+ SomeExpr e <- someExpr
+ unifyExpr off Proxy e
literal :: TestParser SomeExpr
literal = label "literal" $ choice
@@ -369,13 +361,21 @@ variable = label "variable" $ do
args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName)
return $ SomeExpr $ ArgsApp args e'
e -> do
- return e
+ recordSelector e <|> return e
-typedExpr :: forall a. ExprType a => TestParser (Expr a)
-typedExpr = do
- off <- stateOffset <$> getParserState
- SomeExpr e <- someExpr
- unifyExpr off Proxy e
+ where
+ recordSelector :: SomeExpr -> TestParser SomeExpr
+ recordSelector (SomeExpr e) = do
+ void $ osymbol "."
+ off <- stateOffset <$> getParserState
+ m <- identifier
+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]
+ e' <- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers
+ recordSelector e' <|> return e'
+
+ applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr
+ applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 6434a53..2d45a21 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -91,7 +91,10 @@ instance ExprType a => ParamType (TypedVarName a) where
showParamType _ = "<variable>"
instance ExprType a => ParamType (Expr a) where
- parseParam _ = typedExpr
+ parseParam _ = do
+ off <- stateOffset <$> getParserState
+ SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr
+ unifyExpr off Proxy e
showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
instance ParamType a => ParamType [a] where