summaryrefslogtreecommitdiff
path: root/src/Language/ECMAScript3/PrettyPrint.hs
blob: fa0a30982f59ee44a74af7ed2f16aef73dd5c5e3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

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

import Text.PrettyPrint.Leijen hiding (Pretty)
import Language.ECMAScript3.Syntax
import Prelude hiding (maybe, id)
import Data.Char
import Numeric

{-# DEPRECATED PP, javaScript, renderStatements, renderExpression "These interfaces are outdated and would be removed/hidden in version 1.0. Use the Pretty class instead." #-}

-- | A class of pretty-printable ECMAScript AST nodes. Will
-- pretty-print correct JavaScript given that the 'isValid' predicate
-- holds for the AST.
class Pretty a where
  -- | Pretty-print an ECMAScript AST node. Use 'render' or 'show' to
  -- convert 'Doc' to 'String'.
  prettyPrint :: a -> Doc

instance Pretty (JavaScript a) where
  prettyPrint (Script _ ss) = prettyPrint ss

instance Pretty [Statement a] where 
  prettyPrint = vcat . map prettyPrint

instance Pretty (Expression a) where 
  prettyPrint = ppExpression True

instance Pretty (Statement a) where 
  prettyPrint s = case s of
    BlockStmt _ ss -> asBlock ss
    EmptyStmt _ -> semi
    ExprStmt _ e | unsafeInExprStmt (e) -> parens (ppExpression True e) <> semi
    ExprStmt _ e | otherwise            -> ppExpression True e <> semi
    IfSingleStmt _ test cons -> text "if" <+> 
                                parens (ppExpression True test) </> 
                                (nest 3 $ prettyPrint cons)
    IfStmt _ test cons alt -> text "if" <+> parens (ppExpression True test) </>
                              (nest 3 $ prettyPrint cons) </> text "else"
                              <+> (nest 3 $ prettyPrint alt)
    SwitchStmt _ e cases ->
      text "switch" <+> parens (ppExpression True e) <$>
      braces (nest 3 (vcat (map prettyPrint cases)))
    WhileStmt _ test body -> text "while" <+> parens (ppExpression True test) </>
                             prettyPrint body
    ReturnStmt _ Nothing -> text "return" <> semi
    ReturnStmt _ (Just e) -> text "return" <+> ppExpression True e <> semi
    DoWhileStmt _ s e -> 
      text "do" </> 
      (prettyPrint s </> text "while" <+> parens (ppExpression True e)
       <> semi)
    BreakStmt _ Nothing ->  text "break" <> semi
    BreakStmt _ (Just label) -> text "break" <+> prettyPrint label <> semi
    ContinueStmt _ Nothing -> text "continue" <> semi
    ContinueStmt _ (Just label) -> text"continue" <+> prettyPrint label
                                   <> semi
    LabelledStmt _ label s -> prettyPrint label <> colon </> prettyPrint s
    ForInStmt p init e body -> 
      text "for" <+> 
      parens (prettyPrint init <+> text "in" <+> ppExpression True e) </> 
      prettyPrint body
    ForStmt _ init incr test body ->
      text "for" <+> 
      parens (prettyPrint init <> semi <+> maybe incr (ppExpression True) <> 
              semi <+> maybe test (ppExpression True)) </> 
      prettyPrint 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 cc -> prettyPrint cc
    ThrowStmt _ e -> text "throw" <+> ppExpression True e <> semi
    WithStmt _ e s -> text "with" <+> parens (ppExpression True e)
                      </> prettyPrint s
    VarDeclStmt _ decls ->
      text "var" <+> cat (punctuate comma (map (ppVarDecl True) decls))
      <> semi
    FunctionStmt _ name args body ->
      text "function" <+> prettyPrint name <> 
      parens (cat $ punctuate comma (map prettyPrint args)) <+>
      asBlock body

-- | A predicate to tell if the expression --when pretty-printed--
-- will begin with "function" or '{' and be thus unsafe to use in an
-- expression statement without wrapping it in '()'.
unsafeInExprStmt :: Expression a -> Bool
-- property: forall e. unsafeInExprStmt(e) <==> prettyPrint(e) begins
-- with "function" or '{'
unsafeInExprStmt = unsafeInExprStmt_ 15
  where unsafeInExprStmt_ prec e =
          case e of
            ObjectLit {} -> True
            DotRef _ obj _ | prec >= 1 -> unsafeInExprStmt_ 1 obj
            BracketRef _ obj _ | prec > 0 -> unsafeInExprStmt_ 1 obj
            UnaryAssignExpr a op lv | (op `elem` [PostfixInc, PostfixDec])
                                      && (prec > 3) -> unsafeLv 2 lv
            InfixExpr _ _ l _ | prec >= 5  -> unsafeInExprStmt_ 5 l
            CondExpr _ c _ _ | prec >= 12 -> unsafeInExprStmt_ 12 c
            AssignExpr _ _ lv _ | prec >= 13 -> unsafeLv 2 lv
            ListExpr _ (e:_) | prec >= 14 -> unsafeInExprStmt_ 14 e
            CallExpr _ e _ | prec >= 2 -> unsafeInExprStmt_ 2 e
            FuncExpr {} -> True
            _ -> False
        unsafeLv prec lv = case lv of
          LVar {} -> False
          LDot _ obj _ -> unsafeInExprStmt_ prec obj
          LBracket _ obj _ -> unsafeInExprStmt_ prec obj
            
instance Pretty (CatchClause a) where
  prettyPrint (CatchClause _ id s) =
    text "catch" <+> (parens.prettyPrint) id <+> inBlock s

instance Pretty (ForInit a) where 
  prettyPrint t = case t of
    NoInit     -> empty
    VarInit vs -> text "var"
                  <+> cat (punctuate comma $ map (ppVarDecl False) vs)
    ExprInit e -> ppExpression False e

instance Pretty (ForInInit a) where
  prettyPrint t = case t of
    ForInVar id  -> text "var" <+> prettyPrint id
    ForInLVal lv -> prettyPrint lv

instance Pretty (LValue a) where 
  prettyPrint lv = case lv of
    LVar _ x -> printIdentifierName x
    LDot _ e x -> ppObjInDotRef e ppMemberExpression <> text "." <> printIdentifierName x
    LBracket _ e1 e2 -> ppMemberExpression e1 <> 
                        brackets (ppExpression True e2)

instance Pretty (VarDecl a) where
  prettyPrint = ppVarDecl True

instance Pretty (CaseClause a) where
  prettyPrint c = case c of
    CaseClause _ e ss -> 
      text "case" <+> ppExpression True e <> colon </> nest 2 (prettyPrint ss)
    CaseDefault _ ss -> text "default:" </> nest 2 (prettyPrint ss)

instance Pretty InfixOp where 
   prettyPrint 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 -> "||"

instance Pretty AssignOp where 
  prettyPrint op = text $ case op of
    OpAssign -> "="
    OpAssignAdd -> "+="
    OpAssignSub -> "-="
    OpAssignMul -> "*="
    OpAssignDiv -> "/="
    OpAssignMod -> "%="
    OpAssignLShift -> "<<="
    OpAssignSpRShift -> ">>="
    OpAssignZfRShift -> ">>>="
    OpAssignBAnd -> "&="
    OpAssignBXor -> "^="
    OpAssignBOr -> "|="

instance Pretty PrefixOp where 
  prettyPrint op = text $ case op of
    PrefixLNot -> "!"
    PrefixBNot -> "~"
    PrefixPlus -> "+"
    PrefixMinus -> "-"
    PrefixTypeof -> "typeof"
    PrefixVoid -> "void"
    PrefixDelete -> "delete"

instance Pretty (Prop a) where
  prettyPrint p = case p of
    PropId _ id -> prettyPrint id
    PropString _ str -> dquotes $ text $ jsEscape str
    PropNum _ n -> text (show n)

instance Pretty (Id a) where
  prettyPrint (Id _ str) = printIdentifierName str

class PP a where 
  pp :: a -> Doc

instance Pretty a => PP a where 
  pp = prettyPrint

-- | DEPRECATED: Use 'prettyPrint' instead! Renders a JavaScript
-- program as a document, the show instance of 'Doc' will pretty-print
-- it automatically
javaScript :: JavaScript a -> Doc
javaScript = prettyPrint

-- | DEPRECATED: Use 'prettyPrint' instead! Renders a list of
-- statements as a 'String'
renderStatements :: [Statement a] -> String
renderStatements = show . prettyPrint

-- | DEPRECATED: Use 'prettyPrint' instead! Renders a list of
-- statements as a 'String'
renderExpression :: Expression a -> String
renderExpression = show . prettyPrint

-- Displays the statement in { ... }, unless it is a block itself.
inBlock:: Statement a -> Doc
inBlock s@(BlockStmt _ _) = prettyPrint s
inBlock s                 = asBlock [s]

asBlock :: [Statement a] -> Doc
asBlock [] = lbrace <$$> rbrace
asBlock ss = lbrace <> line <> (indentBlock $ prettyPrint ss) <$$> rbrace

indentBlock :: Doc -> Doc
indentBlock = indent 3

ppVarDecl :: Bool -> VarDecl a -> Doc
ppVarDecl hasIn vd = case vd of
  VarDecl _ id Nothing  -> prettyPrint id
  VarDecl _ id (Just e) -> prettyPrint id <+> equals
                           <+> ppAssignmentExpression hasIn e

-- | Pretty prints a string assuming it's used as an
-- identifier. Escapes characters that are disallowed by the grammar
-- with unicode escape sequences, so that the resulting program can be
-- parsed later. Note that it does not (and could not) do anything
-- about identifier names that are reserved words as well as empty
-- identifier names.
printIdentifierName :: String -> Doc
printIdentifierName = text . adapt 
  where adapt [] = []
        adapt (c:cs) = (adaptStart c) ++ (concatMap adaptRest cs)
        adaptStart c = if validIdStart c then [c]
                       else unicodeEscape c
        adaptRest c = if validIdPart c then [c]
                      else unicodeEscape c
        validIdStart c = unicodeLetter c
                      || c == '$'
                      || c == '_'
        validIdPart c = validIdStart c
                     || validIdPartUnicode c
        unicodeLetter c = case generalCategory c of
          UppercaseLetter -> True
          LowercaseLetter -> True
          TitlecaseLetter -> True
          ModifierLetter  -> True
          OtherLetter     -> True
          LetterNumber    -> True
          _               -> False
        validIdPartUnicode c = case generalCategory c of
          NonSpacingMark       -> True
          SpacingCombiningMark -> True
          DecimalNumber        -> True
          ConnectorPunctuation -> True
          _                    -> False
        -- escapes a given character converting it into a 16-bit
        -- unicode escape sequence
        unicodeEscape :: Char -> String
        unicodeEscape c = "\\u" ++ showHex (ord c) ""

-- 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.

-- | Escapes a regular expression so that it can be parsed correctly afterwards
regexpEscape :: String -> String
regexpEscape = regexpEscapeChar True
  where regexpEscapeChar :: Bool -- ^ First char?
                         -> String -> String
        regexpEscapeChar first s = 
          case (s, first) of
            ("", True) -> "(?:)"
            ("", False)-> ""
            -- see spec 7.8.5, RegularExpressionFirstChar
            ("\\", _) -> "\\\\"
            ('\\':c:rest, _) -> '\\':c:(regexpEscapeChar False rest)
            ('/':rest, _) -> '\\':'/':regexpEscapeChar False rest
            ('*':rest, True) -> ('\\':'*':regexpEscapeChar False rest)
            (c:rest, _)   -> c:regexpEscapeChar False rest

-- 11.1
ppPrimaryExpression :: Expression a -> Doc
ppPrimaryExpression e = case e of
  ThisRef _ -> text "this"
  VarRef _ id -> prettyPrint id
  NullLit _ -> text "null"
  BoolLit _ True -> text "true"
  BoolLit _ False -> text "false"
  NumLit  _ n -> double n
  IntLit _ n ->  int n
  StringLit _ str -> dquotes $ text $ jsEscape str
  RegexpLit _ reg g ci -> text "/" <> (text (regexpEscape reg)) <> text "/" <>
                          (if g then text "g" else empty) <> 
                          (if ci then text "i" else empty)
  ArrayLit _ es -> list $ map (ppAssignmentExpression True) es
  ObjectLit _ xs -> encloseSep lbrace rbrace comma $ map ppField xs
    where ppField (f,v)= prettyPrint f <> colon <+> ppAssignmentExpression True v
  _ -> parens $ ppExpression True e

-- 11.2
ppMemberExpression :: Expression a -> Doc
ppMemberExpression e = case e of
  FuncExpr _ name params body -> 
    text "function" <+> maybe name (\n -> prettyPrint n <> space) <>
    parens (cat $ punctuate comma (map prettyPrint params)) <+>
    asBlock body
  DotRef _ obj id -> ppObjInDotRef obj ppMemberExpression <> text "." <> prettyPrint id
  BracketRef _ obj key -> 
    ppMemberExpression obj <> brackets (ppExpression True key)  
  NewExpr _ ctor args -> 
    text "new" <+> ppMemberExpression ctor <> ppArguments args
  _ -> ppPrimaryExpression e

ppCallExpression :: Expression a -> Doc
ppCallExpression e = case e of
  CallExpr _ f args -> ppCallExpression f <> ppArguments args
  DotRef _ obj id -> ppObjInDotRef obj ppCallExpression <> text "." <> prettyPrint id
  BracketRef _ obj key -> ppCallExpression obj
                          <> brackets (ppExpression True key)
  _ -> ppMemberExpression e

ppObjInDotRef :: Expression a -> (Expression a -> Doc) -> Doc
ppObjInDotRef i@(IntLit _ _) _ = parens (ppPrimaryExpression i)
ppObjInDotRef e p              = p e

ppArguments :: [Expression a] -> Doc
ppArguments es = 
  parens $ cat $ punctuate comma (map (ppAssignmentExpression True) es)

ppLHSExpression :: Expression a -> Doc
ppLHSExpression = ppCallExpression

-- 11.3
ppPostfixExpression :: Expression a -> Doc
ppPostfixExpression e = case e of
  UnaryAssignExpr _ PostfixInc e' -> prettyPrint e' <> text "++"
  UnaryAssignExpr _ PostfixDec e' -> prettyPrint e' <> text "--"
  _ -> ppLHSExpression e
  
-- 11.4
ppUnaryExpression :: Expression a -> Doc
ppUnaryExpression e = case e of
  PrefixExpr _ op e' -> prettyPrint op <> prefixSpace op <> ppUnaryExpression e'
  UnaryAssignExpr _ PrefixInc e' -> text "++" <> prettyPrint e'
  UnaryAssignExpr _ PrefixDec e' -> text "--" <> prettyPrint e'
  _ -> ppPostfixExpression e

prefixSpace :: PrefixOp -> Doc
prefixSpace op = case op of
  PrefixLNot   -> empty
  PrefixBNot   -> empty
  PrefixPlus   -> empty
  PrefixMinus  -> empty
  PrefixTypeof -> space
  PrefixVoid   -> space
  PrefixDelete -> space

-- 11.5
ppMultiplicativeExpression :: Expression a -> Doc
ppMultiplicativeExpression e = case e of
  InfixExpr _ op e1 e2 | op `elem` [OpMul, OpDiv, OpMod] -> 
    ppMultiplicativeExpression e1 <+> prettyPrint op <+> ppUnaryExpression e2
  _ -> ppUnaryExpression e
  
-- 11.6
ppAdditiveExpression :: Expression a -> Doc
ppAdditiveExpression e = case e of
  InfixExpr _ op e1 e2 | op `elem` [OpAdd, OpSub] -> 
    ppAdditiveExpression e1 <+> prettyPrint op
    <+> ppMultiplicativeExpression e2
  _ -> ppMultiplicativeExpression e

-- 11.7
ppShiftExpression :: Expression a -> Doc
ppShiftExpression e = case e of
  InfixExpr _ op e1 e2 | op `elem` [OpLShift, OpSpRShift, OpZfRShift] -> 
    ppShiftExpression e1 <+> prettyPrint op <+> ppAdditiveExpression e2  
  _ -> ppAdditiveExpression e

-- 11.8.  
-- | @ppRelationalExpression True@ is RelationalExpression,
-- @ppRelationalExpression False@ is RelationalExpressionNoIn
ppRelationalExpression :: Bool -> Expression a -> Doc
ppRelationalExpression hasIn e = 
  let opsNoIn = [OpLT, OpGT, OpLEq, OpGEq, OpInstanceof]
      ops     = if hasIn then OpIn:opsNoIn else opsNoIn
  in case e of    
    InfixExpr _ op e1 e2 | op `elem` ops -> 
      ppRelationalExpression hasIn e1 <+> prettyPrint op
      <+> ppShiftExpression e2
    _ -> ppShiftExpression e
    
-- 11.9
ppEqualityExpression :: Bool -> Expression a -> Doc
ppEqualityExpression hasIn e = case e of
  InfixExpr _ op e1 e2 | op `elem` [OpEq, OpNEq, OpStrictEq, OpStrictNEq] ->
    ppEqualityExpression hasIn e1 <+> prettyPrint op <+> 
    ppRelationalExpression hasIn e2
  _ -> ppRelationalExpression hasIn e
  
-- 11.10
ppBitwiseANDExpression :: Bool -> Expression a -> Doc
ppBitwiseANDExpression hasIn e = case e of
  InfixExpr _ op@OpBAnd e1 e2 -> ppBitwiseANDExpression hasIn e1 <+> 
                                 prettyPrint op <+>
                                 ppEqualityExpression hasIn e2
  _ -> ppEqualityExpression hasIn e
  
ppBitwiseXORExpression :: Bool -> Expression a -> Doc
ppBitwiseXORExpression hasIn e = case e of
  InfixExpr _ op@OpBXor e1 e2 -> ppBitwiseXORExpression hasIn e1 <+>
                                 prettyPrint op <+>
                                 ppBitwiseANDExpression hasIn e2
  _ -> ppBitwiseANDExpression hasIn e
  
ppBitwiseORExpression :: Bool -> Expression a -> Doc
ppBitwiseORExpression hasIn e = case e of
  InfixExpr _ op@OpBOr e1 e2 -> ppBitwiseORExpression hasIn e1 <+>
                                prettyPrint op <+>
                                ppBitwiseXORExpression hasIn e2
  _ -> ppBitwiseXORExpression hasIn e

-- 11.11
ppLogicalANDExpression :: Bool -> Expression a -> Doc
ppLogicalANDExpression hasIn e = case e of
  InfixExpr _ op@OpLAnd e1 e2 -> ppLogicalANDExpression hasIn e1 <+>
                                 prettyPrint op <+>
                                 ppBitwiseORExpression hasIn e2
  _ -> ppBitwiseORExpression hasIn e                                 
                                 
ppLogicalORExpression :: Bool -> Expression a -> Doc
ppLogicalORExpression hasIn e = case e of
  InfixExpr _ op@OpLOr e1 e2 -> ppLogicalORExpression hasIn e1 <+>
                                prettyPrint op <+>
                                ppLogicalANDExpression hasIn e2
  _ -> ppLogicalANDExpression hasIn e
  
-- 11.12
ppConditionalExpression :: Bool -> Expression a -> Doc
ppConditionalExpression hasIn e = case e of
  CondExpr _ c et ee -> ppLogicalORExpression hasIn c <+> text "?" <+> 
                        ppAssignmentExpression hasIn et <+> colon <+>
                        ppAssignmentExpression hasIn ee
  _ -> ppLogicalORExpression hasIn e

-- 11.13
ppAssignmentExpression :: Bool -> Expression a -> Doc
ppAssignmentExpression hasIn e = case e of
  AssignExpr _ op l r -> prettyPrint l <+> prettyPrint op <+> 
                         ppAssignmentExpression hasIn r
  _ -> ppConditionalExpression hasIn e
  
-- 11.14
ppExpression :: Bool -> Expression a -> Doc
ppExpression hasIn e = case e of
  ListExpr _ es -> cat $ punctuate comma (map (ppExpression hasIn) es)
  _ -> ppAssignmentExpression hasIn e

maybe :: Maybe a -> (a -> Doc) -> Doc
maybe Nothing  _ = empty
maybe (Just a) f = f a