module Language.JavaScript.Pretty (
Pretty(..)
) where
import Text.PrettyPrint.Leijen
import Text.PrettyPrint.Leijen.PrettyPrec
import Language.JavaScript.AST
import Language.JavaScript.NonEmptyList
instance Pretty JSString where
pretty s = char '"' <> text (unJSString s) <> char '"'
instance Pretty JSName where
pretty = text . unJSName
sepWith :: Pretty a => Doc -> [a] -> Doc
sepWith s = encloseSep empty empty s . map pretty
endWith :: Pretty a => Doc -> [a] -> Doc
endWith s xs = sepWith s xs <> s
sepWith' :: Pretty a => Doc -> NonEmptyList a -> Doc
sepWith' s = encloseSep empty empty s . map pretty . toList
prettyBlock :: Pretty a => [a] -> Doc
prettyBlock stmts = lbrace <$> indent 2 (endWith (semi <$> empty) stmts) <$> rbrace
data Associativity = LeftToRight | RightToLeft deriving Eq
prettyInfixOpApp :: (PrettyPrec a, PrettyPrec b) => Int -> OpInfo -> a -> b -> Doc
prettyInfixOpApp prec (OpInfo opPrec assoc name) a b =
docParen (prec > opPrec) $ bump LeftToRight a <+> text name <+> bump RightToLeft b
where
bump assoc' d = prettyPrec opPrec' d
where opPrec' = if assoc == assoc' then opPrec else opPrec + 1
docParen :: Bool -> Doc -> Doc
docParen True = parens
docParen False = id
data OpInfo = OpInfo Int
Associativity
String
infixOpInfo :: JSInfixOperator -> OpInfo
infixOpInfo op = case op of
JSMul -> go 6 "*"
JSDiv -> go 6 "/"
JSMod -> go 6 "%"
JSAdd -> go 5 "+"
JSSub -> go 5 "-"
JSGTE -> go 4 ">="
JSLTE -> go 4 "<="
JSGT -> go 4 ">"
JSLT -> go 4 "<"
JSEq -> go 3 "==="
JSNotEq -> go 3 "!=="
JSOr -> go 1 "||"
JSAnd -> go 2 "&&"
where go i s = OpInfo i LeftToRight s
instance Pretty JSNumber where
pretty (JSNumber n) = pretty n
instance PrettyPrec JSNumber
instance Pretty JSVarStatement where
pretty (JSVarStatement varDecls) = sepWith' (comma <+> empty) varDecls
instance PrettyPrec JSVarStatement
instance Pretty JSVarDecl where
pretty (JSVarDecl nm Nothing) = pretty nm
pretty (JSVarDecl nm (Just exp')) = pretty nm <+> text "=" <+> pretty exp'
instance PrettyPrec JSVarDecl
instance Pretty JSStatement where
pretty stmt = case stmt of
(JSStatementExpression es) -> pretty es <> semi
(JSStatementDisruptive ds) -> pretty ds
(JSStatementTry ts) -> pretty ts
(JSStatementIf is) -> pretty is
(JSStatementSwitch mbLbl ss) -> pp mbLbl ss
(JSStatementWhile mbLbl ws) -> pp mbLbl ws
(JSStatementFor mbLbl fs) -> pp mbLbl fs
(JSStatementDo mbLbl ds) -> pp mbLbl ds
where
pp :: Pretty a => Maybe JSName -> a -> Doc
pp (Just label) doc = pretty label <> colon <+> pretty doc
pp Nothing doc = pretty doc
instance PrettyPrec JSStatement
instance Pretty JSDisruptiveStatement where
pretty stmt = case stmt of
JSDSBreak bs -> pretty bs
JSDSReturn rs -> pretty rs
JSDSThrow ts -> pretty ts
instance PrettyPrec JSDisruptiveStatement
instance Pretty JSIfStatement where
pretty (JSIfStatement cond thenStmts blockOrIf) =
text "if" <+> parens (pretty cond) <+> prettyBlock thenStmts <+> ppRest
where
ppRest = case blockOrIf of
Nothing -> empty
Just (Left elseStmts) -> text "else" <+> prettyBlock elseStmts
Just (Right ifStmt) -> pretty ifStmt
instance PrettyPrec JSIfStatement
instance Pretty JSSwitchStatement where
pretty (JSSwitchStatementSingleCase cond caseClause) =
text "switch" <+> parens (pretty cond) <+> lbrace <$> pretty caseClause <$> rbrace
pretty (JSSwitchStatement cond cds stmts) =
text "switch" <+> parens (pretty cond) <+> lbrace <$>
indent 2 (vcat (toList . fmap pretty $ cds) <$>
(text "default:" <$>
indent 2 (endWith semi stmts))) <$>
rbrace
instance PrettyPrec JSSwitchStatement
instance Pretty JSCaseAndDisruptive where
pretty (JSCaseAndDisruptive caseClause disruptive) =
pretty caseClause <$> pretty disruptive
instance PrettyPrec JSCaseAndDisruptive
instance Pretty JSCaseClause where
pretty (JSCaseClause exp' stmts) =
text "case" <+> pretty exp' <> colon <+> endWith semi stmts
instance PrettyPrec JSCaseClause
instance Pretty JSForStatement where
pretty (JSForStatementCStyle init_ cond incr stmts) =
text "for" <+> parens (pretty init_ <> semi <+> pretty cond <> semi <+>
pretty incr) <+> prettyBlock stmts
pretty (JSForStatementInStyle name exp' stmts) =
text "for" <+> parens (pretty name <+> text "in" <+> pretty exp') <+> prettyBlock stmts
instance PrettyPrec JSForStatement
instance Pretty JSDoStatement where
pretty (JSDoStatement stmts cond) =
text "do" <+> prettyBlock stmts <+> text "while" <+>
parens (pretty cond) <> semi
instance PrettyPrec JSDoStatement
instance Pretty JSWhileStatement where
pretty (JSWhileStatement cond stmts) =
text "while" <+> parens (pretty cond) <+> prettyBlock stmts
instance PrettyPrec JSWhileStatement
instance Pretty JSTryStatement where
pretty (JSTryStatement tryStmts varName catchStmts) =
text "try" <+> prettyBlock tryStmts <+> parens (pretty varName) <+> prettyBlock catchStmts
instance PrettyPrec JSTryStatement
instance Pretty JSThrowStatement where
pretty (JSThrowStatement exp_) =
text "throw" <+> pretty exp_ <> semi
instance PrettyPrec JSThrowStatement
instance Pretty JSReturnStatement where
pretty (JSReturnStatement mbExp) = case mbExp of
Nothing -> text "return;"
Just exp_ -> text "return" <+> pretty exp_ <> semi
instance PrettyPrec JSReturnStatement
instance Pretty JSBreakStatement where
pretty (JSBreakStatement mbExp) = case mbExp of
Nothing -> text "break;"
Just exp_ -> text "break" <+> pretty exp_ <> semi
instance PrettyPrec JSBreakStatement
instance Pretty JSExpressionStatement where
pretty (JSESApply lvalues rvalue) =
sepWith' (space <> text "=" <> space) lvalues <+> pretty rvalue
pretty (JSESDelete exp_ refine) =
text "delete" <+> pretty exp_ <> pretty refine
instance PrettyPrec JSExpressionStatement
instance Pretty JSLValue where
pretty (JSLValue name invsAndRefines) = pretty name <> (hcat . map ppIR $ invsAndRefines)
where
ppIR (invs, refine) = (hcat . map pretty $ invs) <> pretty refine
instance PrettyPrec JSLValue
instance Pretty JSRValue where
pretty rvalue = case rvalue of
JSRVAssign e -> text "=" <+> pretty e
JSRVAddAssign e -> text "+=" <+> pretty e
JSRVSubAssign e -> text "-=" <+> pretty e
JSRVInvoke invs -> hcat . toList . fmap pretty $ invs
instance PrettyPrec JSRValue
instance Pretty JSExpression where
pretty = prettyPrec 0
instance PrettyPrec JSExpression where
prettyPrec i exp_ = case exp_ of
JSExpressionLiteral literal -> pretty literal
JSExpressionName name -> pretty name
JSExpressionPrefix prefixOp e -> pretty prefixOp <> pretty e
JSExpressionInfix infixOp e e' -> prettyInfixOpApp i (infixOpInfo infixOp) e e'
JSExpressionTernary cond thn els ->
pretty cond <+> char '?' <+> pretty thn <+> colon <+> pretty els
JSExpressionInvocation e i' -> pretty e <> pretty i'
JSExpressionRefinement e r -> pretty e <> pretty r
JSExpressionNew e i' -> text "new" <+> pretty e <> pretty i'
JSExpressionDelete e r -> text "new" <+> pretty e <> pretty r
instance Pretty JSPrefixOperator where
pretty op = case op of
JSTypeOf -> text "typeof" <+> empty
JSToNumber -> char '+'
JSNegate -> char '-'
JSNot -> char '!'
instance PrettyPrec JSPrefixOperator --default
instance Pretty JSInfixOperator where
pretty = prettyPrec 0
instance PrettyPrec JSInfixOperator where
prettyPrec = error "we never print an operator by itself"
instance Pretty JSInvocation where
pretty (JSInvocation es) = lparen <> sepWith (comma <+> empty) es <> rparen
instance PrettyPrec JSInvocation
instance Pretty JSRefinement where
pretty (JSProperty name) = char '.' <> pretty name
pretty (JSSubscript e) = char '[' <> pretty e <> char ']'
instance PrettyPrec JSRefinement
instance Pretty JSLiteral where
pretty lit = case lit of
JSLiteralNumber n -> pretty n
JSLiteralBool b -> pretty b
JSLiteralString s -> pretty s
JSLiteralObject o -> pretty o
JSLiteralArray a -> pretty a
JSLiteralFunction f -> pretty f
instance PrettyPrec JSLiteral
instance Pretty JSObjectLiteral where
pretty (JSObjectLiteral fields) = lbrace <> sepWith (comma <$> empty) fields <> rbrace
instance PrettyPrec JSObjectLiteral
instance Pretty JSObjectField where
pretty (JSObjectField eitherNameString e) = ppEitherNameString <> colon <+> pretty e
where ppEitherNameString = case eitherNameString of
Left name -> pretty name
Right s -> pretty s
instance PrettyPrec JSObjectField
instance Pretty JSArrayLiteral where
pretty (JSArrayLiteral es) = lbracket <> sepWith (comma <+> empty) es <> rbracket
instance PrettyPrec JSArrayLiteral
instance Pretty JSFunctionLiteral where
pretty (JSFunctionLiteral mbName params body) =
text "function" `join` (parens . hcat . map pretty $ params) <+> pretty body
where join = case mbName of
Just name -> (\a b -> a <+> pretty name <> b)
Nothing -> (<>)
instance PrettyPrec JSFunctionLiteral
instance Pretty JSFunctionBody where
pretty (JSFunctionBody varStmts stmts) =
lbrace <$>
indent 2 (sepWith (semi <$> empty) (map pretty varStmts ++ map pretty stmts)) <$>
rbrace
instance PrettyPrec JSFunctionBody
instance Pretty JSProgram where
pretty (JSProgram varStmts stmts) = vcat (map pretty varStmts ++ map pretty stmts)