module Language.ECMAScript3.PrettyPrint
(
javaScript
, renderStatements
, renderExpression
) where
import Text.PrettyPrint.HughesPJ
import Language.ECMAScript3.Syntax
renderStatements :: [Statement a] -> String
renderStatements = render . stmtList
renderExpression :: Expression a -> String
renderExpression = render . expr
inBlock:: Statement a -> Doc
inBlock s@(BlockStmt _ _) = stmt s
inBlock s = lbrace $+$ nest 2 (stmt s) $+$ rbrace
inParens:: Expression a -> Doc
inParens e@(ParenExpr _ _) = expr e
inParens e = parens (expr e)
pp (Id _ str) = text str
forInit :: ForInit a -> Doc
forInit t = case t of
NoInit -> empty
VarInit vs -> text "var" <+> cat (punctuate comma $ map varDecl vs)
ExprInit e -> expr e
forInInit :: ForInInit a -> Doc
forInInit t = case t of
ForInVar id -> text "var" <+> pp id
ForInLVal lv -> lvalue lv
caseClause :: CaseClause a -> Doc
caseClause (CaseClause _ e ss) =
text "case" $+$ expr e <+> colon $$ nest 2 (stmtList ss)
caseClause (CaseDefault _ ss) =
text "default:" $$ nest 2 (stmtList ss)
varDecl :: VarDecl a -> Doc
varDecl (VarDecl _ id Nothing) = pp id
varDecl (VarDecl _ id (Just e)) = pp id <+> equals <+> expr e
stmt :: Statement a -> Doc
stmt s = case s of
BlockStmt _ ss -> lbrace $+$ nest 2 (stmtList ss) $$ rbrace
EmptyStmt _ -> semi
ExprStmt _ e -> expr e <> semi
IfSingleStmt _ test cons -> text "if" <+> inParens test $$ stmt cons
IfStmt _ test cons alt ->
text "if" <+> inParens test $$ stmt cons $$ text "else" <+> stmt alt
SwitchStmt _ e cases ->
text "switch" <+> inParens e $$
braces (nest 2 (vcat (map caseClause cases)))
WhileStmt _ test body -> text "while" <+> inParens test $$ stmt body
ReturnStmt _ Nothing -> text "return"
ReturnStmt _ (Just e) -> text "return" <+> expr e
DoWhileStmt _ s e ->
text "do" $$ (stmt s <+> text "while" <+> inParens e <> semi)
BreakStmt _ Nothing -> text "break" <> semi
BreakStmt _ (Just label) -> text "break" <+> pp label <> semi
ContinueStmt _ Nothing -> text "continue" <> semi
ContinueStmt _ (Just label) -> text"continue" <+> pp label <> semi
LabelledStmt _ label s -> pp label <> colon $$ stmt s
ForInStmt p init e body ->
text "for" <+>
parens (forInInit init <+> text "in" <+> expr e) $+$ stmt body
ForStmt _ init incr test body ->
text "for" <+>
parens (forInit init <> semi <+> mexpr incr <> semi <+> mexpr test) $$
stmt body
TryStmt _ stmt mcatch mfinally ->
text "try" $$ inBlock stmt $$ ppCatch $$ ppFinally
where ppFinally = case mfinally of
Nothing -> empty
Just stmt -> text "finally" <> inBlock stmt
ppCatch = case mcatch of
Nothing -> empty
Just (CatchClause _ id s) ->
text "catch" <+> (parens.pp) id <+> inBlock s
ThrowStmt _ e -> text "throw" <+> expr e <> semi
WithStmt _ expr s -> text "with" <+> inParens expr $$ stmt s
VarDeclStmt _ decls ->
text "var" <+> cat (punctuate comma (map varDecl decls)) <> semi
FunctionStmt _ name args s ->
text "function" <+> pp name <>
parens (cat $ punctuate comma (map pp args)) $$
inBlock s
stmtList :: [Statement a] -> Doc
stmtList = vcat . map stmt
prop :: Prop a -> Doc
prop p = case p of
PropId _ id -> pp id
PropString _ str -> doubleQuotes (text (jsEscape str))
PropNum _ n -> text (show n)
infixOp op = text $ case op of
OpMul -> "*"
OpDiv -> "/"
OpMod -> "%"
OpAdd -> "+"
OpSub -> "-"
OpLShift -> "<<"
OpSpRShift -> ">>"
OpZfRShift -> ">>>"
OpLT -> "<"
OpLEq -> "<="
OpGT -> ">"
OpGEq -> ">="
OpIn -> "in"
OpInstanceof -> "instanceof"
OpEq -> "=="
OpNEq -> "!="
OpStrictEq -> "==="
OpStrictNEq -> "!=="
OpBAnd -> "&"
OpBXor -> "^"
OpBOr -> "|"
OpLAnd -> "&&"
OpLOr -> "||"
prefixOp op = text $ case op of
PrefixLNot -> "!"
PrefixBNot -> "~"
PrefixPlus -> "+"
PrefixMinus -> "-"
PrefixTypeof -> "typeof"
PrefixVoid -> "void"
PrefixDelete -> "delete"
assignOp op = text $ case op of
OpAssign -> "="
OpAssignAdd -> "+="
OpAssignSub -> "-="
OpAssignMul -> "*="
OpAssignDiv -> "/="
OpAssignMod -> "%="
OpAssignLShift -> "<<="
OpAssignSpRShift -> ">>="
OpAssignZfRShift -> ">>>="
OpAssignBAnd -> "&="
OpAssignBXor -> "^="
OpAssignBOr -> "|="
jsEscape:: String -> String
jsEscape "" = ""
jsEscape (ch:chs) = sel ch ++ jsEscape chs where
sel '\b' = "\\b"
sel '\f' = "\\f"
sel '\n' = "\\n"
sel '\r' = "\\r"
sel '\t' = "\\t"
sel '\v' = "\\v"
sel '\'' = "\\'"
sel '\"' = "\\\""
sel '\\' = "\\\\"
sel x = [x]
lvalue :: LValue a -> Doc
lvalue (LVar _ x) = text x
lvalue (LDot _ e x) = expr e <> text "." <> text x
lvalue (LBracket _ e1 e2) = expr e1 <> brackets (expr e2)
expr :: Expression a -> Doc
expr e = case e of
StringLit _ str -> doubleQuotes (text (jsEscape str))
RegexpLit _ re global ci ->
text "/" <> text re <> text "/" <> g <> i where
g = if global then text "g" else empty
i = if ci then text "i" else empty
NumLit _ n -> text (show n)
IntLit _ n -> text (show n)
BoolLit _ True -> text "true"
BoolLit _ False -> text "false"
NullLit _ -> text "null"
ArrayLit _ es -> brackets $ cat $ punctuate comma (map expr es)
ObjectLit _ xs ->
braces (hsep (punctuate comma (map pp' xs))) where
pp' (n,v) = prop n <> colon <+> expr v
ThisRef _ -> text "this"
VarRef _ id -> pp id
DotRef _ e' id -> expr e' <> text "." <> pp id
BracketRef _ container key -> expr container <> brackets (expr key)
NewExpr _ constr args ->
text "new" <+> expr constr <>
parens (cat $ punctuate comma (map expr args))
PrefixExpr _ op e' -> prefixOp op <+> expr e'
InfixExpr _ op left right -> expr left <+> infixOp op <+> expr right
CondExpr _ test cons alt ->
expr test <+> text "?" <+> expr cons <+> colon <+> expr alt
AssignExpr _ op l r -> lvalue l <+> assignOp op <+> expr r
UnaryAssignExpr _ op e' -> case op of
PrefixInc -> text "++" <> lvalue e'
PrefixDec -> text "--" <> lvalue e'
PostfixInc -> lvalue e' <> text "++"
PostfixDec -> lvalue e' <> text "--"
ParenExpr _ e' -> parens (expr e')
ListExpr _ es -> cat $ punctuate comma (map expr es)
CallExpr _ f args ->
expr f <> parens (cat $ punctuate comma (map expr args))
FuncExpr _ name args body ->
text "function" <+> text (maybe "" unId name) <+>
parens (cat $ punctuate comma (map pp args)) $$
inBlock body
mexpr :: Maybe (Expression a) -> Doc
mexpr Nothing = empty
mexpr (Just e) = expr e
javaScript :: JavaScript a -> Doc
javaScript (Script _ ss) = stmtList ss