-- |Pretty-printing JavaScript.
module Language.ECMAScript3.PrettyPrint
  ( 
--    stmt
--  , expr
  javaScript
  , renderStatements
  , renderExpression
  ) where

import Text.PrettyPrint.HughesPJ
import Language.ECMAScript3.Syntax

-- | Renders a list of statements as a 'String'
renderStatements :: [Statement a] -> String
renderStatements = render . stmtList

-- | Renders a list of statements as a 'String'
renderExpression :: Expression a -> String
renderExpression = render . expr

-- Displays the statement in { ... }, unless it is a block itself.
inBlock:: Statement a -> Doc
inBlock s@(BlockStmt _ _) = stmt s
inBlock s                 = lbrace $+$ nest 2 (stmt s) $+$ rbrace

-- Displays the expression in ( ... ), unless it is a parenthesized expression
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 -> "|="

-- Based on:
--   http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals
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]
    -- We don't have to do anything about \X, \x and \u escape sequences.

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

-- | Renders a JavaScript program as a document, the show instance of
-- 'Doc' will pretty-print it automatically
javaScript :: JavaScript a -> Doc
javaScript (Script _ ss) = stmtList ss