Separate VarValue type without hidden type

4 files changed, 42 insertions, 17 deletions

diff --git a/src/Run.hs b/src/Run.hs
index 31a3c9e..f94c47d 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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 ]