shell-monad 0.2.1 → 0.3.0

raw patch · 6 files changed

+329/−57 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +12/−0
• Control/Monad/Shell.hs +210/−49
• TODO +0/−1
• examples/protocol.hs +99/−0
• examples/santa.hs +6/−6
• shell-monad.cabal +2/−1

@@ -1,3 +1,15 @@+shell-monad (0.3.0) unstable; urgency=medium++  * Renamed a few operators.+  * Added defaultVar, whenVar, lengthVar, and trimVar.+  * Due to changes in how variable expansion is handled, the val function+    has been removed, and WithVar should be used instead.+  * newVar now ensures that the variable starts out empty.+  * Added caseOf+  * Fix bug in stopOnFailure.++ -- Joey Hess <id@joeyh.name>  Fri, 26 Dec 2014 22:58:56 -0400+ shell-monad (0.2.1) unstable; urgency=medium    * Simple support for globs.

@@ -7,49 +7,65 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Control.Monad.Shell (+	-- * Core 	Script, 	script, 	linearScript, 	Var,-	val, 	Quoted, 	quote, 	glob,+	-- * Running commands 	run, 	cmd, 	Param, 	CmdParams, 	Output(..), 	Val(..),-	comment,+	-- * Shell variables 	NamedLike(..), 	NameHinted, 	newVar, 	newVarContaining,+	setVar, 	globalVar, 	positionalParameters, 	takeParameter,+	defaultVar,+	whenVar,+	lengthVar,+	trimVar,+	Greediness(..),+	Direction(..),+	WithVar(..),+	-- * Monadic combinators 	func, 	forCmd, 	whileCmd, 	ifCmd, 	whenCmd, 	unlessCmd,-	readVar,-	stopOnFailure,-	ignoreFailure,+	caseOf, 	(-|-), 	(-&&-), 	(-||-),+	-- * Redirection 	RedirFile, 	(|>), 	(|>>), 	(|<), 	toStderr,-	(|>&),-	(|<&),-	(->-),+	(>&),+	(<&),+	(&), 	hereDocument,+	-- * Error handling+	stopOnFailure,+	ignoreFailure,+	errUnlessVar,+	-- * Misc+	comment,+	readVar, ) where  import qualified Data.Text.Lazy as L@@ -61,12 +77,21 @@ import System.Posix.IO (stdInput, stdOutput, stdError)  -- | A shell variable.-newtype Var = Var L.Text+data Var = Var+	{ varName :: VarName+	, expandVar :: Env -> VarName -> Quoted L.Text+	}++newtype VarName = VarName L.Text 	deriving (Eq, Ord, Show) --- | Expand a shell variable to its value.-val :: Var -> Quoted L.Text-val (Var v) = Q ("\"$" <> v <> "\"")+simpleVar :: VarName -> Var+simpleVar name = Var+	{ varName = name+	-- Used to expand the variable; can be overridden for other+	-- types of variable expansion.+	, expandVar = \_ (VarName n) -> Q ("\"$" <> n <> "\"")+	}  -- | A value that is safely quoted. newtype Quoted a = Q { getQ :: a }@@ -79,7 +104,7 @@ -- like csh. quote :: L.Text -> Quoted L.Text quote t-	| L.all (isAlphaNum) t = Q t+	| L.all (\c -> isAlphaNum c || c == '_') t = Q t 	| otherwise = Q $ q <> L.intercalate "'\"'\"'" (L.splitOn q t) <> q   where 	q = "'"@@ -148,7 +173,7 @@ -- | Environment built up by the shell script monad, -- so it knows which environment variables and functions are in use. data Env = Env-	{ envVars :: S.Set Var+	{ envVars :: S.Set VarName 	, envFuncs :: S.Set Func 	} @@ -156,7 +181,7 @@ 	mempty = Env mempty mempty 	mappend a b = Env (envVars a <> envVars b) (envFuncs a <> envFuncs b) -modifyEnvVars :: Env -> (S.Set Var -> S.Set Var) -> Env+modifyEnvVars :: Env -> (S.Set VarName -> S.Set VarName) -> Env modifyEnvVars env f = env { envVars = f (envVars env) }  modifyEnvFuncs :: Env -> (S.Set Func -> S.Set Func) -> Env@@ -216,8 +241,11 @@ 			use $ redirFd fd1 (Just stdInput) <> "<&" <> showFd fd2 		(RedirHereDoc t) 			| multiline -> -				let marker = eofMarker t-				in use $ "<<" <> marker <> "\n" <> t <> "\n" <> marker+				let myEOF = eofMarker t+				in use $ "<<" <> myEOF <> "\n"+					<> t +					<> "\n" +					<> myEOF 			-- Here documents cannot be represented in a single 			-- line script. Instead, generate: 			-- (echo l1; echo l2; ...) | cmd@@ -309,8 +337,13 @@ -- | Var arguments cause the (quoted) value of a shell variable to be -- passed to the command. instance Param Var where-	toTextParam = toTextParam . val+	toTextParam v = \env -> getQ $ expandVar v env (varName v) +-- | Allows modifying the value of a shell variable before it is passed to+-- the command.+instance Param WithVar where+	toTextParam (WithVar v f) = getQ . f . Q . toTextParam v+ -- | Quoted Text arguments are passed as-is. instance Param (Quoted L.Text) where 	toTextParam (Q v) = const v@@ -345,6 +378,13 @@ -- | An arbitrary value. newtype Val v = Val v +-- | Allows modifying the value of a variable before it is passed to a+-- command. The function is passed a Quoted Text which will expand to the+-- value of the variable, and can modify it, by using eg 'mappend'.+--+-- > cmd "rmdir" (WithVar name ("/home/" <>))+data WithVar = WithVar Var (Quoted L.Text -> Quoted L.Text)+ -- | Adds an Expr to the script. add :: Expr -> Script () add expr = Script $ \env -> ([expr], env, ())@@ -374,36 +414,31 @@ instance NameHinted (Maybe L.Text) where 	hinted = id --- | Defines a new shell variable.+-- | Defines a new shell variable, which starts out not being set. -- -- Each call to newVar will generate a new, unique variable name. -- -- The namehint can influence this name, but is modified to ensure -- uniqueness. newVar :: (NameHinted namehint) => namehint -> Script Var-newVar = hinted $ \namehint -> Script $ \env ->-	let v = go namehint env (0 :: Integer)-	in ([], modifyEnvVars env (S.insert v), v)-  where-	go namehint env x-		| S.member v (envVars env) = go namehint env (succ x)-		| otherwise = v-	  where-		v = Var $ "_"-			<> genvarname namehint-			<> if x == 0 then "" else L.pack (show (x + 1))-	-	genvarname = maybe "v" (L.filter isAlpha)+newVar = newVarContaining ""  -- | Creates a new shell variable, with an initial value. newVarContaining :: (NameHinted namehint) => L.Text -> namehint -> Script Var newVarContaining value = hinted $ \namehint -> do-	v@(Var name) <- newVar namehint+	v@(Var { varName = VarName name }) <- newVarUnsafe namehint 	Script $ \env -> ([Cmd (name <> "=" <> getQ (quote value))], env, v) +-- | Sets the Var to the value of the param. +setVar :: Param param => Var -> param -> Script ()+setVar (Var { varName = VarName name }) p = Script $ \env -> +	([Cmd (name <> "=" <> toTextParam p env)], env, ())+ -- | Gets a Var that refers to a global variable, such as PATH globalVar :: L.Text -> Script Var-globalVar name = Script $ \env -> let v = Var name in ([], modifyEnvVars env (S.insert v), v)+globalVar name = Script $ \env ->+	let v = simpleVar (VarName name)+	in ([], modifyEnvVars env (S.insert (varName v)), v)  -- | This special Var expands to whatever parameters were passed to the -- shell script.@@ -413,7 +448,7 @@ -- -- (This is `$@` in shell) positionalParameters :: Var-positionalParameters = Var "@"+positionalParameters = simpleVar (VarName "@")  -- | Takes the first positional parameter, removing it from -- positionalParameters and returning a new Var that holds the value of the@@ -429,9 +464,104 @@ -- >   cmd "echo" "remaining parameters:" positionalParameters takeParameter :: (NameHinted namehint) => namehint -> Script Var takeParameter = hinted $ \namehint -> do-	p@(Var name) <- newVar namehint+	p@(Var { varName = VarName name}) <- newVarUnsafe namehint 	Script $ \env -> ([Cmd (name <> "=\"$1\""), Cmd "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+-- some shell script that is guaranteed to clobber any existing value of+-- the variable.+newVarUnsafe :: (NameHinted namehint) => namehint -> Script Var+newVarUnsafe = hinted $ \namehint -> Script $ \env ->+	let v = go namehint env (0 :: Integer)+	in ([], modifyEnvVars env (S.insert (varName v)), v)+  where+	go namehint env x+		| S.member (varName v) (envVars env) =+			go namehint env (succ x)+		| otherwise = v+	  where+		v = simpleVar $ VarName $ "_"+			<> genvarname namehint+			<> if x == 0 then "" else L.pack (show (x + 1))+	+	genvarname = maybe "v" (L.filter isAlpha)++modVar :: Var -> (L.Text -> Env -> L.Text) -> Script Var+modVar (Var { varName = VarName varname }) p = do+	v <- newVarUnsafe (NamedLike varname)+	return $ v+		{ expandVar = \env _ -> Q $ "\"${" <> p varname env <> "}\""+		}++modVar' :: (Param param) => L.Text -> Var -> param -> Script Var+modVar' t v p = modVar v $ \varname env ->+	varname <> t <> toTextParam p env++-- | Generates a new Var. Expanding this Var will yield the same+-- result as expanding the input Var, unless it is empty, in which case+-- it instead defaults to the expansion of the param.+defaultVar :: (Param param) => Var -> param -> Script Var+defaultVar = modVar' ":-"++-- | Generates a new Var. If the input Var is empty, then this new Var+-- will likewise expand to the empty string. But if not, the new Var+-- expands to the param.+whenVar :: (Param param) => Var -> param -> Script Var+whenVar = modVar' ":+"++-- | Generates a new Var. If the input Var is empty then expanding this new+-- Var will cause an error to be thrown, using the param as the error+-- message. If the input Var is not empty, then the new Var expands to the+-- same thing the input Var expands to.+errUnlessVar :: (Param param) => Var -> param -> Script Var+errUnlessVar = modVar' ":?"++-- | Generates a new Var, which expands to the length of the+-- expansion of the input Var.+--+-- Note that 'lengthVar positionalParameters' expands to the number+-- of positional parameters.+lengthVar :: Var -> Script Var+-- Implementation note: ${#${foo:-bar}} is not legal shell code.+-- So, to allow taking the length of Vars that expand to such things,+-- a temporary Var is created, assigned to the expansion of the input Var.+-- This yields shell code like:+-- ${_tmp1:-$(_tmp1="${foo:-bar}"; echo ${#_tmp1})}+-- But, this approach won't work for $@, so handle it as a special+-- case.+lengthVar v@(Var { varName = VarName varname })+	| varname /= "@" = do+		tmpvar <- newVar (NamedLike "tmp")+		modVar tmpvar $ \tmpname env ->+			let hack = do+				setVar tmpvar v+				cmd ("echo" :: L.Text) $ tmpvar+					{ expandVar = \_ _ -> Q $+						"${#" <> tmpname <> "}"+					}+			in varname <> ":-" <> toTextParam (Output hack) env+	| otherwise = return $ simpleVar (VarName "#")++-- | Produces a Var that is a trimmed version of the input Var.+--+-- The Quoted Text is removed from the value of the Var, either+-- from the beginning or from the end.+--+-- If the Quoted Text was produced by 'glob', it could match in+-- multiple ways. You can choose whether to remove the shortest or+-- the longest match.+trimVar :: Greediness -> Direction -> Var -> Quoted L.Text -> Script Var+trimVar ShortestMatch FromBeginning = modVar' "#"+trimVar LongestMatch FromBeginning = modVar' "##"+trimVar ShortestMatch FromEnd = modVar' "%"+trimVar LongestMatch FromEnd = modVar' "%%"++data Greediness = ShortestMatch | LongestMatch++data Direction = FromBeginning | FromEnd+ -- | Defines a shell function, and returns an action that can be run to -- call the function. --@@ -488,9 +618,9 @@ -- The action is run for each part, passed a Var containing the part. forCmd :: Script () -> (Var -> Script ()) -> Script () forCmd c a = do-	v@(Var vname) <- newVar (NamedLike "x")+	v@(Var { varName = VarName varname}) <- newVarUnsafe (NamedLike "x") 	s <- toLinearScript <$> runM c-	add $ Cmd $ "for " <> vname <> " in $(" <> s <> ")"+	add $ Cmd $ "for " <> varname <> " in $(" <> s <> ")" 	block "do" (a v) 	add $ Cmd "done" @@ -537,6 +667,32 @@ 	ifCmd' ("! " <>) cond $ 		block "then" a +-- | Matches the value of the Var against the Quoted Text (which can+-- be generated by 'glob'), and runs the Script action associated+-- with the first match.+caseOf :: Var -> [(Quoted L.Text, Script ())] -> Script ()+caseOf _ [] = return ()+caseOf v l = go True l+  where+	-- The case expression is formatted somewhat unusually,+	-- in order to make it work in both single line and multi-line+	-- rendering.+	--+	-- > case "$foo" in ook) : +	-- >     echo got ook+	-- >     echo yay+	-- > ;; *) :+	-- >     echo default+	-- > ;; esac+	go _ [] = add $ Cmd $ ";; esac"+	go atstart ((t, s):rest) = do+		let leader = if atstart+			then "case " <> toTextParam v undefined <> " in "+			else ";; "+		add $ Cmd $ leader <> getQ t <> ") :"+		mapM_ (add . indent) =<< runM s+		go False rest+ -- | Creates a block such as "do : ; cmd ; cmd" or "else : ; cmd ; cmd" -- -- The use of : ensures that the block is not empty, and allows@@ -549,13 +705,14 @@  -- | Generates shell code to fill a variable with a line read from stdin. readVar :: Var -> Script ()-readVar (Var vname) = add $ Cmd $ "read " <> getQ (quote vname)+readVar (Var { varName = VarName varname }) = add $+	Cmd $ "read " <> getQ (quote varname)  -- | 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 "+" <> "x"+stopOnFailure b = add $ Cmd $ "set " <> (if b then "-" else "+") <> "x"  -- | Makes a nonzero exit status be ignored. ignoreFailure :: Script () -> Script ()@@ -637,23 +794,27 @@  -- | Redirects a script's output to stderr. toStderr :: Script () -> Script ()-toStderr s = s ->- stdOutput |>& stdError+toStderr s = s &stdOutput>&stdError  -- | Redirects the first file descriptor to output to the second. -- -- For example, to redirect a command's stderr to stdout: ----- > cmd "foo" ->- stdError) |>& stdOutput-(|>&) :: (Script (), Fd) -> Fd -> Script ()-(s, fd1) |>& fd2 = redir s (RedirOutput fd1 fd2)+-- > cmd "foo" &stdError>&stdOutput+(>&) :: (Script (), Fd) -> Fd -> Script ()+(s, fd1) >& fd2 = redir s (RedirOutput fd1 fd2)  -- | Redirects the first file descriptor to input from the second.-(|<&) :: (Script (), Fd) -> Fd -> Script ()-(s, fd1) |<& fd2 = redir s (RedirInput fd1 fd2)+--+-- For example, to read from Fd 42:+--+-- > cmd "foo" &stdInput<&Fd 42+(<&) :: (Script (), Fd) -> Fd -> Script ()+(s, fd1) <& fd2 = redir s (RedirInput fd1 fd2) --- | Helper for '|>&' and '|<&'-(->-) :: Script () -> Fd -> (Script (), Fd)-(->-) = (,)+-- | Helper for '>&' and '<&'+(&) :: Script () -> Fd -> (Script (), Fd)+(&) = (,)  -- | Provides the Text as input to the Script, using a here-document. hereDocument :: Script () -> L.Text -> Script ()

@@ -1,3 +1,2 @@ * shell arithmetic * nicer interface for the `test` command (aka `[`)-* ${var%foo} etc

@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+import Control.Monad.Shell+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import Control.Applicative+default (T.Text)++data Proto+	= Foo String+	| Bar+	| Baz Integer+	deriving (Show)++class Monad t => OutputsProto t where+	output :: Proto -> t ()++instance OutputsProto IO where+	output = putStrLn . fromProto++instance OutputsProto Script where+	output = cmd "echo" . fromProto++class Monad t => InputsProto t p where+	input :: t p++instance InputsProto IO Proto where+	input = toProto <$> readLn++instance InputsProto Script Var where+	input = do+		v <- newVar ()+		readVar v+		return v++protoExchangeIO :: Proto -> IO Proto+protoExchangeIO p = do+	output p+	input++foo :: Script ()+foo = do+	stopOnFailure True+	handler <- func (NamedLike "handler") $+		handleProto =<< input+	output (Foo "starting up")+	handler+	output Bar+	handler++pFOO, pBAR, pBAZ :: String+(pFOO, pBAR, pBAZ) = ("FOO", "BAR", "BAZ")++fromProto :: Proto -> String+fromProto (Foo s) = pFOO ++ " " ++ s+fromProto Bar = pBAR ++ " "+fromProto (Baz i) = pBAZ ++ " " ++ show i++-- throws exception if the string cannot be parsed+toProto :: String -> Proto+toProto s = case break (== ' ') s of+	(w, ' ':rest)+		| w == pFOO -> Foo rest+		| w == pBAR && null rest -> Bar+		| w == pBAZ -> Baz (read rest)+		| otherwise -> error $ "unknown protocol command: " ++ w+	(_, _) -> error "protocol splitting error"++handleProto :: Var -> Script ()+handleProto v = do+	w <- getProtoCommand v+	caseOf w+		[ (quote (T.pack pFOO), handleFoo =<< getProtoRest v)+		, (quote (T.pack pBAR), handleBar)+		, (quote (T.pack pBAZ), handleBaz =<< getProtoRest v)+		, (glob "*", do+			toStderr $ cmd "echo" "unknown protocol command" w+			cmd "false"+		  )+		]++handleFoo :: Var -> Script ()+handleFoo v = toStderr $ cmd "echo" "yay, I got a Foo" v++handleBar :: Script ()+handleBar = toStderr $ cmd "echo" "yay, I got a Bar"++handleBaz :: Var -> Script ()+handleBaz num = forCmd (cmd "seq" "1" num) $+	toStderr . cmd "echo" "yay, I got a Baz"++getProtoCommand :: Var -> Script Var+getProtoCommand v = trimVar LongestMatch FromEnd v (glob " *")++getProtoRest :: Var -> Script Var+getProtoRest v = trimVar ShortestMatch FromBeginning v (glob "[! ]*[ ]")++main :: IO ()+main = T.writeFile "protocol.sh" $ script foo

@@ -11,9 +11,9 @@ 	hohoho <- mkHohoho 	hohoho (Val 1) -	promptFor "What's your name?" $ \name -> pipeLess $ do-		cmd "echo" "Let's see what's in" (val name <> quote "'s") "stocking!"-		forCmd (cmd "ls" "-1" (quote "/home/" <> val name)) $ \f -> do+	promptFor "What's your name?" "virginia" $ \name -> pipeLess $ do+		cmd "echo" "Let's see what's in" (WithVar name (<> quote "'s")) "stocking!"+		forCmd (cmd "ls" "-1" (WithVar name (quote "/home/" <>))) $ \f -> do 			cmd "echo" "a shiny new" f 			hohoho (Val 1) @@ -29,9 +29,9 @@ pipeLess :: Script () -> Script () pipeLess c = c -|- cmd "less" -promptFor :: T.Text -> (Var -> Script ()) -> Script ()-promptFor prompt cont = do+promptFor :: T.Text -> T.Text -> (Var -> Script ()) -> Script ()+promptFor prompt defaultname cont = do 	cmd "printf" (prompt <> " ") 	var <- newVar (NamedLike prompt) 	readVar var-	cont var+	cont =<< defaultVar var defaultname

@@ -1,5 +1,5 @@ Name: shell-monad-Version: 0.2.1+Version: 0.3.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -16,6 +16,7 @@   CHANGELOG   TODO   examples/santa.hs+  examples/protocol.hs  Library   GHC-Options: -Wall