diff options
| -rw-r--r-- | src/Network.hs | 4 | ||||
| -rw-r--r-- | src/Parser.hs | 3 | ||||
| -rw-r--r-- | src/Run.hs | 6 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 6 | ||||
| -rw-r--r-- | src/Test.hs | 23 |
5 files changed, 26 insertions, 16 deletions
diff --git a/src/Network.hs b/src/Network.hs index aa06952..c841acb 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -5,6 +5,7 @@ module Network ( NodeName(..), textNodeName, unpackNodeName, nextNodeName, + rootNetworkVar, newInternet, delInternet, newSubnet, newNode, @@ -112,6 +113,9 @@ instance ExprType Node where ] +rootNetworkVar :: TypedVarName Network +rootNetworkVar = TypedVarName (VarName "$ROOT_NET") + nextPrefix :: IpPrefix -> [Word8] -> Word8 nextPrefix _ used = maximum (0 : used) + 1 diff --git a/src/Parser.hs b/src/Parser.hs index 4b1e69a..ab44833 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -22,6 +22,7 @@ import System.Directory import System.Exit import System.FilePath +import Network import Parser.Core import Parser.Expr import Parser.Statement @@ -83,7 +84,7 @@ parseTestFile path = do { testVars = concat [ map (fmap someVarValueType) builtins ] - , testContext = SomeExpr RootNetwork + , testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar , testNextTypeVar = 0 , testTypeUnif = M.empty } @@ -59,8 +59,7 @@ runTest out opts test variables = do , teGDB = fst <$> mgdb } tstate = TestState - { tsNetwork = error "network not initialized" - , tsVars = builtins + { tsVars = builtins , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -184,7 +183,8 @@ withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir res <- withNetwork (inetRoot inet) $ \net -> do - local (fmap $ \s -> s { tsNetwork = net }) $ inner net + withTypedVar rootNetworkVar net $ do + inner net delInternet inet return res diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 512dd72..2882197 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -21,7 +21,6 @@ import Data.Scientific import qualified Data.Text as T import {-# SOURCE #-} GDB -import {-# SOURCE #-} Network import Network.Ip import Output import {-# SOURCE #-} Process @@ -39,8 +38,7 @@ data TestEnv = TestEnv } data TestState = TestState - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] + { tsVars :: [(VarName, SomeVarValue)] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -94,8 +92,6 @@ instance MonadError Failed TestRun where 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, someConstValue value ) : tsVars s }) instance MonadOutput TestRun where diff --git a/src/Test.hs b/src/Test.hs index d0f1e45..effd00a 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -6,7 +6,7 @@ module Test ( SourceLine(..), textSourceLine, MonadEval(..), - VarName(..), TypedVarName(..), textVarName, unpackVarName, + VarName(..), TypedVarName(..), textVarName, unpackVarName, withTypedVar, ExprType(..), SomeExpr(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, FunctionType, DynamicType, @@ -19,7 +19,7 @@ module Test ( RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), - Expr(..), eval, evalSome, + Expr(..), varExpr, eval, evalSome, EvalTrace, VarNameSelectors, gatherVars, AppAnnotation(..), @@ -90,7 +90,6 @@ textSourceLine SourceLineBuiltin = "<builtin>" class MonadFail m => MonadEval m where lookupVar :: VarName -> m SomeVarValue - rootNetwork :: m Network withVar :: ExprType e => VarName -> e -> m a -> m a @@ -106,6 +105,14 @@ textVarName (VarName name ) = name unpackVarName :: VarName -> String unpackVarName = T.unpack . textVarName +isInternalVar :: VarName -> Bool +isInternalVar (VarName name) + | Just ( '$', _ ) <- T.uncons name = True + | otherwise = False + +withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a +withTypedVar (TypedVarName name) = withVar name + class Typeable a => ExprType a where textExprType :: proxy a -> Text @@ -253,7 +260,6 @@ data Expr a where App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b Concat :: [Expr Text] -> Expr Text Regex :: [Expr Regex] -> Expr Regex - RootNetwork :: Expr Network Undefined :: String -> Expr a data AppAnnotation b = AnnNone @@ -272,6 +278,9 @@ instance Semigroup a => Semigroup (Expr a) where instance Monoid a => Monoid (Expr a) where mempty = Pure mempty +varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a +varExpr sline (TypedVarName name) = Variable sline name + eval :: forall m a. MonadEval m => Expr a -> m a eval = \case Variable sline name -> fromSomeVarValue sline name =<< lookupVar name @@ -292,7 +301,6 @@ eval = \case parts -> case regexCompile $ T.concat $ map regexSource parts of Left err -> fail err Right re -> return re - RootNetwork -> rootNetwork Undefined err -> fail err evalSome :: MonadEval m => SomeExpr -> m SomeVarValue @@ -309,7 +317,9 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper where helper :: forall b. Expr b -> m EvalTrace helper = \case - Variable _ var -> (: []) . (( var, [] ), ) <$> lookupVar var + Variable _ var + | isInternalVar var -> return [] + | otherwise -> (: []) . (( var, [] ), ) <$> lookupVar var DynVariable _ _ var -> (: []) . (( var, [] ), ) <$> lookupVar var FunVariable _ _ var -> (: []) . (( var, [] ), ) <$> lookupVar var ArgsApp (FunctionArguments args) fun -> do @@ -328,7 +338,6 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper App _ f x -> (++) <$> helper f <*> helper x Concat es -> concat <$> mapM helper es Regex es -> concat <$> mapM helper es - RootNetwork -> return [] Undefined {} -> return [] gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) |