{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
module Control.Monad.Shell (
Script,
script,
linearScript,
Term,
Var,
Static,
Quoted,
Quotable(..),
glob,
run,
cmd,
Param,
CmdParams,
Output(..),
NamedLike(..),
NameHinted,
static,
newVar,
newVarFrom,
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,
test,
Test(..),
val,
Arith(..),
comment,
readVar,
) where
import qualified Data.Text.Lazy as L
import qualified Data.Set as S
import Data.Semigroup
import Data.Char
import System.Posix.Types (Fd)
import System.Posix.IO (stdInput, stdOutput, stdError)
import Control.Applicative
import Prelude
import Control.Monad.Shell.Quote
data Term t a where
VarTerm :: UntypedVar -> Term Var a
StaticTerm :: (Quotable (Val a)) => a -> Term Static a
data Var
data Static
data UntypedVar = V
{ varName :: VarName
, expandVar :: Env -> VarName -> Quoted L.Text
}
newtype VarName = VarName L.Text
deriving (Eq, Ord, Show)
simpleVar :: forall a. VarName -> Term Var a
simpleVar name = VarTerm 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` ("*?[!-:]\\" :: String) = L.singleton c
| otherwise = "\\" <> L.singleton c
newtype Func = Func L.Text
deriving (Eq, Ord, Show)
class Named t where
getName :: t -> L.Text
instance Named (Term Var t) where
getName (VarTerm v) = getName v
instance Named UntypedVar where
getName = getName . varName
instance Named VarName where
getName (VarName n) = n
instance Named Func where
getName (Func n) = n
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 Applicative Script where
pure a = Script $ \env -> ([], env, a)
Script f <*> Script a = Script $ \env0 ->
let (expr1, env1, f') = f env0
(expr2, env2, a') = a env1
in (expr1 <> expr2, env2, f' a')
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 Semigroup Env where
(<>) a b = Env (envVars a <> envVars b) (envFuncs a <> envFuncs b)
instance Monoid Env where
mempty = Env mempty mempty
mappend a b = Env (envVars a <> envVars b) (envFuncs a <> envFuncs b)
getEnv :: Script Env
getEnv = Script $ \env -> ([], env, 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
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) = ": " <> 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 Param UntypedVar where
toTextParam v env = "\"" <> getQ (expandVar v env (varName v)) <> "\""
instance Param (Term Var a) where
toTextParam (VarTerm v) = toTextParam v
instance (Show a) => Param (Term Static a) where
toTextParam (StaticTerm a) = toTextParam $ quote $ Val a
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 (Term 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
static :: (Quotable (Val t)) => t -> Term Static t
static = StaticTerm
newVar :: (NameHinted namehint) => forall a. namehint -> Script (Term Var a)
newVar = newVarContaining' ""
newVarContaining' :: (NameHinted namehint) => L.Text -> namehint -> Script (Term Var t)
newVarContaining' value = hinted $ \namehint -> do
v <- newVarUnsafe namehint
Script $ \env -> ([Cmd (getName v <> "=" <> value)], env, v)
newVarFrom
:: (NameHinted namehint, Param param)
=> param -> namehint -> Script (Term Var t)
newVarFrom param namehint = do
v <- newVarUnsafe namehint
Script $ \env ->
([Cmd (getName v <> "=" <> toTextParam param env)], env, v)
newVarContaining :: (NameHinted namehint, Quotable (Val t)) => t -> namehint -> Script (Term Var t)
newVarContaining = newVarContaining' . getQ . quote . Val
setVar :: Param param => forall a. Term Var a -> param -> Script ()
setVar v p = Script $ \env ->
([Cmd (getName v <> "=" <> toTextParam p env)], env, ())
globalVar :: forall a. L.Text -> Script (Term Var a)
globalVar name = Script $ \env ->
let v = simpleVar (VarName name)
in ([], modifyEnvVars env (S.insert (VarName (getName v))), v)
positionalParameters :: forall a. Term Var a
positionalParameters = simpleVar (VarName "@")
takeParameter :: (NameHinted namehint) => forall a. namehint -> Script (Term Var a)
takeParameter = hinted $ \namehint -> do
p <- newVarUnsafe namehint
Script $ \env -> ([Cmd (getName p <> "=\"$1\""), Cmd "shift"], env, p)
newVarUnsafe :: (NameHinted namehint) => forall a. namehint -> Script (Term Var a)
newVarUnsafe = hinted $ \namehint -> Script $ \env ->
let v = go namehint env (0 :: Integer)
in ([], modifyEnvVars env (S.insert (VarName (getName v))), v)
where
go namehint env x
| S.member (VarName (getName 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)
defaultVar :: (Param param) => forall a. Term Var a -> param -> Script (Term Var a)
defaultVar = funcVar' ":-"
whenVar :: (Param param) => forall a. Term Var a -> param -> Script (Term Var a)
whenVar = funcVar' ":+"
errUnlessVar :: (Param param) => forall a. Term Var a -> param -> Script (Term Var a)
errUnlessVar = funcVar' ":?"
trimVar :: forall a. Greediness -> Direction -> Term Var String -> Quoted L.Text -> Script (Term Var a)
trimVar ShortestMatch FromBeginning = funcVar' "#"
trimVar LongestMatch FromBeginning = funcVar' "##"
trimVar ShortestMatch FromEnd = funcVar' "%"
trimVar LongestMatch FromEnd = funcVar' "%%"
data Greediness = ShortestMatch | LongestMatch
data Direction = FromBeginning | FromEnd
lengthVar :: forall a. Term Var a -> Script (Term Var Integer)
lengthVar v
| getName v == "@" = return $ simpleVar (VarName "#")
| otherwise = funcVar v ("#" <>)
funcVar :: forall a b. Term Var a -> (L.Text -> L.Text) -> Script (Term Var b)
funcVar orig transform = do
tmp@(VarTerm internal) <- newVarUnsafe shortname :: Script (Term Var ())
f <- mkFunc tmp
return $ VarTerm $ internal
{ expandVar = \env _ -> Q $
"$(" <> toLinearScript (fst (runScript env f)) <> ")"
}
where
mkFunc :: Term Var () -> Script (Script ())
mkFunc tmp = func shortname $ do
setVar tmp orig
cmd ("echo" :: L.Text) $ Q $
"\"${" <> transform (getName tmp) <> "}\""
shortname = NamedLike "v"
funcVar' :: (Param param) => forall a b. L.Text -> Term Var a -> param -> Script (Term Var b)
funcVar' op v p = do
t <- toTextParam p <$> getEnv
funcVar v (<> op <> t)
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 () -> (Term Var a -> Script ()) -> Script ()
forCmd c a = do
v <- newVarUnsafe (NamedLike "x")
s <- toLinearScript <$> runM c
add $ Cmd $ "for " <> getName v <> " 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. Term 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
env <- getEnv
let leader = if atstart
then "case " <> toTextParam v env <> " 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 :: Term Var String -> Script ()
readVar v = add $ Cmd $ "read " <> getQ (quote (getName v))
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)
test :: Test -> Script ()
test t = Script $ \env -> ([Cmd $ "test " <> mkTest env t], env, ())
mkTest :: Env -> Test -> L.Text
mkTest env = go
where
go (TNot t) = unop "!" (go t)
go (TAnd t1 t2) = binop (go t1) "&&" (go t2)
go (TOr t1 t2) = binop (go t1) "||" (go t2)
go (TEmpty p) = unop "-z" (pv p)
go (TNonEmpty p) = unop "-n" (pv p)
go (TStrEqual p1 p2) = binop (pv p1) "=" (pv p2)
go (TStrNotEqual p1 p2) = binop (pv p1) "!=" (pv p2)
go (TEqual p1 p2) = binop (pv p1) "-eq" (pv p2)
go (TNotEqual p1 p2) = binop (pv p1) "-ne" (pv p2)
go (TGT p1 p2) = binop (pv p1) "-gt" (pv p2)
go (TLT p1 p2) = binop (pv p1) "-lt" (pv p2)
go (TGE p1 p2) = binop (pv p1) "-ge" (pv p2)
go (TLE p1 p2) = binop (pv p1) "-le" (pv p2)
go (TFileEqual p1 p2) = binop (pv p1) "-ef" (pv p2)
go (TFileNewer p1 p2) = binop (pv p1) "-nt" (pv p2)
go (TFileOlder p1 p2) = binop (pv p1) "-ot" (pv p2)
go (TBlockExists p) = unop "-b" (pv p)
go (TCharExists p) = unop "-c" (pv p)
go (TDirExists p) = unop "-d" (pv p)
go (TFileExists p) = unop "-e" (pv p)
go (TRegularFileExists p) = unop "-f" (pv p)
go (TSymlinkExists p) = unop "-L" (pv p)
go (TFileNonEmpty p) = unop "-s" (pv p)
go (TFileExecutable p) = unop "-x" (pv p)
paren t = "\\( " <> t <> " \\)"
binop a o b = paren $ a <> " " <> o <> " " <> b
unop o v = paren $ o <> " " <> v
pv :: (Param p) => p -> L.Text
pv = flip toTextParam env
data Test where
TNot :: Test -> Test
TAnd :: Test -> Test -> Test
TOr :: Test -> Test -> Test
TEmpty :: (Param p) => p -> Test
TNonEmpty :: (Param p) => p -> Test
TStrEqual :: (Param p, Param q) => p -> q -> Test
TStrNotEqual :: (Param p, Param q) => p -> q -> Test
TEqual :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TNotEqual :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TGT :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TLT :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TGE :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TLE :: (Integral p, Integral q) => Term Var p -> Term Var q -> Test
TFileEqual :: (Param p, Param q) => p -> q -> Test
TFileNewer :: (Param p, Param q) => p -> q -> Test
TFileOlder :: (Param p, Param q) => p -> q -> Test
TBlockExists :: (Param p) => p -> Test
TCharExists :: (Param p) => p -> Test
TDirExists :: (Param p) => p -> Test
TFileExists :: (Param p) => p -> Test
TRegularFileExists :: (Param p) => p -> Test
TSymlinkExists :: (Param p) => p -> Test
TFileNonEmpty :: (Param p) => p -> Test
TFileExecutable :: (Param p) => p -> Test
instance (Show a, Num a) => Num (Term Static a) where
fromInteger = static . fromInteger
(StaticTerm a) + (StaticTerm b) = StaticTerm (a + b)
(StaticTerm a) * (StaticTerm b) = StaticTerm (a * b)
(StaticTerm a) - (StaticTerm b) = StaticTerm (a - b)
abs (StaticTerm a) = StaticTerm (abs a)
signum (StaticTerm a) = StaticTerm (signum a)
val :: Term t Integer -> Arith
val t@(VarTerm _) = AVar t
val t@(StaticTerm _) = AStatic t
data Arith
= ANum Integer
| AVar (Term Var Integer)
| AStatic (Term Static 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
| AIf Arith (Arith, Arith)
fmtArith :: Env -> Arith -> L.Text
fmtArith env arith = "$(( " <> go arith <> " ))"
where
go (ANum i) = L.pack (show i)
go (AVar (VarTerm v)) = getQ $ expandVar v env (varName v)
go (AStatic (StaticTerm v)) = getQ $ quote $ Val 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 (AIf 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
instance Num Arith where
fromInteger = ANum
(+) = APlus
(*) = AMult
(-) = AMinus
negate = ANegate
abs v = AIf (v `ALT` ANum 0)
( AMult v (ANum (-1))
, v
)
signum v =
AIf (v `ALT` ANum 0)
( ANum (-1)
, AIf (v `AGT` ANum 0)
( ANum 1
, ANum 0
)
)
instance Enum Arith where
succ a = APlus a (ANum 1)
pred a = AMinus a (ANum 1)
toEnum = ANum . fromIntegral
enumFrom a = a : enumFrom (succ a)
enumFromThen a b = a : enumFromThen b ((b `AMult` ANum 2) `AMinus` a)
fromEnum = error "fromEnum not implemented for Arith"
enumFromTo = error "enumFromTo not implemented for Arith"
enumFromThenTo = error "enumFromToThen not implemented for Arith"