module Control.Monad.Shell (
Script,
script,
linearScript,
Var,
val,
Q,
quote,
Expr,
indent,
run,
cmd,
add,
comment,
newVar,
newVarContaining,
globalVar,
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 -> Q
val (Var v) = Q ("\"$" <> v <> "\"")
newtype Q = Q { getQ :: L.Text }
deriving (Eq, Ord, Show)
instance Monoid Q where
mempty = Q L.empty
mappend (Q a) (Q b) = Q (a <> b)
quote :: L.Text -> Q
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
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)
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
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
run :: L.Text -> [L.Text] -> Script ()
run c ps = add $ Cmd $ L.intercalate " " (map (getQ . quote) (c:ps))
cmd :: (ShellCmd result) => L.Text -> result
cmd c = cmdAll c []
class CmdArg a where
toTextArg :: a -> L.Text
instance CmdArg L.Text where
toTextArg = getQ . quote
instance CmdArg Var where
toTextArg v = toTextArg (val v)
instance CmdArg Q where
toTextArg (Q v) = v
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)
add :: Expr -> Script ()
add expr = Script $ \env -> ([expr], env, ())
comment :: L.Text -> Script ()
comment = add . Comment
newVar
:: L.Text
-> Script Var
newVar basename = Script $ \env ->
let v = go env (0 :: Integer)
in ([], modifyEnvVars env (S.insert v), v)
where
go env x
| S.member v (envVars env) = go env (succ x)
| otherwise = v
where
v = Var $ "_" <> basename <> L.pack (show (x + 1))
newVarContaining
:: L.Text
-> L.Text
-> Script Var
newVarContaining basename value = do
v@(Var name) <- newVar basename
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)
func :: Script () -> Script (Script ())
func s = Script $ \env ->
let f = go env (0 :: Integer)
env' = modifyEnvFuncs env (S.insert f)
(ls, env'') = eval env' s
in (definefunc f ls, env'', callfunc f)
where
basename = "p"
go env x
| S.member f (envFuncs env) = go env (succ x)
| otherwise = f
where
f = Func $ basename <> L.pack (show (x + 1))
definefunc (Func f) ls = (Cmd $ f <> " () { :") : map indent ls ++ [ Cmd "}" ]
callfunc :: Func -> Script ()
callfunc (Func f) = add $ Cmd f
(-|-) :: Script () -> Script () -> Script ()
a -|- b = do
alines <- runM a
blines <- runM b
add $ Pipe (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 "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 (Cmd t) = Cmd $ t <> " || 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)