diff options
| -rw-r--r-- | src/Run.hs | 2 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 2 | ||||
| -rw-r--r-- | src/Test.hs | 47 | ||||
| -rw-r--r-- | src/Test/Builtins.hs | 8 |
4 files changed, 42 insertions, 17 deletions
@@ -300,7 +300,7 @@ expect (SourceLine sline) p expr tvars inner = do throwError Failed outProc OutputMatch p line - local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue [] mempty . const . const) capture) ++ tsVars s }) inner + local (fmap $ \s -> s { tsVars = zip vars (map someConstValue capture) ++ tsVars s }) inner Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) =<< gatherVars expr diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 54600f0..512dd72 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -96,7 +96,7 @@ instance MonadEval TestRun where lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) rootNetwork = asks $ tsNetwork . snd - withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue [] mempty $ const $ const value ) : tsVars s }) + withVar name value = local (fmap $ \s -> s { tsVars = ( name, someConstValue value ) : tsVars s }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst diff --git a/src/Test.hs b/src/Test.hs index da4c82d..836489c 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -10,7 +10,12 @@ module Test ( ExprType(..), SomeExpr(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, FunctionType, DynamicType, - SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), @@ -179,14 +184,34 @@ textSomeExprType (ExprTypeVar (TypeVar name)) = name textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r -data SomeVarValue = forall a. ExprType a => SomeVarValue - { svvVariables :: EvalTrace - , svvArguments :: FunctionArguments SomeArgumentType - , svvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a } +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> VarValue a -> m a +fromConstValue sline name (VarValue _ args value :: VarValue 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" ] + fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue _ args (value :: SourceLine -> args -> b)) = do +fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do maybe (fail err) return $ do guard $ anull args cast $ value sline mempty @@ -195,12 +220,12 @@ fromSomeVarValue sline name (SomeVarValue _ args (value :: SourceLine -> args -> if anull args then textExprType @b Proxy else "function type" ] textSomeVarValue :: SourceLine -> SomeVarValue -> Text -textSomeVarValue sline (SomeVarValue _ args value) +textSomeVarValue sline (SomeVarValue (VarValue _ args value)) | anull args = textExprValue $ value sline mempty | otherwise = "<function>" someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue _ args (_ :: SourceLine -> args -> a)) +someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) | anull args = ExprTypePrim (Proxy @a) | otherwise = ExprTypeFunction args (Proxy @a) @@ -265,7 +290,7 @@ eval = \case Undefined err -> fail err evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) = SomeVarValue +evalSome (SomeExpr expr) = fmap SomeVarValue $ VarValue <$> gatherVars expr <*> pure mempty <*> (const . const <$> eval expr) @@ -290,7 +315,7 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x -> do - val <- SomeVarValue [] mempty . const . const <$> eval e + val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e return [ (( var, sels ++ [ sel ] ), val ) ] | otherwise -> do helper x @@ -326,7 +351,7 @@ exprArgs (ArgsApp (FunctionArguments applied) expr) = 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 +funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do maybe (fail err) return $ do guard $ not $ anull args FunctionType <$> cast (value sline) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 36f88e8..a36505a 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -29,7 +29,7 @@ getArgVars (FunctionArguments args) kw = do maybe [] svvVariables $ M.lookup kw args builtinSend :: SomeVarValue -builtinSend = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $ +builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] where atypes = @@ -38,7 +38,7 @@ builtinSend = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $ ] builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $ +builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ] where atypes = @@ -47,8 +47,8 @@ builtinFlush = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $ ] builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ +builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ] builtinWait :: SomeVarValue -builtinWait = SomeVarValue [] mempty $ const . const $ TestBlock [ Wait ] +builtinWait = someConstValue $ TestBlock [ Wait ] |