summaryrefslogtreecommitdiff
path: root/src/Script
diff options
context:
space:
mode:
Diffstat (limited to 'src/Script')
-rw-r--r--src/Script/Expr.hs90
-rw-r--r--src/Script/Expr/Class.hs14
-rw-r--r--src/Script/Object.hs53
-rw-r--r--src/Script/Shell.hs200
-rw-r--r--src/Script/Var.hs10
5 files changed, 290 insertions, 77 deletions
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index ced807c..7a446c5 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -18,7 +18,7 @@ module Script.Expr (
anull, exprArgs,
SomeArgumentType(..), ArgumentType(..),
- Traced(..), EvalTrace, VarNameSelectors, gatherVars,
+ Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars,
AppAnnotation(..),
module Script.Var,
@@ -58,7 +58,7 @@ data Expr a where
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)
- FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a
+ FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a
LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b)
Pure :: a -> Expr a
App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
@@ -98,7 +98,7 @@ mapExpr f = go
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)
- FunctionEval expr -> f $ FunctionEval (go expr)
+ FunctionEval sline expr -> f $ FunctionEval sline (go expr)
LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr)
e@Pure {} -> f e
App ann efun earg -> f $ App ann (go efun) (go earg)
@@ -131,12 +131,6 @@ withVar name value = withDictionary (( name, someConstValue value ) : )
withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
withTypedVar (TypedVarName name) = withVar name
-isInternalVar :: FqVarName -> Bool
-isInternalVar (GlobalVarName {}) = False
-isInternalVar (LocalVarName (VarName name))
- | Just ( '$', _ ) <- T.uncons name = True
- | otherwise = False
-
newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
deriving (Functor, Applicative, Monad)
@@ -152,31 +146,42 @@ instance MonadEval SimpleEval where
askDictionary = SimpleEval (asks snd)
withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner)
+callStackVarName :: VarName
+callStackVarName = VarName "$STACK"
+
+callStackFqVarName :: FqVarName
+callStackFqVarName = LocalVarName callStackVarName
+
eval :: forall m a. MonadEval m => Expr a -> m a
eval = \case
Let _ (TypedVarName name) valExpr expr -> do
val <- eval valExpr
withVar name val $ eval expr
- Variable sline name -> fromSomeVarValue sline name =<< lookupVar name
+ Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name
DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"
- FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
+ FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name
ArgsReq (FunctionArguments req) efun -> do
gdefs <- askGlobalDefs
dict <- askDictionary
- return $ FunctionType $ \(FunctionArguments args) ->
+ return $ FunctionType $ \stack (FunctionArguments args) ->
let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
- in fun $ FunctionArguments $ args `M.difference` req
+ in fun stack $ FunctionArguments $ args `M.difference` req
ArgsApp eargs efun -> do
FunctionType fun <- eval efun
args <- mapM evalSome eargs
- return $ FunctionType $ \args' -> fun (args <> args')
+ return $ FunctionType $ \stack args' -> fun stack (args <> args')
FunctionAbstraction expr -> do
- val <- eval expr
- return $ FunctionType $ const val
- FunctionEval efun -> do
- FunctionType fun <- eval efun
- return $ fun mempty
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ return $ FunctionType $ \stack _ ->
+ runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : dict)
+ FunctionEval sline efun -> do
+ vars <- gatherVars efun
+ CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName
+ let cs' = CallStack (( sline, vars ) : cs)
+ FunctionType fun <- withVar callStackVarName cs' $ eval efun
+ return $ fun cs' mempty
LambdaAbstraction (TypedVarName name) expr -> do
gdefs <- askGlobalDefs
dict <- askDictionary
@@ -205,7 +210,7 @@ evalFunToVarValue expr = do
VarValue
<$> gatherVars expr
<*> pure (exprArgs expr)
- <*> pure (const fun)
+ <*> pure fun
evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
evalSome (SomeExpr expr)
@@ -216,7 +221,7 @@ evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue
evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs []
-data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)
+data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a)
instance ExprType a => ExprType (FunctionType a) where
textExprType _ = "function type"
@@ -289,7 +294,7 @@ asFunType = \case
data VarValue a = VarValue
{ vvVariables :: EvalTrace
, vvArguments :: FunctionArguments SomeArgumentType
- , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
+ , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a
}
data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a)
@@ -303,27 +308,27 @@ svvArguments (SomeVarValue vv) = vvArguments vv
someConstValue :: ExprType a => a -> SomeVarValue
someConstValue = SomeVarValue . VarValue [] mempty . const . const
-fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a
-fromConstValue sline name (VarValue _ args value :: VarValue b) = do
+fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a
+fromConstValue stack name (VarValue _ args value :: VarValue b) = do
maybe (fail err) return $ do
guard $ anull args
- cast $ value sline mempty
+ cast $ value stack mempty
where
err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ",
if anull args then textExprType @b Proxy else "function type" ]
-fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a
-fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
+fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a
+fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
maybe (fail err) return $ do
guard $ anull args
- cast $ value sline mempty
+ cast $ value stack mempty
where
err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ",
if anull args then textExprType @b Proxy else "function type" ]
-textSomeVarValue :: SourceLine -> SomeVarValue -> Text
-textSomeVarValue sline (SomeVarValue (VarValue _ args value))
- | anull args = textExprValue $ value sline mempty
+textSomeVarValue :: SomeVarValue -> Text
+textSomeVarValue (SomeVarValue (VarValue _ args value))
+ | anull args = textExprValue $ value (CallStack []) mempty
| otherwise = "<function>"
someVarValueType :: SomeVarValue -> SomeExprType
@@ -356,10 +361,10 @@ exprArgs = \case
App {} -> error "exprArgs: app"
Undefined {} -> error "exprArgs: undefined"
-funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a)
-funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
+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 sline)
+ 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 ]
@@ -377,6 +382,11 @@ data Traced a = Traced EvalTrace a
type VarNameSelectors = ( FqVarName, [ Text ] )
type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
+newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ]
+
+instance ExprType CallStack where
+ textExprType _ = T.pack "callstack"
+ textExprValue _ = T.pack "<callstack>"
gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
gatherVars = fmap (uniqOn fst . sortOn fst) . helper
@@ -385,17 +395,21 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
helper = \case
Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Variable _ var
- | isInternalVar var -> return []
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ DynVariable _ _ var
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ FunVariable _ _ var
+ | GlobalVarName {} <- 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 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
+ FunctionEval _ efun -> helper efun
LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Pure _ -> return []
e@(App (AnnRecord sel) _ x)
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
index 20a92b4..810b0c8 100644
--- a/src/Script/Expr/Class.hs
+++ b/src/Script/Expr/Class.hs
@@ -39,6 +39,10 @@ data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (P
data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
+instance ExprType () where
+ textExprType _ = "Unit"
+ textExprValue () = "()"
+
instance ExprType Integer where
textExprType _ = T.pack "integer"
textExprValue x = T.pack (show x)
@@ -75,3 +79,13 @@ instance ExprType a => ExprType [a] where
textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"
exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
+
+instance ExprType a => ExprType (Maybe a) where
+ textExprType _ = textExprType @a Proxy <> "?"
+ textExprValue (Just x) = textExprValue x
+ textExprValue Nothing = "Nothing"
+
+instance (ExprType a, ExprType b) => ExprType (Either a b) where
+ textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy
+ textExprValue (Left x) = "Left " <> textExprValue x
+ textExprValue (Right x) = "Right " <> textExprValue x
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..7e60f80
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,53 @@
+module Script.Object (
+ ObjectId(..),
+ ObjectType(..),
+ Object(..), SomeObject(..),
+ toSomeObject, fromSomeObject,
+ destroySomeObject,
+) where
+
+import Data.Kind
+import Data.Text (Text)
+import Data.Typeable
+
+import Script.Expr.Class
+
+
+newtype ObjectId = ObjectId Int
+
+class Typeable a => ObjectType m a where
+ type ConstructorArgs a :: Type
+ type ConstructorArgs a = ()
+
+ textObjectType :: proxy (m a) -> proxy a -> Text
+ textObjectValue :: proxy (m a) -> a -> Text
+
+ createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
+ destroyObject :: Object m a -> m ()
+
+instance (Typeable m, ObjectType m a) => ExprType (Object m a) where
+ textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a)
+ textExprValue = textObjectValue (Proxy @(m a)) . objImpl
+
+
+data Object m a = ObjectType m a => Object
+ { objId :: ObjectId
+ , objImpl :: a
+ }
+
+data SomeObject m = forall a. ObjectType m a => SomeObject
+ { sobjId :: ObjectId
+ , sobjImpl :: a
+ }
+
+toSomeObject :: Object m a -> SomeObject m
+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }
+
+fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)
+fromSomeObject SomeObject {..} = do
+ let objId = sobjId
+ objImpl <- cast sobjImpl
+ return Object {..}
+
+destroySomeObject :: SomeObject m -> m ()
+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index 60ec929..d53fe2e 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -1,6 +1,9 @@
module Script.Shell (
- ShellStatement(..),
ShellScript(..),
+ ShellStatement(ShellStatement),
+ ShellPipeline(ShellPipeline),
+ ShellCommand(ShellCommand),
+ ShellArgument(..),
withShellProcess,
) where
@@ -11,69 +14,174 @@ import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Reader
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
-import Data.Text.IO qualified as T
+
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Foreign.Storable
import System.Exit
import System.IO
+import System.Posix.IO qualified as P
+import System.Posix.Process
+import System.Posix.Types
import System.Process hiding (ShellCommand)
import Network
+import Network.Ip
import Output
import Process
import Run.Monad
+import Script.Expr.Class
+import Script.Var
+
+newtype ShellScript = ShellScript [ ShellStatement ]
data ShellStatement = ShellStatement
- { shellCommand :: Text
- , shellArguments :: [ Text ]
+ { shellPipeline :: ShellPipeline
+ , shellSourceLine :: SourceLine
}
-newtype ShellScript = ShellScript [ ShellStatement ]
+data ShellPipeline = ShellPipeline
+ { pipeCommand :: ShellCommand
+ , pipeUpstream :: Maybe ShellPipeline
+ }
+
+data ShellCommand = ShellCommand
+ { cmdCommand :: Text
+ , cmdExtArguments :: [ ShellArgument ]
+ , cmdSourceLine :: SourceLine
+ }
+
+data ShellArgument
+ = ShellArgument Text
+
+cmdArguments :: ShellCommand -> [ Text ]
+cmdArguments = catMaybes . map (\case ShellArgument x -> Just x) . cmdExtArguments
+
+instance ExprType ShellScript where
+ textExprType _ = T.pack "ShellScript"
+ textExprValue _ = "<shell-script>"
+
+instance ExprType ShellStatement where
+ textExprType _ = T.pack "ShellStatement"
+ textExprValue _ = "<shell-statement>"
+instance ExprType ShellPipeline where
+ textExprType _ = T.pack "ShellPipeline"
+ textExprValue _ = "<shell-pipeline>"
-executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
-executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do
- forM_ statements $ \ShellStatement {..} -> case shellCommand of
- "echo" -> liftIO $ do
- T.hPutStrLn pstdout $ T.intercalate " " shellArguments
- hFlush pstdout
- cmd -> do
- (_, _, _, phandle) <- liftIO $ createProcess_ "shell"
- (proc (T.unpack cmd) (map T.unpack shellArguments))
- { std_in = UseHandle pstdin
- , std_out = UseHandle pstdout
- , std_err = UseHandle pstderr
- , cwd = Just (nodeDir node)
- , env = Just []
- }
- liftIO (waitForProcess phandle) >>= \case
- ExitSuccess -> return ()
- ExitFailure code -> do
- outLine OutputChildFail (Just $ textProcName pname) $ T.pack $ "exit code: " ++ show code
- throwError Failed
+instance ExprType ShellCommand where
+ textExprType _ = T.pack "ShellCommand"
+ textExprValue _ = "<shell-command>"
+
+instance ExprType ShellArgument where
+ textExprType _ = T.pack "ShellArgument"
+ textExprValue _ = "<shell-argument>"
+
+
+data ShellExecInfo = ShellExecInfo
+ { seiNode :: Node
+ , seiProcName :: ProcName
+ , seiStatusVar :: MVar ExitCode
+ }
+
+
+data HandleHandling
+ = CloseHandle Handle
+ | KeepHandle Handle
+
+closeIfRequested :: MonadIO m => HandleHandling -> m ()
+closeIfRequested (CloseHandle h) = liftIO $ hClose h
+closeIfRequested (KeepHandle _) = return ()
+
+handledHandle :: HandleHandling -> Handle
+handledHandle (CloseHandle h) = h
+handledHandle (KeepHandle h) = h
+
+
+executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ()
+executeCommand ShellExecInfo {..} pstdin pstdout pstderr scmd@ShellCommand {..} = do
+ let args = cmdArguments scmd
+ pid <- liftIO $ do
+ (_, _, _, phandle) <- createProcess_ "shell"
+ (proc (T.unpack cmdCommand) (map T.unpack args))
+ { std_in = UseHandle $ handledHandle pstdin
+ , std_out = UseHandle $ handledHandle pstdout
+ , std_err = UseHandle $ handledHandle pstderr
+ , cwd = Just (nodeDir seiNode)
+ , env = Just []
+ }
+ Just pid <- getPid phandle
+ return pid
+
+ mapM_ closeIfRequested [ pstdin, pstdout, pstderr ]
+ liftIO (getProcessStatus True False pid) >>= \case
+ Just (Exited ExitSuccess) -> do
+ return ()
+ Just (Exited status) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar status
+ throwError Failed
+ Just (Terminated sig _) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))
+ throwError Failed
+ Just (Stopped sig) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))
+ throwError Failed
+ Nothing -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status"
+ liftIO $ putMVar seiStatusVar (ExitFailure (- 1))
+ throwError Failed
+
+executePipeline :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ()
+executePipeline sei pstdin pstdout pstderr ShellPipeline {..} = do
+ case pipeUpstream of
+ Nothing -> do
+ executeCommand sei pstdin pstdout pstderr pipeCommand
+
+ Just upstream -> do
+ ( pipeRead, pipeWrite ) <- createPipeCloexec
+ void $ forkTestUsing forkOS $ do
+ executePipeline sei pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream
+
+ executeCommand sei (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand
+ closeIfRequested pstderr
+
+executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do
+ setNetworkNamespace $ getNetns seiNode
+ forM_ statements $ \ShellStatement {..} -> do
+ executePipeline sei (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline
+ liftIO $ putMVar seiStatusVar ExitSuccess
spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
spawnShell procNode procName script = do
procOutput <- liftIO $ newTVarIO []
- statusVar <- liftIO $ newEmptyMVar
- ( pstdin, procStdin ) <- liftIO $ createPipe
- ( hout, pstdout ) <- liftIO $ createPipe
- ( herr, pstderr ) <- liftIO $ createPipe
- procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do
- executeScript procNode procName pstdin pstdout pstderr script
- liftIO $ putMVar statusVar ExitSuccess
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
+ seiStatusVar <- liftIO $ newEmptyMVar
+ ( pstdin, procStdin ) <- createPipeCloexec
+ ( hout, pstdout ) <- createPipeCloexec
+ ( herr, pstderr ) <- createPipeCloexec
+ procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do
+ let seiNode = procNode
+ seiProcName = procName
+ executeScript ShellExecInfo {..} pstdin pstdout pstderr script
+ liftIO $ do
+ hClose pstdin
+ hClose pstdout
+ hClose pstderr
let procKillWith = Nothing
let process = Process {..}
- void $ forkTest $ lineReadingLoop process hout $ \line -> do
- outProc OutputChildStdout process line
- liftIO $ atomically $ modifyTVar procOutput (++ [ line ])
- void $ forkTest $ lineReadingLoop process herr $ \line -> do
- outProc OutputChildStderr process line
-
+ startProcessIOLoops process hout herr
return process
withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
@@ -85,5 +193,19 @@ withShellProcess node pname script inner = do
inner process `finally` do
ps <- liftIO $ takeMVar procVar
- closeProcess process `finally` do
+ closeTestProcess process `finally` do
liftIO $ putMVar procVar $ filter (/=process) ps
+
+
+foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt
+
+createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle )
+createPipeCloexec = liftIO $ do
+ allocaArray 2 $ \ptr -> do
+ c_pipe_cloexec ptr >>= \case
+ 0 -> do
+ rh <- P.fdToHandle =<< peekElemOff ptr 0
+ wh <- P.fdToHandle =<< peekElemOff ptr 1
+ return ( rh, wh )
+ _ -> do
+ fail $ "failed to create pipe"
diff --git a/src/Script/Var.hs b/src/Script/Var.hs
index 668060c..2c50101 100644
--- a/src/Script/Var.hs
+++ b/src/Script/Var.hs
@@ -9,6 +9,8 @@ module Script.Var (
import Data.Text (Text)
import Data.Text qualified as T
+import Script.Expr.Class
+
newtype VarName = VarName Text
deriving (Eq, Ord)
@@ -40,6 +42,10 @@ unqualifyName (LocalVarName name) = name
newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
deriving (Eq, Ord)
+instance ExprType a => ExprType (TypedVarName a) where
+ textExprType _ = "TypedVarName"
+ textExprValue = textVarName . fromTypedVarName
+
newtype ModuleName = ModuleName [ Text ]
deriving (Eq, Ord, Show)
@@ -54,3 +60,7 @@ data SourceLine
textSourceLine :: SourceLine -> Text
textSourceLine (SourceLine text) = text
textSourceLine SourceLineBuiltin = "<builtin>"
+
+instance ExprType SourceLine where
+ textExprType _ = "SourceLine"
+ textExprValue = textSourceLine
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-17 00:09:47 +0000