Function parameters and calls

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