From 3640256e80ba1aa1c1e022a231234dee814ace58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 15 Feb 2025 20:38:39 +0100 Subject: Collect and evaluate global definitions together --- src/Main.hs | 6 ++--- src/Parser.hs | 4 +-- src/Run.hs | 28 ++++++++++---------- src/Run/Monad.hs | 12 +++++---- src/Test.hs | 72 ++++++++++++++++++++++++++++++++-------------------- src/Test/Builtins.hs | 6 ++--- 6 files changed, 73 insertions(+), 55 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 1f15e68..9b0667d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -151,12 +151,12 @@ main = do ( modules, allModules ) <- parseTestFiles $ map fst files tests <- forM (zip modules $ map snd files) $ \( Module {..}, mbTestName ) -> do - return $ map ( , map (first LocalVarName) moduleDefinitions ) $ case mbTestName of + return $ case mbTestName of Nothing -> moduleTests Just name -> filter ((==name) . testName) moduleTests - let globalDefs = concatMap (map snd . moduleExportedDefinitions) allModules + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules - ok <- allM (\( test, defs ) -> runTest out (optTest opts) test (defs ++ globalDefs)) $ + ok <- allM (runTest out (optTest opts) globalDefs) $ concat $ replicate (optRepeat opts) $ concat tests when (not ok) exitFailure diff --git a/src/Parser.hs b/src/Parser.hs index 174babb..94e9a12 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -68,7 +68,7 @@ parseDefinition = label "symbol definition" $ do atypes' <- getInferredTypes atypes L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr ] - modify $ \s -> s { testVars = ( name, ( LocalVarName name, someExprType expr )) : testVars s } + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return def where getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do @@ -169,7 +169,7 @@ parseTestFile parsedModules moduleName path = do Nothing -> do let initState = TestParserState { testVars = concat - [ map (\( name, value ) -> ( unqualifyName name, ( name, someVarValueType value ))) builtins + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 diff --git a/src/Run.hs b/src/Run.hs index 4cd80a0..1b2f448 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -1,6 +1,7 @@ module Run ( module Run.Monad, runTest, + evalGlobalDefs, ) where import Control.Applicative @@ -33,8 +34,8 @@ import Run.Monad import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> [ ( FqVarName, SomeExpr ) ] -> IO Bool -runTest out opts test variables = do +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool +runTest out opts gdefs test = do let testDir = optTestDir opts when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e @@ -59,7 +60,8 @@ runTest out opts test variables = do , teGDB = fst <$> mgdb } tstate = TestState - { tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -82,19 +84,12 @@ runTest out opts test variables = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - let withVarExprList (( name, expr ) : rest) act = do - value <- evalSome expr - local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do - withVarExprList rest act - withVarExprList [] act = act - resetOutputTime out res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withVarExprList variables $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + withInternet $ \_ -> do + evalBlock =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." void $ installHandler processStatusChanged oldHandler Nothing @@ -109,6 +104,11 @@ runTest out opts test variables = do return True _ -> return False + +evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs +evalGlobalDefs exprs = fix $ \gdefs -> + builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) + evalBlock :: TestBlock -> TestRun () evalBlock (TestBlock steps) = forM_ steps $ \case Subnet name parent inner -> do diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index a550070..3fc511a 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -16,9 +16,9 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Map (Map) -import Data.Set (Set) import Data.Scientific -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text qualified as T import {-# SOURCE #-} GDB import Network.Ip @@ -38,7 +38,8 @@ data TestEnv = TestEnv } data TestState = TestState - { tsVars :: [ ( FqVarName, SomeVarValue ) ] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeVarValue ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -91,8 +92,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - askDictionary = asks (tsVars . snd) - withDictionary f = local (fmap $ \s -> s { tsVars = f (tsVars s) }) + askGlobalDefs = asks (tsGlobals . snd) + askDictionary = asks (tsLocals . snd) + withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst diff --git a/src/Test.hs b/src/Test.hs index 82303f8..3808186 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -13,7 +13,7 @@ module Test ( TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, FunctionType, DynamicType, - VarValue(..), SomeVarValue(..), + VarValue(..), SomeVarValue(..), GlobalDefs, svvVariables, svvArguments, someConstValue, fromConstValue, fromSomeVarValue, textSomeVarValue, someVarValueType, @@ -21,7 +21,7 @@ module Test ( RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), - Expr(..), varExpr, mapExpr, eval, evalSome, + Expr(..), varExpr, mapExpr, eval, evalSome, evalSomeWith, Traced(..), EvalTrace, VarNameSelectors, gatherVars, AppAnnotation(..), @@ -36,7 +36,6 @@ import Control.Monad import Control.Monad.Reader import Data.Char -import Data.Bifunctor import Data.Foldable import Data.List import Data.Map (Map) @@ -105,19 +104,21 @@ textSourceLine SourceLineBuiltin = "" class MonadFail m => MonadEval m where + askGlobalDefs :: m GlobalDefs askDictionary :: m VariableDictionary withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a -type VariableDictionary = [ ( FqVarName, SomeVarValue ) ] +type VariableDictionary = [ ( VarName, SomeVarValue ) ] lookupVar :: MonadEval m => FqVarName -> m SomeVarValue -lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return . lookup name =<< askDictionary +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) -tryLookupVar name = lookup name <$> askDictionary +tryLookupVar (LocalVarName name) = lookup name <$> askDictionary +tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a -withVar name value = withDictionary (( LocalVarName name, someConstValue value ) : ) +withVar name value = withDictionary (( name, someConstValue value ) : ) newtype VarName = VarName Text @@ -292,6 +293,8 @@ data VarValue a = VarValue , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a } +type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue + someConstValue :: ExprType a => a -> SomeVarValue someConstValue = SomeVarValue . VarValue [] mempty . const . const @@ -389,18 +392,19 @@ mapExpr f = go Trace expr -> f $ Trace (go expr) -newtype SimpleEval a = SimpleEval (Reader VariableDictionary a) +newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) deriving (Functor, Applicative, Monad) -runSimpleEval :: SimpleEval a -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = runReader x +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) = curry $ runReader x instance MonadFail SimpleEval where fail = error . ("eval failed: " <>) instance MonadEval SimpleEval where - askDictionary = SimpleEval ask - withDictionary f (SimpleEval inner) = SimpleEval (local f inner) + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) eval :: forall m a. MonadEval m => Expr a -> m a @@ -412,10 +416,11 @@ eval = \case DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \(FunctionArguments args) -> let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req - FunctionType fun = runSimpleEval (eval efun) (map (first LocalVarName) (toList used) ++ dict) + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) in fun $ FunctionArguments $ args `M.difference` req ArgsApp eargs efun -> do FunctionType fun <- eval efun @@ -428,8 +433,9 @@ eval = \case FunctionType fun <- eval efun return $ fun mempty LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) (( LocalVarName name, someConstValue x ) : dict) + return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) Pure value -> return value App _ f x -> eval f <*> eval x Concat xs -> T.concat <$> mapM eval xs @@ -441,19 +447,29 @@ eval = \case Undefined err -> fail err Trace expr -> Traced <$> gatherVars expr <*> eval expr +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure (const fun) + evalSome :: MonadEval m => SomeExpr -> m SomeVarValue evalSome (SomeExpr expr) - | IsFunType <- asFunType expr = do - FunctionType fun <- eval expr - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure (exprArgs expr) - <*> pure (const fun) - | otherwise = do - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure mempty - <*> (const . const <$> eval expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + data Traced a = Traced EvalTrace a @@ -465,20 +481,20 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper where helper :: forall b. Expr b -> m EvalTrace helper = \case - Let _ (TypedVarName var) _ expr -> withDictionary (filter ((LocalVarName var /=) . fst)) $ helper expr + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Variable _ var | isInternalVar var -> return [] | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - ArgsReq args expr -> withDictionary (filter ((`notElem` map (LocalVarName . fst) (toList args)) . fst)) $ helper expr + ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr ArgsApp (FunctionArguments args) fun -> do v <- helper fun vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args return $ concat (v : vs) FunctionAbstraction expr -> helper expr FunctionEval efun -> helper efun - LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((LocalVarName var /=) . fst)) $ helper expr + LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Pure _ -> return [] e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 29e54af..bf22ff8 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -9,15 +9,15 @@ import Data.Text (Text) import Process (Process) import Test -builtins :: [ ( FqVarName, SomeVarValue ) ] -builtins = +builtins :: GlobalDefs +builtins = M.fromList [ fq "send" builtinSend , fq "flush" builtinFlush , fq "guard" builtinGuard , fq "wait" builtinWait ] where - fq name impl = ( GlobalVarName (ModuleName [ "$" ]) (VarName name), impl ) + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a getArg args = fromMaybe (error "parameter mismatch") . getArgMb args -- cgit v1.2.3