module Control.Monad.Shell (
Script,
script,
linearScript,
Var,
Val(..),
Quoted,
Quotable(..),
glob,
run,
cmd,
Param,
CmdParams,
Output(..),
NamedLike(..),
NameHinted,
newVar,
newVarContaining,
setVar,
globalVar,
positionalParameters,
takeParameter,
defaultVar,
whenVar,
lengthVar,
trimVar,
Greediness(..),
Direction(..),
WithVar(..),
func,
forCmd,
whileCmd,
ifCmd,
whenCmd,
unlessCmd,
caseOf,
(-|-),
(-&&-),
(-||-),
RedirFile,
(|>),
(|>>),
(|<),
toStderr,
(>&),
(<&),
(&),
hereDocument,
stopOnFailure,
ignoreFailure,
errUnlessVar,
Arith(..),
comment,
readVar,
) where
import qualified Data.Text.Lazy as L
import qualified Data.Set as S
import Data.Monoid
import Control.Applicative
import Data.Char
import System.Posix.Types (Fd)
import System.Posix.IO (stdInput, stdOutput, stdError)
import Control.Monad.Shell.Quote
newtype Var a = Var UntypedVar
data UntypedVar = V
{ varName :: VarName
, expandVar :: Env -> VarName -> Quoted L.Text
}
castVar :: forall a b. Var a -> Var b
castVar (Var v) = Var v
newtype VarName = VarName L.Text
deriving (Eq, Ord, Show)
simpleVar :: forall a. VarName -> Var a
simpleVar name = Var $ V
{ varName = name
, expandVar = \_ (VarName n) -> Q ("$" <> n)
}
glob :: L.Text -> Quoted L.Text
glob = Q . L.concatMap escape
where
escape c
| isAlphaNum c = L.singleton c
| c `elem` "*?[!-:]\\" = L.singleton c
| otherwise = "\\" <> L.singleton c
newtype Func = Func L.Text
deriving (Eq, Ord, Show)
data Expr
= Cmd L.Text
| Comment L.Text
| Subshell L.Text [Expr]
| Pipe Expr Expr
| And Expr Expr
| Or Expr Expr
| Redir Expr RedirSpec
indent :: Expr -> Expr
indent (Cmd t) = Cmd $ "\t" <> t
indent (Comment t) = Comment $ "\t" <> t
indent (Subshell i l) = Subshell ("\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)
indent (Or e1 e2) = Or (indent e1) (indent e2)
data RedirSpec
= RedirToFile Fd FilePath
| RedirToFileAppend Fd FilePath
| RedirFromFile Fd FilePath
| RedirOutput Fd Fd
| RedirInput Fd Fd
| RedirHereDoc L.Text
newtype Script a = Script (Env -> ([Expr], Env, a))
deriving (Functor)
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)
where
call :: Script f -> Env -> ([Expr], Env, f)
call (Script f) = f
data Env = Env
{ envVars :: S.Set VarName
, envFuncs :: S.Set Func
}
instance Monoid Env where
mempty = Env mempty mempty
mappend a b = Env (envVars a <> envVars b) (envFuncs a <> envFuncs b)
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
modifyEnvFuncs env f = env { envFuncs = f (envFuncs env) }
gen :: Script f -> [Expr]
gen = fst . runScript mempty
runScript :: Env -> Script f -> ([Expr], Env)
runScript env (Script f) = (code, env') where (code, env', _) = f env
runM :: Script () -> Script [Expr]
runM s = Script $ \env ->
let (r, env') = runScript env s
in ([], env', r)
script :: Script f -> L.Text
script = flip mappend "\n" . L.intercalate "\n" .
("#!/bin/sh":) . map (fmt True) . gen
where
fmt :: Bool -> Expr -> L.Text
fmt multiline = go
where
go (Cmd t) = t
go (Comment t)
| multiline = "# " <> L.filter (/= '\n') t
| otherwise = ": " <> getQ (quote (L.filter (/= '\n') t))
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 (Pipe e1 e2) = go e1 <> " | " <> go e2
go (And e1 e2) = go e1 <> " && " <> go e2
go (Or e1 e2) = go e1 <> " || " <> go e2
go (Redir e r) = let use = (\t -> go e <> " " <> t) in case r of
(RedirToFile fd f) ->
use $ redirFd fd (Just stdOutput) <> "> " <> L.pack f
(RedirToFileAppend fd f) ->
use $ redirFd fd (Just stdOutput) <> ">> " <> L.pack f
(RedirFromFile fd f) ->
use $ redirFd fd (Just stdInput) <> "< " <> L.pack f
(RedirOutput fd1 fd2) ->
use $ redirFd fd1 (Just stdOutput) <> ">&" <> showFd fd2
(RedirInput fd1 fd2) ->
use $ redirFd fd1 (Just stdInput) <> "<&" <> showFd fd2
(RedirHereDoc t)
| multiline ->
let myEOF = eofMarker t
in use $ "<<" <> myEOF <> "\n"
<> t
<> "\n"
<> myEOF
| otherwise ->
let heredoc = Subshell L.empty $
flip map (L.lines t) $ \l -> Cmd $
"echo " <> getQ (quote l)
in go (Pipe heredoc e)
redirFd :: Fd -> (Maybe Fd) -> L.Text
redirFd fd deffd
| Just fd == deffd = ""
| otherwise = showFd fd
showFd :: Fd -> L.Text
showFd = L.pack . show
eofMarker :: L.Text -> L.Text
eofMarker t = go (1 :: Integer)
where
go n = let marker = "EOF" <> if n == 1 then "" else L.pack (show n)
in if marker `L.isInfixOf` t
then go (succ n)
else marker
linearScript :: Script f -> L.Text
linearScript = toLinearScript . gen
toLinearScript :: [Expr] -> L.Text
toLinearScript = L.intercalate "; " . map (fmt False)
run :: L.Text -> [L.Text] -> Script ()
run c ps = add $ Cmd $ L.intercalate " " (map (getQ . quote) (c:ps))
cmd :: (Param command, CmdParams params) => command -> params
cmd c = cmdAll (toTextParam c) []
class Param a where
toTextParam :: a -> (Env -> L.Text)
instance Param L.Text where
toTextParam = const . getQ . quote
instance Param String where
toTextParam = toTextParam . L.pack
instance (Show v) => Param (Val v) where
toTextParam (Val v) = const $ L.pack (show v)
instance Param UntypedVar where
toTextParam v = \env -> "\"" <> getQ (expandVar v env (varName v)) <> "\""
instance Param (Var a) where
toTextParam (Var v) = toTextParam v
instance Param (WithVar a) where
toTextParam (WithVar v f) = getQ . f . Q . toTextParam v
instance Param (Quoted L.Text) where
toTextParam (Q v) = const v
instance Param Output where
toTextParam (Output s) = \env ->
let t = toLinearScript $ fst $ runScript env s
in "\"$(" <> t <> ")\""
instance Param Arith where
toTextParam a = \env ->
let t = fmtArith env a
in "\"$((" <> t <> "))\""
class CmdParams t where
cmdAll :: (Env -> L.Text) -> [Env -> L.Text] -> t
instance (Param arg, CmdParams result) => CmdParams (arg -> result) where
cmdAll c acc x = cmdAll c (toTextParam x : acc)
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, ())
newtype Output = Output (Script ())
data WithVar a = WithVar (Var a) (Quoted L.Text -> Quoted L.Text)
add :: Expr -> Script ()
add expr = Script $ \env -> ([expr], env, ())
comment :: L.Text -> Script ()
comment = add . Comment
newtype NamedLike = NamedLike L.Text
class NameHinted h where
hinted :: (Maybe L.Text -> a) -> h -> a
instance NameHinted () where
hinted f _ = f Nothing
instance NameHinted NamedLike where
hinted f (NamedLike h) = f (Just h)
instance NameHinted (Maybe L.Text) where
hinted = id
newVar :: (NameHinted namehint) => forall a. namehint -> Script (Var a)
newVar = newVarContaining' ""
newVarContaining' :: (NameHinted namehint) => L.Text -> namehint -> Script (Var t)
newVarContaining' value = hinted $ \namehint -> do
v@(Var (V { varName = VarName name }))
<- newVarUnsafe namehint
Script $ \env -> ([Cmd (name <> "=" <> value)], env, v)
newVarContaining :: (NameHinted namehint, Quotable (Val t)) => t -> namehint -> Script (Var t)
newVarContaining = newVarContaining' . getQ . quote . Val
setVar :: Param param => forall a. Var a -> param -> Script ()
setVar (Var (V { varName = VarName name })) p = Script $ \env ->
([Cmd (name <> "=" <> toTextParam p env)], env, ())
globalVar :: forall a. L.Text -> Script (Var a)
globalVar name = Script $ \env ->
let v@(Var v') = simpleVar (VarName name)
in ([], modifyEnvVars env (S.insert (varName v')), v)
positionalParameters :: forall a. Var a
positionalParameters = simpleVar (VarName "@")
takeParameter :: (NameHinted namehint) => forall a. namehint -> Script (Var a)
takeParameter = hinted $ \namehint -> do
p@(Var (V { varName = VarName name}))
<- newVarUnsafe namehint
Script $ \env -> ([Cmd (name <> "=\"$1\""), Cmd "shift"], env, p)
newVarUnsafe :: (NameHinted namehint) => forall a. namehint -> Script (Var a)
newVarUnsafe = hinted $ \namehint -> Script $ \env ->
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) =
go namehint env (succ x)
| otherwise = v
where
v@(Var v') = simpleVar $ VarName $ "_"
<> genvarname namehint
<> if x == 0 then "" else L.pack (show (x + 1))
genvarname = maybe "v" (L.filter isAlpha)
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) => 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
defaultVar :: (Param param) => forall a. Var a -> param -> Script (Var a)
defaultVar = modVar' ":-"
whenVar :: (Param param) => forall a. Var a -> param -> Script (Var a)
whenVar = modVar' ":+"
errUnlessVar :: (Param param) => forall a. Var a -> param -> Script (Var a)
errUnlessVar = modVar' ":?"
lengthVar :: forall a. Var a -> Script (Var Integer)
lengthVar v@(Var (V { varName = VarName varname }))
| varname /= "@" = do
tmpvar@(Var tmpvar') <- newVar (NamedLike "tmp")
modVar tmpvar $ \tmpname env ->
let hack = do
setVar tmpvar v
cmd ("echo" :: L.Text) $ Var $ tmpvar'
{ expandVar = \_ _ -> Q $
"${#" <> tmpname <> "}"
}
in varname <> ":-" <> toTextParam (Output hack) env
| otherwise = return $ simpleVar (VarName "#")
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' "%"
trimVar LongestMatch FromEnd = modVar' "%%"
data Greediness = ShortestMatch | LongestMatch
data Direction = FromBeginning | FromEnd
func
:: (NameHinted namehint, CmdParams callfunc)
=> namehint
-> Script ()
-> Script callfunc
func h s = flip hinted h $ \namehint -> Script $ \env ->
let f = go (genfuncname namehint) env (0 :: Integer)
env' = modifyEnvFuncs env (S.insert f)
(ls, env'') = runScript env' s
in (definefunc f ls, env'', callfunc f)
where
go basename env x
| S.member f (envFuncs env) = go basename env (succ x)
| otherwise = f
where
f = Func $ "_"
<> basename
<> if x == 0 then "" else L.pack (show (x + 1))
genfuncname = maybe "p" (L.filter isAlpha)
definefunc (Func f) ls = (Cmd $ f <> " () { :") : map indent ls ++ [ Cmd "}" ]
callfunc (Func f) = cmd f
forCmd :: forall a. Script () -> (Var a -> Script ()) -> Script ()
forCmd c a = do
v@(Var (V { varName = VarName varname})) <- newVarUnsafe (NamedLike "x")
s <- toLinearScript <$> runM c
add $ Cmd $ "for " <> varname <> " in $(" <> s <> ")"
block "do" (a v)
add $ Cmd "done"
whileCmd :: Script () -> Script () -> Script ()
whileCmd c a = do
s <- toLinearScript <$> runM c
add $ Cmd $ "while $(" <> s <> ")"
block "do" a
add $ Cmd "done"
ifCmd :: Script () -> Script () -> Script () -> Script ()
ifCmd cond thena elsea =
ifCmd' id cond $ do
block "then" thena
block "else" elsea
ifCmd' :: (L.Text -> L.Text) -> Script () -> Script () -> Script ()
ifCmd' condf cond body = do
condl <- runM cond
add $ Cmd $ "if " <> condf (singleline condl)
body
add $ Cmd "fi"
where
singleline l =
let c = case l of
[c'@(Cmd {})] -> c'
[c'@(Subshell {})] -> c'
_ -> Subshell L.empty l
in toLinearScript [c]
whenCmd :: Script () -> Script () -> Script ()
whenCmd cond a =
ifCmd' id cond $
block "then" a
unlessCmd :: Script () -> Script () -> Script ()
unlessCmd cond a =
ifCmd' ("! " <>) cond $
block "then" a
caseOf :: forall a. Var a -> [(Quoted L.Text, Script ())] -> Script ()
caseOf _ [] = return ()
caseOf v l = go True l
where
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
block :: L.Text -> Script () -> Script ()
block word s = do
add $ Cmd $ word <> " :"
mapM_ (add . indent) =<< runM s
readVar :: Var String -> Script ()
readVar (Var (V { varName = VarName varname })) = add $
Cmd $ "read " <> getQ (quote varname)
stopOnFailure :: Bool -> Script ()
stopOnFailure b = add $ Cmd $ "set " <> (if b then "-" else "+") <> "e"
ignoreFailure :: Script () -> Script ()
ignoreFailure s = runM s >>= mapM_ (add . go)
where
go c@(Cmd _) = Or c true
go c@(Comment _) = c
go (Subshell i l) = Subshell i (map go l)
go (Pipe e1 e2) = Pipe e1 (go e2)
go c@(And _ _) = Or c true
go (Or e1 e2) = Or e1 (go e2)
go (Redir e r) = Redir (go e) r
true = Cmd "true"
(-|-) :: Script () -> Script () -> Script ()
(-|-) = combine Pipe
(-&&-) :: Script () -> Script () -> Script ()
(-&&-) = combine And
(-||-) :: Script () -> Script () -> Script ()
(-||-) = combine Or
combine :: (Expr -> Expr -> Expr) -> Script () -> Script () -> Script ()
combine f a b = do
alines <- runM a
blines <- runM b
add $ f (toSingleExp alines) (toSingleExp blines)
toSingleExp :: [Expr] -> Expr
toSingleExp [e] = e
toSingleExp l = Subshell L.empty l
redir :: Script () -> RedirSpec -> Script ()
redir s r = do
e <- toSingleExp <$> runM s
add $ Redir e r
class RedirFile r where
fromRedirFile :: Fd -> r -> (Fd, FilePath)
instance RedirFile FilePath where
fromRedirFile = (,)
instance RedirFile (Fd, FilePath) where
fromRedirFile = const id
fileRedir :: RedirFile f => f -> Fd -> (Fd -> FilePath -> RedirSpec) -> RedirSpec
fileRedir f deffd c = uncurry c (fromRedirFile deffd f)
(|>) :: RedirFile f => Script () -> f -> Script ()
s |> f = redir s (fileRedir f stdOutput RedirToFile)
(|>>) :: RedirFile f => Script () -> f -> Script ()
s |>> f = redir s (fileRedir f stdOutput RedirToFileAppend)
(|<) :: RedirFile f => Script () -> f -> Script ()
s |< f = redir s (fileRedir f stdInput RedirFromFile)
toStderr :: Script () -> Script ()
toStderr s = s &stdOutput>&stdError
(>&) :: (Script (), Fd) -> Fd -> Script ()
(s, fd1) >& fd2 = redir s (RedirOutput fd1 fd2)
(<&) :: (Script (), Fd) -> Fd -> Script ()
(s, fd1) <& fd2 = redir s (RedirInput fd1 fd2)
(&) :: Script () -> Fd -> (Script (), Fd)
(&) = (,)
hereDocument :: Script () -> L.Text -> Script ()
hereDocument s t = redir s (RedirHereDoc t)
data Arith
= ANum Integer
| AVar (Var Integer)
| ANegate Arith
| APlus Arith Arith
| AMinus Arith Arith
| AMult Arith Arith
| ADiv Arith Arith
| AMod Arith Arith
| ANot Arith
| AOr Arith Arith
| AAnd Arith Arith
| AEqual Arith Arith
| ANotEqual Arith Arith
| ALT Arith Arith
| AGT Arith Arith
| ALE Arith Arith
| AGE Arith Arith
| ABitOr Arith Arith
| ABitXOr Arith Arith
| ABitAnd Arith Arith
| AShiftLeft Arith Arith
| AShiftRight Arith Arith
| ACond Arith Arith Arith
fmtArith :: Env -> Arith -> L.Text
fmtArith env = go
where
go (ANum i) = L.pack (show i)
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