summaryrefslogtreecommitdiff
path: root/src/Test.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Test.hs')
-rw-r--r--src/Test.hs142
1 files changed, 124 insertions, 18 deletions
diff --git a/src/Test.hs b/src/Test.hs
index ba27153..24a4c72 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -7,22 +7,33 @@ module Test (
MonadEval(..),
VarName(..), TypedVarName(..), textVarName, unpackVarName,
- ExprType(..), SomeExpr(..), SomeExprType(..), someExprType,
+ ExprType(..), SomeExpr(..),
+ TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
+ FunctionType, DynamicType,
SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType,
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
- Expr(..), eval, gatherVars,
+ Expr(..), eval, gatherVars, evalSome,
AppAnnotation(..),
+ ArgumentKeyword(..), FunctionArguments(..),
+ anull, exprArgs,
+ SomeArgumentType(..), ArgumentType(..),
+
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.String
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
@@ -35,6 +46,7 @@ import Util
data Module = Module
{ moduleName :: [ Text ]
, moduleTests :: [ Test ]
+ , moduleDefinitions :: [ ( VarName, SomeVarValue ) ]
}
data Test = Test
@@ -69,7 +81,7 @@ class MonadFail m => MonadEval m where
newtype VarName = VarName Text
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Show)
newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
deriving (Eq, Ord)
@@ -128,25 +140,62 @@ instance ExprType TestBlock where
textExprValue _ = "<test block>"
+data FunctionType a = FunctionType (FunctionArguments SomeExpr -> a)
+
+instance ExprType a => ExprType (FunctionType a) where
+ textExprType _ = "function type"
+ textExprValue _ = "<function type>"
+
+data DynamicType
+
+instance ExprType DynamicType where
+ textExprType _ = "ambiguous type"
+ textExprValue _ = "<dynamic type>"
+
data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
-data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)
+newtype TypeVar = TypeVar Text
+ deriving (Eq, Ord)
+
+data SomeExprType
+ = forall a. ExprType a => ExprTypePrim (Proxy a)
+ | ExprTypeVar TypeVar
+ | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)
someExprType :: SomeExpr -> SomeExprType
-someExprType (SomeExpr (_ :: Expr a)) = SomeExprType (Proxy @a)
+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 SomeArgumentType) (SourceLine -> 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 :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a
+fromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do
+ maybe (fail err) return $ do
+ guard $ anull args
+ cast $ value sline 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 :: SourceLine -> SomeVarValue -> Text
+textSomeVarValue sline (SomeVarValue args value)
+ | anull args = textExprValue $ value sline mempty
+ | otherwise = "<function>"
someVarValueType :: SomeVarValue -> SomeExprType
-someVarValueType (SomeVarValue (_ :: a)) = SomeExprType (Proxy @a)
+someVarValueType (SomeVarValue args (_ :: SourceLine -> args -> a))
+ | anull args = ExprTypePrim (Proxy @a)
+ | otherwise = ExprTypeFunction args (Proxy @a)
data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
@@ -157,7 +206,11 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
data Expr a where
- Variable :: ExprType a => VarName -> Expr a
+ Variable :: ExprType a => SourceLine -> VarName -> Expr a
+ DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType
+ FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> 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
@@ -176,7 +229,15 @@ instance Applicative Expr where
(<*>) = App AnnNone
eval :: MonadEval m => Expr a -> m a
-eval (Variable name) = fromSomeVarValue name =<< lookupVar name
+eval (Variable sline name) = fromSomeVarValue sline name =<< lookupVar name
+eval (DynVariable _ _ _) = fail "ambiguous type"
+eval (FunVariable _ sline name) = funFromSomeVarValue sline 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
@@ -188,15 +249,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 . 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 (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 . const <$> eval e
return [((var, sels ++ [sel]), val)]
| otherwise = helper x
helper (App _ f x) = (++) <$> helper f <*> helper x
@@ -207,12 +278,47 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text])
gatherSelectors = \case
- Variable var -> Just (var, [])
+ Variable _ var -> Just (var, [])
App (AnnRecord sel) _ x -> do
(var, sels) <- gatherSelectors x
return (var, sels ++ [sel])
_ -> Nothing
+
+newtype ArgumentKeyword = ArgumentKeyword Text
+ deriving (Show, Eq, Ord, IsString)
+
+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 SomeArgumentType
+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) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a)
+funFromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do
+ maybe (fail err) return $ do
+ guard $ not $ anull args
+ FunctionType <$> cast (value sline)
+ 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 SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a)
+
+data ArgumentType a
+ = RequiredArgument
+ | OptionalArgument
+ | ExprDefault (Expr a)
+ | ContextDefault
+
+
data Regex = RegexCompiled Text RE.Regex
| RegexPart Text
| RegexString Text
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 03:10:59 +0000