diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +shell-monad (0.6.8) unstable; urgency=medium + + * Added withEnv, subshell and group. + Thanks, dhivael + + -- Joey Hess Sat, 12 Jan 2019 17:11:39 -0400 + shell-monad (0.6.7) unstable; urgency=medium * Fix quoting of empty String/Text. diff --git a/Control/Monad/Shell.hs b/Control/Monad/Shell.hs --- a/Control/Monad/Shell.hs +++ b/Control/Monad/Shell.hs @@ -84,6 +84,9 @@ whenCmd, unlessCmd, caseOf, + subshell, + group, + withEnv, (-|-), (-&&-), (-||-), @@ -196,11 +199,21 @@ instance Named Func where getName (Func n) = n +type Indent = Int + +type LocalEnv = (L.Text, L.Text) + -- | A shell expression. data Expr - = Cmd L.Text -- ^ a command + = Cmd Indent [LocalEnv] L.Text + -- ^ a command. may have a local environment to be added to it + | Raw Indent L.Text + -- ^ shell code that is not able to a have a local environment added to it + | EnvWrap Indent L.Text [LocalEnv] [Expr] + -- ^ named script with a local environment to add to it | Comment L.Text -- ^ a comment | Subshell L.Text [Expr] -- ^ expressions run in a sub-shell + | Group L.Text [Expr] -- ^ expressions run in a group | Pipe Expr Expr -- ^ Piping the first Expr to the second Expr | And Expr Expr -- ^ && | Or Expr Expr -- ^ || @@ -208,9 +221,12 @@ -- | Indents an Expr indent :: Expr -> Expr -indent (Cmd t) = Cmd $ "\t" <> t +indent (Cmd i localenvs t) = Cmd (i + 1) localenvs t +indent (Raw i t) = Raw (i + 1) t +indent (EnvWrap i n localenvs e) = EnvWrap (i + 1) n localenvs (map indent e) indent (Comment t) = Comment $ "\t" <> t indent (Subshell i l) = Subshell ("\t" <> i) (map indent l) +indent (Group i l) = Group ("\t" <> i) (map indent l) indent (Pipe e1 e2) = Pipe (indent e1) (indent e2) indent (Redir e r) = Redir (indent e) r indent (And e1 e2) = And (indent e1) (indent e2) @@ -237,11 +253,11 @@ in (expr1 <> expr2, env2, f' a') instance Monad Script where - return ret = Script $ \env -> ([], env, ret) - a >>= b = Script $ \start -> let - (left, mid, v) = call a start - (right, end, ret) = call (b v) mid - in (left ++ right, end, ret) + return ret = Script $ \env -> ([], env, ret) + a >>= b = Script $ \start -> let + (left, mid, v) = call a start + (right, end, ret) = call (b v) mid + in (left ++ right, end, ret) where call :: Script f -> Env -> ([Expr], Env, f) call (Script f) = f @@ -291,7 +307,6 @@ script :: Script f -> L.Text script = flip mappend "\n" . L.intercalate "\n" . ("#!/bin/sh":) . map (fmt True) . gen - where -- | Formats an Expr to shell script. -- @@ -299,16 +314,33 @@ fmt :: Bool -> Expr -> L.Text fmt multiline = go where - go (Cmd t) = t + fmtlocalenvs = L.intercalate " " . map (\(k, v) -> k <> "=" <> v) + + go (Cmd i [] t) = L.pack (replicate i '\t') <> t + go (Cmd i localenvs t) = L.pack (replicate i '\t') <> fmtlocalenvs localenvs <> " " <> t + go (Raw i t) = L.pack (replicate i '\t') <> t + go (EnvWrap i n localenvs e) = + let (lp, sep) = if multiline + then (L.pack (replicate i '\t'), "\n") + else ("", ";") + in lp <> n <> "() { : " <> sep + <> L.intercalate sep (map (go . indent) e) <> sep + <> lp <> "}" <> sep + <> lp <> fmtlocalenvs localenvs <> " " <> n -- Comments are represented using : for two reasons: -- 1. To support single line rendering. -- 2. So that it's a valid shell expression; any -- Expr, including Comment can be combined with any other. -- For example, Pipe Comment Comment. go (Comment t) = ": " <> getQ (quote (L.filter (/= '\n') t)) + go (Subshell i []) = i <> "( : )" go (Subshell i l) = let (wrap, sep) = if multiline then ("\n", "\n") else ("", ";") in i <> "(" <> wrap <> L.intercalate sep (map (go . indent) l) <> wrap <> i <> ")" + go (Group i []) = i <> "{ :; }" + go (Group i l) = + let (wrap, sep, end) = if multiline then ("\n", "\n", "") else ("", ";", ";") + in i <> "{" <> wrap <> L.intercalate sep (map (go . indent) l) <> end <> wrap <> i <> "}" go (Pipe e1 e2) = go e1 <> " | " <> go e2 go (And e1 e2) = go e1 <> " && " <> go e2 go (Or e1 e2) = go e1 <> " || " <> go e2 @@ -335,7 +367,7 @@ -- (echo l1; echo l2; ...) | cmd | otherwise -> let heredoc = Subshell L.empty $ - flip map (L.lines t) $ \l -> Cmd $ + flip map (L.lines t) $ \l -> raw $ "echo " <> getQ (quote l) in go (Pipe heredoc e) @@ -371,8 +403,14 @@ -- | Adds a shell command to the script. run :: L.Text -> [L.Text] -> Script () -run c ps = add $ Cmd $ L.intercalate " " (map (getQ . quote) (c:ps)) +run c ps = add $ newCmd $ L.intercalate " " (map (getQ . quote) (c:ps)) +newCmd :: L.Text -> Expr +newCmd l = Cmd 0 [] l + +raw :: L.Text -> Expr +raw l = Raw 0 l + -- | Variadic and polymorphic version of 'run' -- -- A command can be passed any number of Params. @@ -453,7 +491,7 @@ instance (f ~ ()) => CmdParams (Script f) where cmdAll c acc = Script $ \env -> let ps = map (\f -> f env) (c : reverse acc) - in ([Cmd $ L.intercalate " " ps], env, ()) + in ([newCmd $ L.intercalate " " ps], env, ()) -- | The output of a command, or even a more complicated Script -- can be passed as a parameter to 'cmd' @@ -525,7 +563,7 @@ newVarContaining' :: (NameHinted namehint) => L.Text -> namehint -> Script (Term Var t) newVarContaining' value = hinted $ \namehint -> do v <- newVarUnsafe namehint - Script $ \env -> ([Cmd (getName v <> "=" <> value)], env, v) + Script $ \env -> ([raw (getName v <> "=" <> value)], env, v) -- | Creates a new shell variable with an initial value coming from any -- 'Param'. @@ -554,7 +592,7 @@ newVarFrom param namehint = do v <- newVarUnsafe namehint Script $ \env -> - ([Cmd (getName v <> "=" <> toTextParam param env)], env, v) + ([raw (getName v <> "=" <> toTextParam param env)], env, v) -- | Creates a new shell variable, with an initial value which can -- be anything that can be shown. @@ -567,7 +605,7 @@ -- | Sets the Var to the value of the param. setVar :: Param param => forall a. Term Var a -> param -> Script () setVar v p = Script $ \env -> - ([Cmd (getName v <> "=" <> toTextParam p env)], env, ()) + ([raw (getName v <> "=" <> toTextParam p env)], env, ()) -- | Gets a Var that refers to a global variable, such as PATH globalVar :: forall a. L.Text -> Script (Term Var a) @@ -600,7 +638,7 @@ takeParameter :: (NameHinted namehint) => forall a. namehint -> Script (Term Var a) takeParameter = hinted $ \namehint -> do p <- newVarUnsafe namehint - Script $ \env -> ([Cmd (getName p <> "=\"$1\""), Cmd "shift"], env, p) + Script $ \env -> ([raw (getName p <> "=\"$1\""), raw "shift"], env, p) -- | Creates a new shell variable, but does not ensure that it's not -- already set to something. For use when the caller is going to generate @@ -754,7 +792,7 @@ genfuncname = maybe "p" (L.filter isAlpha) - definefunc (Func f) ls = (Cmd $ f <> " () { :") : map indent ls ++ [ Cmd "}" ] + definefunc (Func f) ls = (raw $ f <> " () { :") : map indent ls ++ [ raw "}" ] callfunc (Func f) = cmd f @@ -766,17 +804,17 @@ forCmd c a = do v <- newVarUnsafe (NamedLike "x") s <- toLinearScript <$> runM c - add $ Cmd $ "for " <> getName v <> " in $(" <> s <> ")" + add $ raw $ "for " <> getName v <> " in $(" <> s <> ")" block "do" (a v) - add $ Cmd "done" + add $ raw "done" -- | As long as the first Script exits nonzero, runs the second script. whileCmd :: Script () -> Script () -> Script () whileCmd c a = do s <- toLinearScript <$> runM c - add $ Cmd $ "while $(" <> s <> ")" + add $ raw $ "while $(" <> s <> ")" block "do" a - add $ Cmd "done" + add $ raw "done" -- | if with a Script conditional. -- @@ -790,13 +828,14 @@ ifCmd' :: (L.Text -> L.Text) -> Script () -> Script () -> Script () ifCmd' condf cond body = do condl <- runM cond - add $ Cmd $ "if " <> condf (singleline condl) + add $ raw $ "if " <> condf (singleline condl) body - add $ Cmd "fi" + add $ raw "fi" where singleline l = let c = case l of [c'@(Cmd {})] -> c' + [c'@(Raw {})] -> c' [c'@(Subshell {})] -> c' _ -> Subshell L.empty l in toLinearScript [c] @@ -836,16 +875,45 @@ -- > : ;; *) : -- > echo default -- > : ;; esac - go _ [] = add $ Cmd ";; esac" + go _ [] = add $ raw ";; esac" go atstart ((t, s):rest) = do env <- getEnv let leader = if atstart then "case " <> toTextParam v env <> " in " else ": ;; " - add $ Cmd $ leader <> getQ t <> ") :" + add $ raw $ leader <> getQ t <> ") :" mapM_ (add . indent) =<< runM s go False rest +-- | Runs the script in a new subshell. +subshell :: Script () -> Script () +subshell s = do + e <- runM s + add $ Subshell "" e + +-- | Runs the script as a command group in the current subshell. +group :: Script () -> Script () +group s = do + e <- runM s + add $ Group "" e + +-- | Add a variable to the local environment of the script. +withEnv :: Param value => L.Text -> value -> Script () -> Script () +withEnv n v (Script f) = Script $ addEnv . f + where + -- We can only add K=V to simple commands. If the input script + -- contains anything more than one simple command we'll have to wrap + -- the script into a fresh function and call that with the + -- environment. + addEnv (e, env, _) = let localenv = (n, toTextParam v env) + in case e of + [Cmd i localenvs l] -> ([Cmd i (localenv : localenvs) l], env, ()) + [EnvWrap i envName localenvs e'] -> ([EnvWrap i envName (localenv : localenvs) e'], env, ()) + l -> ([EnvWrap 0 (getName name) [localenv] l], env', ()) + where + (Script nameFn) = newVarUnsafe' (NamedLike "envfn") + (_, env', name) = nameFn env + -- | Creates a block such as "do : ; cmd ; cmd" or "else : ; cmd ; cmd" -- -- The use of : ensures that the block is not empty, and allows @@ -853,26 +921,29 @@ -- formatting work. block :: L.Text -> Script () -> Script () block word s = do - add $ Cmd $ word <> " :" + add $ raw $ word <> " :" mapM_ (add . indent) =<< runM s -- | Fills a variable with a line read from stdin. readVar :: Term Var String -> Script () -readVar v = add $ Cmd $ "read " <> getQ (quote (getName v)) +readVar v = add $ newCmd $ "read " <> getQ (quote (getName v)) -- | By default, shell scripts continue running past commands that exit -- nonzero. Use 'stopOnFailure True' to make the script stop on the first -- such command. stopOnFailure :: Bool -> Script () -stopOnFailure b = add $ Cmd $ "set " <> (if b then "-" else "+") <> "e" +stopOnFailure b = add $ raw $ "set " <> (if b then "-" else "+") <> "e" -- | Makes a nonzero exit status be ignored. ignoreFailure :: Script () -> Script () ignoreFailure s = runM s >>= mapM_ (add . go) where - go c@(Cmd _) = Or c true + go c@(Cmd _ _ _) = Or c true + go c@(Raw _ _) = Or c true go c@(Comment _) = c + go (EnvWrap i n localenvs e) = EnvWrap i n localenvs (map go e) go (Subshell i l) = Subshell i (map go l) + go (Group i l) = Group i (map go l) -- Assumes pipefail is not set. go (Pipe e1 e2) = Pipe e1 (go e2) -- Note that in shell, a && b || true will result in true; @@ -881,7 +952,7 @@ go (Or e1 e2) = Or e1 (go e2) go (Redir e r) = Redir (go e) r - true = Cmd "true" + true = raw "true" -- | Pipes together two Scripts. (-|-) :: Script () -> Script () -> Script () @@ -978,7 +1049,7 @@ -- -- > ifCmd (test (FileExists "foo")) (foo, bar) test :: Test -> Script () -test t = Script $ \env -> ([Cmd $ "test " <> mkTest env t], env, ()) +test t = Script $ \env -> ([newCmd $ "test " <> mkTest env t], env, ()) mkTest :: Env -> Test -> L.Text mkTest env = go diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -7,3 +7,11 @@ * Allow: test (n `TEqual` 42) Perhaps by making Test an instance of Num? + +* globalVar and withEnv take a Text name of the variable, and if it's not a + legal shell variable name, can generate broken shell code. + +* The EnvWrap and Raw constructors are an ugly hack around Expr not + containing an AST for shell scripts. withEnv needs them to determine + which way to set the local environment variable. An AST would improve + the internals. diff --git a/examples/hello.hs b/examples/hello.hs --- a/examples/hello.hs +++ b/examples/hello.hs @@ -10,8 +10,3 @@ cmd "echo" "hello, world" username <- newVarFrom (Output (cmd "whoami")) () cmd "echo" "from" (WithVar username (<> "'s shell")) - - v <- globalVar "SOMEVAR" - ifCmd (test $ TStrEqual v "") - (cmd "echo" "Bad") - (cmd "echo" "Good") diff --git a/shell-monad.cabal b/shell-monad.cabal --- a/shell-monad.cabal +++ b/shell-monad.cabal @@ -1,5 +1,5 @@ Name: shell-monad -Version: 0.6.7 +Version: 0.6.8 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess