From 274554243235d3013430a48973fd0f25244ac392 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 21 Sep 2024 21:19:37 +0200 Subject: Function parameters and calls --- src/Parser/Core.hs | 19 ++++++++--- src/Parser/Expr.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++-------- src/Run.hs | 4 +-- src/Test.hs | 93 +++++++++++++++++++++++++++++++++++++++++++++----- src/Test/Builtins.hs | 6 ++-- 5 files changed, 184 insertions(+), 33 deletions(-) (limited to 'src') 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 diff --git a/src/Run.hs b/src/Run.hs index 2bee6ec..24bba48 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -188,7 +188,7 @@ evalSteps = mapM_ $ \case withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a -withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s }) +withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue mempty $ const value ) : tsVars s }) withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do @@ -310,7 +310,7 @@ expect (SourceLine sline) p expr tvars inner = do throwError Failed outProc OutputMatch p line - local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner + local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue mempty . const) capture) ++ tsVars s }) inner Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr diff --git a/src/Test.hs b/src/Test.hs index bb65b81..8c5a3ef 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -9,22 +9,29 @@ module Test ( VarName(..), TypedVarName(..), textVarName, unpackVarName, ExprType(..), SomeExpr(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - DynamicType, + FunctionType, DynamicType, SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType, RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), - Expr(..), eval, gatherVars, + Expr(..), eval, gatherVars, evalSome, AppAnnotation(..), + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + Regex(RegexPart, RegexString), regexMatch, ) where +import Control.Monad + import Data.Char import Data.List +import Data.Map (Map) +import Data.Map qualified as M import Data.Scientific import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Typeable import Text.Regex.TDFA qualified as RE @@ -130,6 +137,12 @@ instance ExprType TestBlock where textExprValue _ = "" +data FunctionType a = FunctionType (FunctionArguments SomeExpr -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "" + data DynamicType instance ExprType DynamicType where @@ -144,26 +157,42 @@ newtype TypeVar = TypeVar Text data SomeExprType = forall a. ExprType a => ExprTypePrim (Proxy a) | ExprTypeVar TypeVar + | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeExprType) (Proxy a) someExprType :: SomeExpr -> SomeExprType +someExprType (SomeExpr (DynVariable tvar _)) = ExprTypeVar tvar +someExprType (SomeExpr fun@(FunVariable params _)) = ExprTypeFunction params (proxyOfFunctionType fun) + where + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy someExprType (SomeExpr (_ :: Expr a)) = ExprTypePrim (Proxy @a) textSomeExprType :: SomeExprType -> Text textSomeExprType (ExprTypePrim p) = textExprType p textSomeExprType (ExprTypeVar (TypeVar name)) = name +textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r -data SomeVarValue = forall a. ExprType a => SomeVarValue a +data SomeVarValue = forall a. ExprType a => SomeVarValue (FunctionArguments SomeExprType) (FunctionArguments SomeExpr -> a) fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a -fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value - where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ] +fromSomeVarValue name (SomeVarValue args (value :: args -> b)) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] textSomeVarValue :: SomeVarValue -> Text -textSomeVarValue (SomeVarValue value) = textExprValue value +textSomeVarValue (SomeVarValue args value) + | anull args = textExprValue $ value mempty + | otherwise = "" someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue (_ :: a)) = ExprTypePrim (Proxy @a) +someVarValueType (SomeVarValue args (_ :: args -> a)) + | anull args = ExprTypePrim (Proxy @a) + | otherwise = ExprTypeFunction args (Proxy @a) data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) @@ -176,6 +205,9 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) data Expr a where Variable :: ExprType a => VarName -> Expr a DynVariable :: TypeVar -> VarName -> Expr DynamicType + FunVariable :: ExprType a => FunctionArguments SomeExprType -> VarName -> Expr (FunctionType a) + ArgsApp :: FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) + FunctionEval :: Expr (FunctionType a) -> Expr a Pure :: a -> Expr a App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b Concat :: [Expr Text] -> Expr Text @@ -196,6 +228,13 @@ instance Applicative Expr where eval :: MonadEval m => Expr a -> m a eval (Variable name) = fromSomeVarValue name =<< lookupVar name eval (DynVariable _ _) = fail "ambiguous type" +eval (FunVariable _ name) = funFromSomeVarValue name =<< lookupVar name +eval (ArgsApp args efun) = do + FunctionType fun <- eval efun + return $ FunctionType $ \args' -> fun (args <> args') +eval (FunctionEval efun) = do + FunctionType fun <- eval efun + return $ fun mempty eval (Pure value) = return value eval (App _ f x) = eval f <*> eval x eval (Concat xs) = T.concat <$> mapM eval xs @@ -207,16 +246,25 @@ eval (Regex xs) = mapM eval xs >>= \case eval (RootNetwork) = rootNetwork eval (Undefined err) = fail err +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) = SomeVarValue mempty . const <$> eval expr + gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)] gatherVars = fmap (uniqOn fst . sortOn fst) . helper where helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)] helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var helper (DynVariable _ var) = (:[]) . ((var, []),) <$> lookupVar var + helper (FunVariable _ var) = (:[]) . ((var, []),) <$> lookupVar var + helper (ArgsApp (FunctionArguments args) fun) = do + v <- helper fun + vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args + return $ concat (v : vs) + helper (FunctionEval efun) = helper efun helper (Pure _) = return [] helper e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x - = do val <- SomeVarValue <$> eval e + = do val <- SomeVarValue mempty . const <$> eval e return [((var, sels ++ [sel]), val)] | otherwise = helper x helper (App _ f x) = (++) <$> helper f <*> helper x @@ -233,6 +281,33 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper return (var, sels ++ [sel]) _ -> Nothing + +data ArgumentKeyword = ArgumentKeyword Text + deriving (Show, Eq, Ord) + +newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) + deriving (Show, Semigroup, Monoid) + +anull :: FunctionArguments a -> Bool +anull (FunctionArguments args) = M.null args + +exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeExprType +exprArgs (FunVariable args _) = args +exprArgs (ArgsApp (FunctionArguments applied) expr) = + let FunctionArguments args = exprArgs expr + in FunctionArguments (args `M.difference` applied) +exprArgs _ = error "exprArgs on unexpected type" + +funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m (FunctionType a) +funFromSomeVarValue name (SomeVarValue args (value :: args -> b)) = do + maybe (fail err) return $ do + guard $ not $ anull args + FunctionType <$> cast value + where + err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has ", + (if anull args then "type" else "function type returting ") <> textExprType @b Proxy ] + + data Regex = RegexCompiled Text RE.Regex | RegexPart Text | RegexString Text diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 9deb2df..2ab38aa 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -6,8 +6,8 @@ import Test builtins :: [ ( VarName, SomeVarValue ) ] builtins = - [ ( VarName "wait", SomeVarValue builtinWait ) + [ ( VarName "wait", builtinWait ) ] -builtinWait :: TestBlock -builtinWait = TestBlock [ Wait ] +builtinWait :: SomeVarValue +builtinWait = SomeVarValue mempty $ const $ TestBlock [ Wait ] -- cgit v1.2.3