diff options
Diffstat (limited to 'src/Parser')
| -rw-r--r-- | src/Parser/Core.hs | 19 | ||||
| -rw-r--r-- | src/Parser/Expr.hs | 95 |
2 files changed, 95 insertions, 19 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 2a2fc89..dd2df12 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -60,6 +60,7 @@ lookupVarExpr off name = do lookupVarType off name >>= \case ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable name :: Expr a) ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar name + ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args name :: Expr (FunctionType a)) unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -122,24 +123,32 @@ unify off a b = do unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) -unifyExpr off pa x = if +unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT - -> return x + -> return expr - | DynVariable tvar name <- x + | DynVariable tvar name <- expr -> do _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) return $ Variable name + | Just (Refl :: FunctionType a :~: b) <- eqT + -> do + case exprArgs expr of + remaining + | anull remaining -> return (FunctionEval expr) + | otherwise -> parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "missing function arguments" + | Just (Refl :: DynamicType :~: b) <- eqT - , Undefined msg <- x + , Undefined msg <- expr -> do return $ Undefined msg | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType x <> "'" + "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'" skipLineComment :: TestParser () diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index f9b1e32..04035c1 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -7,6 +7,8 @@ module Parser.Expr ( someExpr, typedExpr, + + functionArguments, ) where import Control.Applicative (liftA2) @@ -15,12 +17,13 @@ import Control.Monad import Control.Monad.State import Data.Char +import Data.Map qualified as M import Data.Maybe import Data.Scientific -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T -import qualified Data.Text.Lazy as TL +import Data.Text.Lazy qualified as TL import Data.Typeable import Data.Void @@ -211,7 +214,11 @@ someExpr = join inner <?> "expression" parens = between (symbol "(") (symbol ")") - term = parens inner <|> literal <|> variable <?> "term" + term = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> variable + ] table = [ [ recordSelector ] @@ -330,21 +337,81 @@ someExpr = join inner <?> "expression" applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e - literal = label "literal" $ choice - [ return <$> numberLiteral - , return . SomeExpr <$> quotedString - , return . SomeExpr <$> regex - , return <$> list - ] +literal :: TestParser SomeExpr +literal = label "literal" $ choice + [ numberLiteral + , SomeExpr <$> quotedString + , SomeExpr <$> regex + , list + ] - variable = label "variable" $ do - off <- stateOffset <$> getParserState - name <- varName - e <- lookupVarExpr off name - return $ return e +variable :: TestParser SomeExpr +variable = label "variable" $ do + off <- stateOffset <$> getParserState + name <- varName + lookupVarExpr off name >>= \case + SomeExpr e'@(FunVariable (FunctionArguments argTypes) _) -> do + let check poff kw expr = do + case M.lookup kw argTypes of + Just expected -> do + withRecovery registerParseError $ do + void $ unify poff expected (someExprType expr) + return expr + Nothing -> do + registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ + case kw of + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'" + Nothing -> "unexpected parameter" + return expr + + args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff . VarName) + return $ SomeExpr $ ArgsApp args e' + e -> do + return e typedExpr :: forall a. ExprType a => TestParser (Expr a) typedExpr = do off <- stateOffset <$> getParserState SomeExpr e <- someExpr unifyExpr off Proxy e + + +functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) +functionArguments check param lit promote = do + args <- parseArgs True + return $ FunctionArguments args + where + parseArgs allowUnnamed = choice + [do off <- stateOffset <$> getParserState + x <- pparam + if allowUnnamed + then do + checkAndInsert off Nothing x $ parseArgs False + else do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "multiple unnamed parameters" ] + parseArgs False + + ,do off <- stateOffset <$> getParserState + x <- identifier + choice + [do off' <- stateOffset <$> getParserState + y <- pparam <|> (promote off' =<< identifier) + checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed + + ,if allowUnnamed + then do + y <- promote off x + checkAndInsert off Nothing y $ return M.empty + else do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "multiple unnamed parameters" ] + return M.empty + ] + + ,do return M.empty + ] + + pparam = between (symbol "(") (symbol ")") param <|> lit + + checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont |