module Language.Qux.Syntax (
Id, Program(..), Decl(..), Stmt(..), Expr(..), BinaryOp(..), UnaryOp(..), Value(..), Type(..)
) where
import Data.Char (toLower)
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
type Id = String
data Program = Program [Id] [Decl]
deriving (Eq, Show)
instance Pretty Program where
pPrint (Program module_ decls) = vcat $ map ($+$ text "") ([
text "module" <+> hcat (punctuate (char '.') (map text module_))
] ++ map pPrint decls)
data Decl = FunctionDecl Id [(Type, Id)] [Stmt]
deriving (Eq, Show)
instance Pretty Decl where
pPrint (FunctionDecl name parameters stmts) = vcat [
text name <+> text "::" <+> parametersDoc <> colon,
nest 4 (block stmts)
]
where
parametersDoc = fsep $ punctuate
(space <> text "->")
(map (\(t, p) -> pPrint t <+> (if p == "@" then empty else text p)) parameters)
data Stmt = IfStmt Expr [Stmt] [Stmt]
| ReturnStmt Expr
| WhileStmt Expr [Stmt]
deriving (Eq, Show)
instance Pretty Stmt where
pPrint (IfStmt condition trueStmts falseStmts) = vcat [
text "if" <+> pPrint condition <> colon,
nest 4 (block trueStmts),
if null falseStmts then empty else text "else:",
nest 4 (block falseStmts)
]
pPrint (ReturnStmt expr) = text "return" <+> pPrint expr
pPrint (WhileStmt condition stmts) = vcat [
text "while" <+> pPrint condition <> colon,
nest 4 (block stmts)
]
data Expr = ApplicationExpr Id [Expr]
| BinaryExpr BinaryOp Expr Expr
| ListExpr [Expr]
| TypedExpr Type Expr
| UnaryExpr UnaryOp Expr
| ValueExpr Value
deriving (Eq, Show)
instance Pretty Expr where
pPrint (ApplicationExpr name arguments) = text name <+> fsep (map pPrint arguments)
pPrint (BinaryExpr op lhs rhs) = parens $ fsep [pPrint lhs, pPrint op, pPrint rhs]
pPrint (ListExpr elements) = brackets $ fsep (punctuate comma (map pPrint elements))
pPrint (TypedExpr _ expr) = pPrint expr
pPrint (UnaryExpr Len expr) = char '|' <> pPrint expr <> char '|'
pPrint (UnaryExpr op expr) = pPrint op <> pPrint expr
pPrint (ValueExpr value) = pPrint value
data BinaryOp = Acc
| Mul
| Div
| Mod
| Add
| Sub
| Lt
| Lte
| Gt
| Gte
| Eq
| Neq
deriving (Eq, Show)
instance Pretty BinaryOp where
pPrint Acc = text "!!"
pPrint Mul = text "*"
pPrint Div = text "/"
pPrint Mod = text "%"
pPrint Add = text "+"
pPrint Sub = text "-"
pPrint Lt = text "<"
pPrint Lte = text "<="
pPrint Gt = text ">"
pPrint Gte = text ">="
pPrint Eq = text "=="
pPrint Neq = text "!="
data UnaryOp = Len
| Neg
deriving (Eq, Show)
instance Pretty UnaryOp where
pPrint Len = text "length"
pPrint Neg = text "-"
data Value = BoolValue Bool
| IntValue Integer
| ListValue [Value]
| NilValue
deriving (Eq, Show)
instance Pretty Value where
pPrint (BoolValue bool) = text $ map toLower (show bool)
pPrint (IntValue int) = text $ show int
pPrint (ListValue elements) = brackets $ fsep (punctuate comma (map pPrint elements))
pPrint NilValue = text "nil"
data Type = BoolType
| IntType
| ListType Type
| NilType
deriving (Eq, Show)
instance Pretty Type where
pPrint BoolType = text "Bool"
pPrint IntType = text "Int"
pPrint (ListType inner) = brackets $ pPrint inner
pPrint NilType = text "Nil"
block :: [Stmt] -> Doc
block = vcat . (map pPrint)