shell-monad 0.3.1 → 0.4.0

raw patch · 7 files changed

+177/−58 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +9/−0
• Control/Monad/Shell.hs +135/−47
• TODO +0/−1
• examples/fib.hs +22/−0
• examples/protocol.hs +7/−7
• examples/santa.hs +1/−1
• shell-monad.cabal +3/−2

@@ -1,3 +1,12 @@+shell-monad (0.4.0) unstable; urgency=medium++  * Var now has a phantom type. This allows the haskell type checker+    to type check untyped shell variables!+  * added Arith+  * Really fix stopOnFailure. Strings. So easy to typo three times.++ -- Joey Hess <id@joeyh.name>  Sat, 27 Dec 2014 10:38:13 -0400+ shell-monad (0.3.1) unstable; urgency=medium    * Fixed linear rendering of caseOf

@@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}  module Control.Monad.Shell ( 	-- * Core@@ -63,6 +64,8 @@ 	stopOnFailure, 	ignoreFailure, 	errUnlessVar,+	-- * Shell Arithmetic Expressions+	Arith(..), 	-- * Misc 	comment, 	readVar,@@ -76,21 +79,27 @@ import System.Posix.Types (Fd) import System.Posix.IO (stdInput, stdOutput, stdError) --- | A shell variable.-data Var = Var+-- | A shell variable, with an associated phantom type.+newtype Var a = Var UntypedVar++data UntypedVar = V 	{ varName :: VarName 	, expandVar :: Env -> VarName -> Quoted L.Text 	} +-- | Casts from any type of Var to any other type. Use with caution!+castVar :: forall a b. Var a -> Var b+castVar (Var v) = Var v+ newtype VarName = VarName L.Text 	deriving (Eq, Ord, Show) -simpleVar :: VarName -> Var-simpleVar name = Var+simpleVar :: forall a. VarName -> Var a+simpleVar name = Var $ V 	{ varName = name 	-- Used to expand the variable; can be overridden for other 	-- types of variable expansion.-	, expandVar = \_ (VarName n) -> Q ("\"$" <> n <> "\"")+	, expandVar = \_ (VarName n) -> Q ("$" <> n) 	}  -- | A value that is safely quoted.@@ -336,12 +345,15 @@  -- | Var arguments cause the (quoted) value of a shell variable to be -- passed to the command.-instance Param Var where-	toTextParam v = \env -> getQ $ expandVar v env (varName v)+instance Param UntypedVar where+	toTextParam v = \env -> "\"" <> getQ (expandVar v env (varName v)) <> "\"" +instance Param (Var a) where+	toTextParam (Var v) = toTextParam v+ -- | Allows modifying the value of a shell variable before it is passed to -- the command.-instance Param WithVar where+instance Param (WithVar a) where 	toTextParam (WithVar v f) = getQ . f . Q . toTextParam v  -- | Quoted Text arguments are passed as-is.@@ -354,6 +366,12 @@ 		let t = toLinearScript $ fst $ runScript env s 		in "\"$(" <> t <> ")\"" +-- | Allows passing an Arithmetic Expression as a parameter.+instance Param Arith where+	toTextParam a = \env -> +		let t = fmtArith env a+		in "\"$((" <> t <> "))\""+ -- | Allows a function to take any number of Params. class CmdParams t where 	cmdAll :: (Env -> L.Text) -> [Env -> L.Text] -> t@@ -383,7 +401,7 @@ -- 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)+data WithVar a = WithVar (Var a) (Quoted L.Text -> Quoted L.Text)  -- | Adds an Expr to the script. add :: Expr -> Script ()@@ -420,25 +438,26 @@ -- -- The namehint can influence this name, but is modified to ensure -- uniqueness.-newVar :: (NameHinted namehint) => namehint -> Script Var+newVar :: (NameHinted namehint) => forall a. namehint -> Script (Var a) newVar = newVarContaining ""  -- | Creates a new shell variable, with an initial value.-newVarContaining :: (NameHinted namehint) => L.Text -> namehint -> Script Var+newVarContaining :: (NameHinted namehint) => forall a. L.Text -> namehint -> Script (Var a) newVarContaining value = hinted $ \namehint -> do-	v@(Var { varName = VarName name }) <- newVarUnsafe namehint+	v@(Var (V { 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 -> +setVar :: Param param => forall a. Var a -> param -> Script ()+setVar (Var (V { 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 :: forall a. L.Text -> Script (Var a) globalVar name = Script $ \env ->-	let v = simpleVar (VarName name)-	in ([], modifyEnvVars env (S.insert (varName v)), v)+	let v@(Var 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.@@ -447,7 +466,7 @@ -- func. -- -- (This is `$@` in shell)-positionalParameters :: Var+positionalParameters :: forall a. Var a positionalParameters = simpleVar (VarName "@")  -- | Takes the first positional parameter, removing it from@@ -462,9 +481,10 @@ -- > removefirstfile = script $ do -- >   cmd "rm" =<< takeParameter -- >   cmd "echo" "remaining parameters:" positionalParameters-takeParameter :: (NameHinted namehint) => namehint -> Script Var+takeParameter :: (NameHinted namehint) => forall a. namehint -> Script (Var a) takeParameter = hinted $ \namehint -> do-	p@(Var { varName = VarName name}) <- newVarUnsafe namehint+	p@(Var (V { varName = VarName name}))+		<- newVarUnsafe namehint 	Script $ \env -> ([Cmd (name <> "=\"$1\""), Cmd "shift"], env, p)  @@ -472,50 +492,52 @@ -- 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 :: (NameHinted namehint) => forall a. namehint -> Script (Var a) newVarUnsafe = hinted $ \namehint -> Script $ \env ->-	let v = go namehint env (0 :: Integer)-	in ([], modifyEnvVars env (S.insert (varName v)), v)+	let v@(Var 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) =+		| S.member (varName v') (envVars env) = 			go namehint env (succ x) 		| otherwise = v 	  where-		v = simpleVar $ VarName $ "_"+		v@(Var 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 :: forall a b. Var a -> (L.Text -> Env -> L.Text) -> Script (Var b)+modVar (Var (V { varName = VarName varname })) p = do+	(Var v) <- newVarUnsafe (NamedLike varname)+	return $ Var $ 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+modVar' :: (Param param) => forall a b. L.Text -> Var a -> param -> Script (Var b)+modVar' t v p = castVar <$> go+   where+	go = 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 :: (Param param) => forall a. Var a -> param -> Script (Var a) 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 :: (Param param) => forall a. Var a -> param -> Script (Var a) 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 :: (Param param) => forall a. Var a -> param -> Script (Var a) errUnlessVar = modVar' ":?"  -- | Generates a new Var, which expands to the length of the@@ -523,7 +545,7 @@ -- -- Note that 'lengthVar positionalParameters' expands to the number -- of positional parameters.-lengthVar :: Var -> Script Var+lengthVar :: forall a. Var a -> Script (Var Int) -- 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.@@ -531,13 +553,13 @@ -- ${_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 })+lengthVar v@(Var (V { varName = VarName varname })) 	| varname /= "@" = do-		tmpvar <- newVar (NamedLike "tmp")+		tmpvar@(Var tmpvar') <- newVar (NamedLike "tmp") 		modVar tmpvar $ \tmpname env -> 			let hack = do 				setVar tmpvar v-				cmd ("echo" :: L.Text) $ tmpvar+				cmd ("echo" :: L.Text) $ Var $ tmpvar' 					{ expandVar = \_ _ -> Q $ 						"${#" <> tmpname <> "}" 					}@@ -552,7 +574,10 @@ -- 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+--+-- The act of trimming a Var is assumed to be able to produce a new+-- Var holding a different data type.+trimVar :: forall a. Greediness -> Direction -> Var String -> Quoted L.Text -> Script (Var a) trimVar ShortestMatch FromBeginning = modVar' "#" trimVar LongestMatch FromBeginning = modVar' "##" trimVar ShortestMatch FromEnd = modVar' "%"@@ -616,9 +641,9 @@ -- (using the IFS) -- -- The action is run for each part, passed a Var containing the part.-forCmd :: Script () -> (Var -> Script ()) -> Script ()+forCmd :: forall a. Script () -> (Var a -> Script ()) -> Script () forCmd c a = do-	v@(Var { varName = VarName varname}) <- newVarUnsafe (NamedLike "x")+	v@(Var (V { varName = VarName varname})) <- newVarUnsafe (NamedLike "x") 	s <- toLinearScript <$> runM c 	add $ Cmd $ "for " <> varname <> " in $(" <> s <> ")" 	block "do" (a v)@@ -670,7 +695,7 @@ -- | 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 :: forall a. Var a -> [(Quoted L.Text, Script ())] -> Script () caseOf _ [] = return () caseOf v l = go True l   where@@ -704,15 +729,15 @@ 	mapM_ (add . indent) =<< runM s  -- | Generates shell code to fill a variable with a line read from stdin.-readVar :: Var -> Script ()-readVar (Var { varName = VarName varname }) = add $+readVar :: Var String -> Script ()+readVar (Var (V { 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 "+") <> "e"  -- | Makes a nonzero exit status be ignored. ignoreFailure :: Script () -> Script ()@@ -819,3 +844,66 @@ -- | Provides the Text as input to the Script, using a here-document. hereDocument :: Script () -> L.Text -> Script () hereDocument s t = redir s (RedirHereDoc t)++-- | This data type represents shell Arithmetic Expressions.+--+-- Note that in shell arithmetic, expressions that would evaluate to a+-- Bool, such as ANot and AEqual instead evaluate to 1 for True and 0 for+-- False.+data Arith+	= ANum Integer+	| AVar (Var Integer)+	| ANegate Arith -- ^ negation+	| APlus Arith Arith -- ^ '+'+	| AMinus Arith Arith -- ^ '-'+	| AMult Arith Arith -- ^ '*'+	| ADiv Arith Arith -- ^ '/'+	| AMod Arith Arith -- ^ 'mod'+	| ANot Arith -- ^ 'not'+	| AOr Arith Arith -- ^ 'or'+	| AAnd Arith Arith -- ^ 'and'+	| AEqual Arith Arith -- ^ '=='+	| ANotEqual Arith Arith -- ^ '/='+	| ALT Arith Arith -- ^ '<'+	| AGT Arith Arith -- ^ '>'+	| ALE Arith Arith -- ^ '<='+	| AGE Arith Arith -- ^ '>='+	| ABitOr Arith Arith -- ^ OR of the bits of the two arguments+	| ABitXOr Arith Arith -- ^ XOR of the bits of the two arguments+	| ABitAnd Arith Arith -- ^ AND of the bits of the two arguments+	| AShiftLeft Arith Arith -- ^ shift left (first argument's bits are shifted by the value of the second argument)+	| AShiftRight Arith Arith -- ^ shift right+	| ACond Arith Arith Arith -- ^ if the first argument is non-zero, the result is the second, else the result is the third++fmtArith :: Env -> Arith -> L.Text+fmtArith env = go+  where+	go (ANum i) = L.pack (show i)+	-- shell variable must be expanded without quotes+	go (AVar (Var v)) = getQ $ expandVar v env (varName v)+	go (ANegate v) = unop "-" v+	go (APlus a b) = binop a "+" b+	go (AMinus a b) = binop a "-" b+	go (AMult a b) = binop a "*" b+	go (ADiv a b) = binop a "/" b+	go (AMod a b) = binop a "%" b+	go (ANot v) = unop "!" v+	go (AOr a b) = binop a "||" b+	go (AAnd a b) = binop a "&&" b+	go (AEqual a b) = binop a "==" b+	go (ANotEqual a b) = binop a "!=" b+	go (ALT a b) = binop a "<" b+	go (AGT a b) = binop a ">" b+	go (ALE a b) = binop a "<=" b+	go (AGE a b) = binop a ">=" b+	go (ABitOr a b) = binop a "|" b+	go (ABitXOr a b) = binop a "^" b+	go (ABitAnd a b) = binop a "&" b+	go (AShiftLeft a b) = binop a "<<" b+	go (AShiftRight a b) = binop a ">>" b+	go (ACond c a b) = paren $ go c <> " ? " <> go a <> " : " <> go b++	paren t = "(" <> t <> ")"++	binop a o b = paren $ go a <> " " <> o <> " " <> go b+	unop o v = paren $ o <> " " <> go v

@@ -1,2 +1,1 @@-* shell arithmetic * nicer interface for the `test` command (aka `[`)

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-}+{-# 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 Data.Monoid+default (T.Text)++main :: IO ()+main = T.writeFile "fib.sh" $ script $+	takeParameter () >>= fib >>= cmd "echo"++fib :: Var Integer -> Script (Var Integer)+fib n = do+	prev <- new1+	acc <- new1+	forCmd (cmd "seq" prev n) $ \_ -> do+		setVar acc (AVar acc `APlus` AVar prev)+		setVar prev (AVar acc `AMinus` AVar prev)+	return acc+  where+	new1 = newVarContaining "1" () :: Script (Var Integer)

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, MultiParamTypeClasses, FlexibleInstances, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} import Control.Monad.Shell import qualified Data.Text.Lazy as T@@ -27,7 +27,7 @@ instance InputsProto IO Proto where 	input = toProto <$> readLn -instance InputsProto Script Var where+instance InputsProto Script (Var String) where 	input = do 		v <- newVar () 		readVar v@@ -66,7 +66,7 @@ 		| otherwise -> error $ "unknown protocol command: " ++ w 	(_, _) -> error "protocol splitting error" -handleProto :: Var -> Script ()+handleProto :: Var String -> Script () handleProto v = do 	w <- getProtoCommand v 	caseOf w@@ -79,20 +79,20 @@ 		  ) 		] -handleFoo :: Var -> Script ()+handleFoo :: Var String -> 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 :: Var Int -> Script () handleBaz num = forCmd (cmd "seq" (Val (1 :: Int)) num) $ 	toStderr . cmd "echo" "yay, I got a Baz" -getProtoCommand :: Var -> Script Var+getProtoCommand :: Var String -> Script (Var String) getProtoCommand v = trimVar LongestMatch FromEnd v (glob " *") -getProtoRest :: Var -> Script Var+getProtoRest :: forall t. Var String -> Script (Var t) getProtoRest v = trimVar ShortestMatch FromBeginning v (glob "[! ]*[ ]")  main :: IO ()

@@ -29,7 +29,7 @@ pipeLess :: Script () -> Script () pipeLess c = c -|- cmd "less" -promptFor :: T.Text -> T.Text -> (Var -> Script ()) -> Script ()+promptFor :: T.Text -> T.Text -> (Var String -> Script ()) -> Script () promptFor prompt defaultname cont = do 	cmd "printf" (prompt <> " ") 	var <- newVar (NamedLike prompt)

@@ -1,5 +1,5 @@ Name: shell-monad-Version: 0.3.1+Version: 0.4.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -17,6 +17,7 @@   TODO   examples/santa.hs   examples/protocol.hs+  examples/fib.hs  Library   GHC-Options: -Wall@@ -25,4 +26,4 @@  source-repository head   type: git-  location: git://git.kitenet.net/shell-monad.git+  location: git://git.joeyh.name/shell-monad.git