diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser/Expr.hs | 44 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 5 |
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 |