diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser.hs | 2 | ||||
| -rw-r--r-- | src/Process/Signal.hs | 4 | ||||
| -rw-r--r-- | src/Run.hs | 6 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 2 | ||||
| -rw-r--r-- | src/Script/Expr.hs | 67 | ||||
| -rw-r--r-- | src/Test/Builtins.hs | 48 |
6 files changed, 67 insertions, 62 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index c83d781..191d40d 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -242,7 +242,7 @@ parseTestFile parsedModules mbModuleName path = do let initState = TestParserState { testSourcePath = path , testVars = concat - [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs index f6619f6..e57b68d 100644 --- a/src/Process/Signal.hs +++ b/src/Process/Signal.hs @@ -51,8 +51,8 @@ instance ExprType Signal where | otherwise = "<SIG_" <> T.pack (show sig) <> ">" -signalBuiltins :: [ ( Text, SomeVarValue ) ] -signalBuiltins = map (fmap someConstValue) +signalBuiltins :: [ ( Text, SomeExpr ) ] +signalBuiltins = map (fmap $ SomeExpr . Pure) [ ( "SIGHUP", Signal Posix.sigHUP ) , ( "SIGINT", Signal Posix.sigINT ) , ( "SIGQUIT", Signal Posix.sigQUIT ) @@ -10,7 +10,6 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.Except -import Control.Monad.Fix import Control.Monad.Reader import Control.Monad.Writer @@ -82,7 +81,7 @@ runTest out opts gdefs test = do } tstate = TestState { tsGlobals = gdefs - , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ] + , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -160,8 +159,7 @@ loadModules files = do evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs -evalGlobalDefs exprs = fix $ \gdefs -> - builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) +evalGlobalDefs exprs = builtins `M.union` M.fromList exprs runBlock :: TestBlock () -> TestRun () runBlock EmptyTestBlock = return () diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 7a1d3c5..f4444e8 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -52,7 +52,7 @@ data TestEnv = TestEnv data TestState = TestState { tsGlobals :: GlobalDefs - , tsLocals :: [ ( VarName, SomeVarValue ) ] + , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs index 3d26157..06eb9f6 100644 --- a/src/Script/Expr.hs +++ b/src/Script/Expr.hs @@ -58,6 +58,7 @@ data Expr a where Variable :: ExprType a => SourceLine -> FqVarName -> Expr a DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a) + OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe a) ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) @@ -101,6 +102,7 @@ mapExpr f = go e@Variable {} -> f e e@DynVariable {} -> f e e@FunVariable {} -> f e + e@OptVariable {} -> f e ArgsReq args expr -> f $ ArgsReq args (go expr) ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) @@ -123,19 +125,19 @@ class MonadFail m => MonadEval m where askDictionary :: m VariableDictionary withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a -type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue +type GlobalDefs = Map ( ModuleName, VarName ) SomeExpr -type VariableDictionary = [ ( VarName, SomeVarValue ) ] +type VariableDictionary = [ ( VarName, SomeExpr ) ] -lookupVar :: MonadEval m => FqVarName -> m SomeVarValue +lookupVar :: MonadEval m => FqVarName -> m SomeExpr lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name -tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr) 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 (( name, someConstValue value ) : ) +withVar name value = withDictionary (( name, SomeExpr (Pure value) ) : ) withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a withTypedVar (TypedVarName name) = withVar name @@ -176,14 +178,15 @@ eval = \case Let _ (TypedVarName name) valExpr expr -> do val <- eval valExpr withVar name val $ eval expr - Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name + Variable _ name -> evalSomeExpr name =<< lookupVar name DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" - FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name + FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name + OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name ArgsReq (FunctionArguments req) efun -> do gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \stack (FunctionArguments args) -> - let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) in fun stack $ FunctionArguments $ args `M.difference` req ArgsApp eargs efun -> do @@ -194,10 +197,10 @@ eval = \case gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \stack _ -> - runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict) + runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict) FunctionEval sline efun -> do vars <- gatherVars efun - CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName + CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName let cs' = CallStack (( sline, vars ) : cs) FunctionType fun <- withVar callStackVarName cs' $ eval efun return $ fun cs' mempty @@ -218,7 +221,7 @@ eval = \case LambdaAbstraction (TypedVarName name) expr -> do gdefs <- askGlobalDefs dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) + return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure x ) : dict) Pure value -> return value App _ f x -> eval f <*> eval x Concat xs -> T.concat <$> mapM eval xs @@ -230,6 +233,13 @@ eval = \case Undefined err -> fail err Trace expr -> Traced <$> gatherVars expr <*> eval expr +evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a +evalSomeExpr name (SomeExpr (e :: Expr b)) = do + maybe (fail err) eval $ cast e + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ", + textExprType @b Proxy ] + evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) evalToVarValue expr = do VarValue @@ -313,6 +323,7 @@ renameTypeVar a b = go Variable {} -> orig DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name FunVariable {} -> orig + OptVariable {} -> orig ArgsReq args body -> ArgsReq args (go body) ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun) FunctionAbstraction expr -> FunctionAbstraction (go expr) @@ -446,14 +457,6 @@ exprArgs = \case App {} -> error "exprArgs: app" Undefined {} -> error "exprArgs: undefined" -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - FunctionType <$> cast value - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName 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 @@ -479,18 +482,10 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper helper :: forall b. Expr b -> m EvalTrace helper = \case Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Variable _ var - | GlobalVarName {} <- var -> return [] - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - DynVariable _ _ var - | GlobalVarName {} <- var -> return [] - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - FunVariable _ _ var - | GlobalVarName {} <- var -> return [] - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + e@(Variable _ var) -> gatherLocalVar var e + e@(DynVariable _ _ var) -> gatherLocalVar var e + e@(FunVariable _ _ var) -> gatherLocalVar var e + e@(OptVariable _ var) -> gatherLocalVar var e ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr ArgsApp (FunctionArguments args) fun -> do v <- helper fun @@ -518,6 +513,16 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper Undefined {} -> return [] Trace expr -> helper expr + gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace + gatherLocalVar var expr + | GlobalVarName {} <- var = return [] + | isInternalVar var = return [] + | otherwise = do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict + return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) gatherSelectors = \case Variable _ var -> Just (var, []) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 3dc6554..4ad6049 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -3,7 +3,6 @@ module Test.Builtins ( ) where import Data.Map qualified as M -import Data.Maybe import Data.Proxy import Data.Scientific import Data.Text (Text) @@ -27,47 +26,50 @@ builtins = M.fromList $ concat where fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) -getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a -getArg args = fromMaybe (error "parameter mismatch") . getArgMb args +biVar :: ExprType a => Text -> Expr a +biVar = Variable SourceLineBuiltin . LocalVarName . VarName -getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a -getArgMb (FunctionArguments args) kw = do - fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args +biOpt :: ExprType a => Text -> Expr (Maybe a) +biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName -builtinSend :: SomeVarValue -builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) +biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a ) +biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) )) + +builtinSend :: SomeExpr +builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0") where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) , ( Nothing, SomeArgumentType (RequiredArgument @Text) ) ] -builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) +builtinFlush :: SomeExpr +builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching") where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) ) ] -builtinIgnore :: SomeVarValue -builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") ) +builtinIgnore :: SomeExpr +builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching")) where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) ) ] -builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing) +builtinGuard :: SomeExpr +builtinGuard = SomeExpr $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType (RequiredArgument @Bool) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0") -builtinMultiplyTimeout :: SomeVarValue -builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $ - \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by")) +builtinMultiplyTimeout :: SomeExpr +builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType (RequiredArgument @Scientific) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by") -builtinWait :: SomeVarValue -builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait +builtinWait :: SomeExpr +builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait |