{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, RecordWildCards, DeriveGeneric #-}
module Language.Bash.Syntax
(
Command(..)
, ShellCommand(..)
, WordList(..)
, CaseClause(..)
, CaseTerm(..)
, Redir(..)
, IODesc(..)
, RedirOp(..)
, HeredocOp(..)
, List(..)
, Statement(..)
, ListTerm(..)
, AndOr(..)
, Pipeline(..)
, Assign(..)
, AssignOp(..)
, RValue(..)
) where
import Prelude hiding (Word)
import Data.Data (Data)
import Data.List (intersperse)
import Data.Semigroup (Semigroup(..))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Data.Text.Prettyprint.Doc (Doc, Pretty(..), (<+>), hardline, hcat, hsep, indent, nest, nesting, punctuate, vcat)
import Data.Text.Prettyprint.Doc.Internal (Doc(Empty))
import Language.Bash.Cond (CondExpr)
import Language.Bash.Operator
import Language.Bash.Pretty
import Language.Bash.Word
data BashDoc ann = BashDoc
(Doc ann)
(Doc ann)
(Doc ann)
instance Semigroup (BashDoc ann) where
BashDoc Empty Empty Empty <> y = y
x <> BashDoc Empty Empty Empty = x
BashDoc h1 t1 Empty <> BashDoc h2 t2 hds2 = BashDoc h1 (t1 <> h2 <++> t2) hds2
BashDoc h1 t1 hds1 <> BashDoc h2 t2 hds2 = BashDoc h1 (t1 <> noIndent (h2 $++$ hds1) $++$ t2) hds2
where
noIndent doc = nesting $ \i -> nest (- i) doc
instance Monoid (BashDoc ann) where
mempty = BashDoc mempty mempty mempty
mappend = (<>)
docOp :: Doc ann -> BashDoc ann
docOp xs = BashDoc xs mempty mempty
prettyBashDoc :: BashDoc ann -> Doc ann
prettyBashDoc (BashDoc h t hds) = h <++> t $++$ hds
class ToBashDoc a where
toBashDoc :: a -> BashDoc ann
prettyHeredocs :: [Redir] -> Doc ann
prettyHeredocs [] = mempty
prettyHeredocs rs = mconcat $ intersperse hardline $ map prettyHeredoc rs
where
prettyHeredoc Heredoc{..} = pretty hereDocument <> pretty heredocDelim
prettyHeredoc _ = mempty
indent' :: Doc ann -> Doc ann
indent' = indent 4
prettyBlock :: Doc ann -> Doc ann -> Doc ann -> Doc ann -> Doc ann -> Doc ann
prettyBlock pre cond bs block be = pre <+> cond <+> bs $+$ block $+$ be
prettyBlockList :: Doc ann -> List -> Doc ann -> Doc ann -> Doc ann -> Doc ann
prettyBlockList pre l bs block be
| hasHeredoc l = pre <+> pretty l $+$ bs $+$ block $+$ be
| otherwise = prettyBlock pre (pretty l) bs block be
hasHeredoc :: List -> Bool
hasHeredoc (List []) = False
hasHeredoc (List xs) = let
Statement l _ = last xs
BashDoc _ _ hds = toBashDoc l
in case hds of
Empty -> False
_ -> True
data Command = Command ShellCommand [Redir]
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty Command where
pretty = prettyBashDoc . toBashDoc
instance ToBashDoc Command where
toBashDoc (Command c rs) = BashDoc mempty (pretty c <++> pretty rs) (prettyHeredocs $ filter isHeredoc rs)
where
isHeredoc Heredoc{..} = True
isHeredoc _ = False
data ShellCommand
= SimpleCommand [Assign] [Word]
| AssignBuiltin Word [Either Assign Word]
| FunctionDef String List
| Coproc String Command
| Subshell List
| Group List
| Arith String
| Cond (CondExpr Word)
| For String WordList List
| ArithFor String List
| Select String WordList List
| Case Word [CaseClause]
| If List List (Maybe List)
| Until List List
| While List List
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty ShellCommand where
pretty (SimpleCommand as ws) = pretty as <++> pretty ws
pretty (AssignBuiltin w args) = pretty w <++> hsep (map (either pretty pretty) args)
pretty (FunctionDef name l) =
pretty name <+> "()" $+$ pretty (Group l)
pretty (Coproc name c) =
"coproc" <+> pretty name <+> pretty c
pretty (Subshell l) =
"(" <+> pretty l <+> ")"
pretty (Group l) =
"{" $+$ indent' (pretty l) $+$ "}"
pretty (Arith s) =
"((" <> pretty s <> "))"
pretty (Cond e) =
"[[" <+> pretty e <+> "]]"
pretty (For w ws l) =
prettyBlock "for" (pretty w <+> pretty ws <> ";") "do" (indent' $ pretty l) "done"
pretty (ArithFor s l) =
prettyBlock "for" ("((" <> pretty s <> "))") "do" (indent' $ pretty l) "done"
pretty (Select w ws l) =
prettyBlock "select" (pretty w <++> pretty ws <> ";") "do" (indent' $ pretty l) "done"
pretty (Case w cs) =
prettyBlock "case" (pretty w) "in" (vcat $ map (indent' . pretty) cs) "esac"
pretty (If p t f) =
prettyBlockList "if" p "then"
(indent' (pretty t) $++$ (maybe mempty (\l -> "else" $+$ indent' (pretty l)) f)
)
"fi"
pretty (Until p l) =
prettyBlockList "until" p "do" (indent' $ pretty l) "done"
pretty (While p l) =
prettyBlockList "while" p "do" (indent' $ pretty l) "done"
data WordList
= Args
| WordList [Word]
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty WordList where
pretty Args = mempty
pretty (WordList ws) = "in" <+> pretty ws
data CaseClause = CaseClause [Word] List CaseTerm
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty CaseClause where
pretty (CaseClause ps l term) =
hcat (punctuate " | " (map pretty ps)) <> ")" $+$
indent' (pretty l) $+$
(indent' $ pretty term)
data CaseTerm
= Break
| FallThrough
| Continue
deriving (Data, Eq, Ord, Read, Show, Typeable, Bounded, Enum, Generic)
instance Operator CaseTerm where
operatorTable = zip [minBound .. maxBound] [";;", ";&", ";;&"]
instance Pretty CaseTerm where
pretty = prettyOperator
data Redir
= Redir
{
redirDesc :: Maybe IODesc
, redirOp :: RedirOp
, redirTarget :: Word
}
| Heredoc
{
heredocOp :: HeredocOp
, heredocDelim :: String
, heredocDelimQuoted :: Bool
, hereDocument :: Word
}
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty Redir where
pretty Redir{..} =
pretty redirDesc <> pretty redirOp <> pretty redirTarget
pretty Heredoc{..} =
pretty heredocOp <>
pretty (if heredocDelimQuoted
then "'" ++ heredocDelim ++ "'"
else heredocDelim)
prettyList = hsep . map pretty
data IODesc
= IONumber Int
| IOVar String
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty IODesc where
pretty (IONumber n) = pretty n
pretty (IOVar n) = "{" <> pretty n <> "}"
data RedirOp
= In
| Out
| OutOr
| Append
| AndOut
| AndAppend
| HereString
| InAnd
| OutAnd
| InOut
deriving (Data, Eq, Ord, Read, Show, Typeable, Enum, Bounded, Generic)
instance Operator RedirOp where
operatorTable = zip [minBound .. maxBound]
["<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"]
instance Pretty RedirOp where
pretty = prettyOperator
data HeredocOp
= Here
| HereStrip
deriving (Data, Eq, Ord, Read, Show, Typeable, Enum, Bounded, Generic)
instance Operator HeredocOp where
operatorTable = zip [Here, HereStrip] ["<<", "<<-"]
instance Pretty HeredocOp where
pretty = prettyOperator
newtype List = List [Statement]
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty List where
pretty (List as) = pretty as
data Statement = Statement AndOr ListTerm
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty Statement where
pretty = prettyBashDoc . toBashDoc
prettyList = foldr f mempty
where
f a@(Statement _ Sequential) b = pretty a $++$ b
f a@(Statement _ Asynchronous) b = pretty a <++> b
instance ToBashDoc Statement where
toBashDoc (Statement l lt) = toBashDoc l <> toBashDoc lt
data ListTerm
= Sequential
| Asynchronous
deriving (Data, Eq, Ord, Read, Show, Typeable, Bounded, Enum, Generic)
instance Operator ListTerm where
operatorTable =
[ (Sequential , ";" )
, (Sequential , "\n")
, (Asynchronous, "&" )
]
instance Pretty ListTerm where
pretty = prettyOperator
instance ToBashDoc ListTerm where
toBashDoc Sequential = docOp ";"
toBashDoc Asynchronous = docOp "&"
data AndOr
= Last Pipeline
| And Pipeline AndOr
| Or Pipeline AndOr
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty AndOr where
pretty = prettyBashDoc . toBashDoc
instance ToBashDoc AndOr where
toBashDoc (Last p) = toBashDoc p
toBashDoc (And p a) = toBashDoc p <> docOp " &&" <> toBashDoc a
toBashDoc (Or p a) = toBashDoc p <> docOp " ||" <> toBashDoc a
data Pipeline = Pipeline
{
timed :: Bool
, timedPosix :: Bool
, inverted :: Bool
, commands :: [Command]
} deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty Pipeline where
pretty = prettyBashDoc . toBashDoc
instance ToBashDoc Pipeline where
toBashDoc Pipeline{..} = let
timed' = if timed then "time" else mempty
timedPosix' = if timedPosix then "-p" else mempty
inverted' = if inverted then "!" else mempty
space = if timed || timedPosix || inverted then " " else mempty
prefix = BashDoc mempty (timed' <++> timedPosix' <++> inverted' <> space) mempty
in prefix <> mconcat (intersperse (docOp " |") (map toBashDoc commands))
data Assign = Assign Parameter AssignOp RValue
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty Assign where
pretty (Assign lhs op rhs) = pretty lhs <> pretty op <> pretty rhs
prettyList = hsep . map pretty
data AssignOp
= Equals
| PlusEquals
deriving (Data, Eq, Ord, Read, Show, Typeable, Bounded, Enum, Generic)
instance Operator AssignOp where
operatorTable = zip [Equals, PlusEquals] ["=", "+="]
instance Pretty AssignOp where
pretty = prettyOperator
data RValue
= RValue Word
| RArray [(Maybe Word, Word)]
deriving (Data, Eq, Read, Show, Typeable, Generic)
instance Pretty RValue where
pretty (RValue w) = pretty w
pretty (RArray rs) = "(" <> hsep (map f rs) <> ")"
where
f (Nothing , w) = pretty w
f (Just sub, w) = "[" <> pretty sub <> "]=" <> pretty w