module Control.Monad.Shell (
Script,
script,
linearScript,
Var,
val,
Quoted,
quote,
run,
cmd,
CmdArg,
Output(..),
Val(..),
comment,
NamedLike(..),
NameHinted,
newVar,
newVarContaining,
globalVar,
positionalParameters,
takeParameter,
func,
(-|-),
(-&&-),
(-||-),
forCmd,
whileCmd,
ifCmd,
whenCmd,
unlessCmd,
readVar,
stopOnFailure,
ignoreFailure,
) where
import qualified Data.Text.Lazy as L
import qualified Data.Set as S
import Data.Monoid
import Control.Applicative
import Data.Char
newtype Var = Var L.Text
deriving (Eq, Ord, Show)
val :: Var -> Quoted L.Text
val (Var v) = Q ("\"$" <> v <> "\"")
newtype Quoted a = Q { getQ :: a }
deriving (Eq, Ord, Show, Monoid)
quote :: L.Text -> Quoted L.Text
quote t
| L.all (isAlphaNum) t = Q t
| otherwise = Q $ q <> L.intercalate "'\"'\"'" (L.splitOn q t) <> q
where
q = "'"
newtype Func = Func L.Text
deriving (Eq, Ord, Show)
data Expr
= Cmd L.Text
| Comment L.Text
| HereDocBody L.Text
| Subshell L.Text [Expr]
| Pipe Expr Expr
| And Expr Expr
| Or Expr Expr
indent :: Expr -> Expr
indent (Cmd t) = Cmd $ "\t" <> t
indent (Comment t) = Comment $ "\t" <> t
indent (HereDocBody t) = HereDocBody t
indent (Subshell i l) = Subshell ("\t" <> i) (map indent l)
indent (Pipe e1 e2) = Pipe (indent e1) (indent e2)
indent (And e1 e2) = And (indent e1) (indent e2)
indent (Or e1 e2) = Or (indent e1) (indent e2)
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 Var
, 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 Var -> S.Set Var) -> 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 . eval mempty
eval :: Env -> Script f -> ([Expr], Env)
eval env (Script f) = (code, env') where (code, env', _) = f env
runM :: Script () -> Script [Expr]
runM s = Script $ \env ->
let (r, env') = eval env s
in ([], env', r)
script :: Script f -> L.Text
script = flip mappend "\n" . L.intercalate "\n" . ("#!/bin/sh":) . map fmt . gen
where
fmt (Cmd t) = t
fmt (Comment t) = "# " <> L.filter (/= '\n') t
fmt (HereDocBody t) = t
fmt (Subshell i l) = i <> "(\n" <> L.intercalate "\n" (map (fmt . indent) l) <> "\n" <> i <> ")"
fmt (Pipe e1 e2) = fmt e1 <> " | " <> fmt e2
fmt (And e1 e2) = fmt e1 <> " && " <> fmt e2
fmt (Or e1 e2) = fmt e1 <> " || " <> fmt e2
linearScript :: Script f -> L.Text
linearScript = toLinearScript . gen
toLinearScript :: [Expr] -> L.Text
toLinearScript = L.intercalate "; " . map fmt
where
fmt (Cmd t) = t
fmt (Comment t) = ": " <> getQ (quote (L.filter (/= '\n') t))
fmt (HereDocBody _) = ""
fmt (Subshell i l) = i <> "(" <> L.intercalate "; " (map (fmt . indent) l) <> i <> ")"
fmt (Pipe e1 e2) = fmt e1 <> " | " <> fmt e2
fmt (And e1 e2) = fmt e1 <> " && " <> fmt e2
fmt (Or e1 e2) = fmt e1 <> " || " <> fmt e2
run :: L.Text -> [L.Text] -> Script ()
run c ps = add $ Cmd $ L.intercalate " " (map (getQ . quote) (c:ps))
cmd :: (ShellCmd params) => L.Text -> params
cmd c = cmdAll c []
class CmdArg a where
toTextArg :: a -> L.Text
instance CmdArg L.Text where
toTextArg = getQ . quote
instance CmdArg String where
toTextArg = toTextArg . L.pack
instance (Show v) => CmdArg (Val v) where
toTextArg (Val v) = L.pack (show v)
instance CmdArg Var where
toTextArg v = toTextArg (val v)
instance CmdArg (Quoted L.Text) where
toTextArg (Q v) = v
instance CmdArg Output where
toTextArg (Output s) = "\"$(" <> linearScript s <> ")\""
class ShellCmd t where
cmdAll :: L.Text -> [L.Text] -> t
instance (CmdArg arg, ShellCmd result) => ShellCmd (arg -> result) where
cmdAll c acc x = cmdAll c (toTextArg x : acc)
instance (f ~ ()) => ShellCmd (Script f) where
cmdAll c acc = add $ Cmd $ L.intercalate " " (c:reverse acc)
newtype Output = Output (Script ())
newtype Val v = Val v
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) => 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)
newVarContaining :: (NameHinted namehint) => L.Text -> namehint -> Script Var
newVarContaining value = hinted $ \namehint -> do
v@(Var name) <- newVar namehint
Script $ \env -> ([Cmd (name <> "=" <> getQ (quote value))], env, v)
globalVar :: L.Text -> Script Var
globalVar name = Script $ \env -> let v = Var name in ([], modifyEnvVars env (S.insert v), v)
positionalParameters :: Var
positionalParameters = Var "@"
takeParameter :: (NameHinted namehint) => namehint -> Script Var
takeParameter = hinted $ \namehint -> do
p@(Var name) <- newVar namehint
Script $ \env -> ([Cmd (name <> "=\"$1\""), Cmd "shift"], env, p)
func
:: (NameHinted namehint, ShellCmd 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'') = eval 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
(-|-) :: 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 (toExp alines) (toExp blines)
where
toExp [e] = e
toExp l = Subshell L.empty l
forCmd :: Script () -> (Var -> Script ()) -> Script ()
forCmd c a = do
v@(Var vname) <- newVar (NamedLike "x")
s <- toLinearScript <$> runM c
add $ Cmd $ "for " <> vname <> " 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
block :: L.Text -> Script () -> Script ()
block word s = do
add $ Cmd $ word <> " :"
mapM_ (add . indent) =<< runM s
readVar :: Var -> Script ()
readVar (Var vname) = add $ Cmd $ "read " <> getQ (quote vname)
stopOnFailure :: Bool -> Script ()
stopOnFailure b = add $ Cmd $ "set " <> if b then "-" else "+" <> "x"
ignoreFailure :: Script () -> Script ()
ignoreFailure s = runM s >>= mapM_ (add . go)
where
go c@(Cmd _) = Or c true
go c@(Comment _) = c
go c@(HereDocBody _) = 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)
true = Cmd "true"