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/Test.hs | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 84 insertions(+), 9 deletions(-) (limited to 'src/Test.hs') 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 -- cgit v1.2.3