{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}

-- For Outputable instances for JS syntax
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Pretty-printing JavaScript
module GHC.JS.Ppr
  ( renderJs
  , renderJs'
  , renderPrefixJs
  , renderPrefixJs'
  , JsToDoc(..)
  , defaultRenderJs
  , RenderJs(..)
  , jsToDoc
  , pprStringLit
  , flattenBlocks
  , braceNest
  , hangBrace
  )
where

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Transform


import Data.Char (isControl, ord)
import Data.List (sortOn)

import Numeric(showHex)

import GHC.Utils.Outputable (Outputable (..), docToSDoc)
import GHC.Utils.Ppr as PP
import GHC.Data.FastString
import GHC.Types.Unique.Map

instance Outputable JExpr where
  ppr :: JExpr -> SDoc
ppr = Doc -> SDoc
docToSDoc (Doc -> SDoc) -> (JExpr -> Doc) -> JExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JExpr -> Doc
forall a. (JsToDoc a, JMacro a) => a -> Doc
renderJs

instance Outputable JVal where
  ppr :: JVal -> SDoc
ppr = Doc -> SDoc
docToSDoc (Doc -> SDoc) -> (JVal -> Doc) -> JVal -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JVal -> Doc
forall a. (JsToDoc a, JMacro a) => a -> Doc
renderJs


($$$) :: Doc -> Doc -> Doc
Doc
x $$$ :: Doc -> Doc -> Doc
$$$ Doc
y = Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
x Doc -> Doc -> Doc
$+$ Doc
y

-- | Render a syntax tree as a pretty-printable document
-- (simply showing the resultant doc produces a nice,
-- well formatted String).
renderJs :: (JsToDoc a, JMacro a) => a -> Doc
renderJs :: forall a. (JsToDoc a, JMacro a) => a -> Doc
renderJs = RenderJs -> a -> Doc
forall a. (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderJs' RenderJs
defaultRenderJs

renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderJs' :: forall a. (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderJs' RenderJs
r = RenderJs -> a -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (a -> Doc) -> (a -> a) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FastString -> a -> a
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate Maybe FastString
forall a. Maybe a
Nothing

data RenderJs = RenderJs
  { RenderJs -> RenderJs -> JStat -> Doc
renderJsS :: !(RenderJs -> JStat -> Doc)
  , RenderJs -> RenderJs -> JExpr -> Doc
renderJsE :: !(RenderJs -> JExpr -> Doc)
  , RenderJs -> RenderJs -> JVal -> Doc
renderJsV :: !(RenderJs -> JVal  -> Doc)
  , RenderJs -> RenderJs -> Ident -> Doc
renderJsI :: !(RenderJs -> Ident -> Doc)
  }

defaultRenderJs :: RenderJs
defaultRenderJs :: RenderJs
defaultRenderJs = (RenderJs -> JStat -> Doc)
-> (RenderJs -> JExpr -> Doc)
-> (RenderJs -> JVal -> Doc)
-> (RenderJs -> Ident -> Doc)
-> RenderJs
RenderJs RenderJs -> JStat -> Doc
defRenderJsS RenderJs -> JExpr -> Doc
defRenderJsE RenderJs -> JVal -> Doc
defRenderJsV RenderJs -> Ident -> Doc
defRenderJsI

jsToDoc :: JsToDoc a => a -> Doc
jsToDoc :: forall a. JsToDoc a => a -> Doc
jsToDoc = RenderJs -> a -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
defaultRenderJs

-- | Render a syntax tree as a pretty-printable document, using a given prefix
-- to all generated names. Use this with distinct prefixes to ensure distinct
-- generated names between independent calls to render(Prefix)Js.
renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc
renderPrefixJs :: forall a. (JsToDoc a, JMacro a) => FastString -> a -> Doc
renderPrefixJs FastString
pfx = RenderJs -> FastString -> a -> Doc
forall a.
(JsToDoc a, JMacro a) =>
RenderJs -> FastString -> a -> Doc
renderPrefixJs' RenderJs
defaultRenderJs FastString
pfx

renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc
renderPrefixJs' :: forall a.
(JsToDoc a, JMacro a) =>
RenderJs -> FastString -> a -> Doc
renderPrefixJs' RenderJs
r FastString
pfx = RenderJs -> a -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (a -> Doc) -> (a -> a) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FastString -> a -> a
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ FastString
"jmId_" FastString -> FastString -> FastString
forall a. Monoid a => a -> a -> a
`mappend` FastString
pfx)

braceNest :: Doc -> Doc
braceNest :: Doc -> Doc
braceNest Doc
x = Char -> Doc
char Char
'{' Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
2 Doc
x Doc -> Doc -> Doc
$$ Char -> Doc
char Char
'}'

-- | Hang with braces:
--
--  hdr {
--    body
--  }
hangBrace :: Doc -> Doc -> Doc
hangBrace :: Doc -> Doc -> Doc
hangBrace Doc
hdr Doc
body = [Doc] -> Doc
sep [ Doc
hdr Doc -> Doc -> Doc
<> Char -> Doc
char Char
' ' Doc -> Doc -> Doc
<> Char -> Doc
char Char
'{', Int -> Doc -> Doc
nest Int
2 Doc
body, Char -> Doc
char Char
'}' ]

class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
instance JsToDoc JStat where jsToDocR :: RenderJs -> JStat -> Doc
jsToDocR RenderJs
r = RenderJs -> RenderJs -> JStat -> Doc
renderJsS RenderJs
r RenderJs
r
instance JsToDoc JExpr where jsToDocR :: RenderJs -> JExpr -> Doc
jsToDocR RenderJs
r = RenderJs -> RenderJs -> JExpr -> Doc
renderJsE RenderJs
r RenderJs
r
instance JsToDoc JVal  where jsToDocR :: RenderJs -> JVal -> Doc
jsToDocR RenderJs
r = RenderJs -> RenderJs -> JVal -> Doc
renderJsV RenderJs
r RenderJs
r
instance JsToDoc Ident where jsToDocR :: RenderJs -> Ident -> Doc
jsToDocR RenderJs
r = RenderJs -> RenderJs -> Ident -> Doc
renderJsI RenderJs
r RenderJs
r
instance JsToDoc [JExpr] where
    jsToDocR :: RenderJs -> [JExpr] -> Doc
jsToDocR RenderJs
r = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([JExpr] -> [Doc]) -> [JExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JExpr -> Doc) -> [JExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc -> Doc
<> Doc
semi) (Doc -> Doc) -> (JExpr -> Doc) -> JExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r)
instance JsToDoc [JStat] where
    jsToDocR :: RenderJs -> [JStat] -> Doc
jsToDocR RenderJs
r = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([JStat] -> [Doc]) -> [JStat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JStat -> Doc) -> [JStat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc -> Doc
<> Doc
semi) (Doc -> Doc) -> (JStat -> Doc) -> JStat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r)

defRenderJsS :: RenderJs -> JStat -> Doc
defRenderJsS :: RenderJs -> JStat -> Doc
defRenderJsS RenderJs
r = \case
  IfStat JExpr
cond JStat
x JStat
y -> Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"if" Doc -> Doc -> Doc
<> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
cond))
                               (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x)
                     Doc -> Doc -> Doc
$$ Doc
mbElse
        where mbElse :: Doc
mbElse | JStat
y JStat -> JStat -> Bool
forall a. Eq a => a -> a -> Bool
== [JStat] -> JStat
BlockStat []  = Doc
PP.empty
                     | Bool
otherwise = Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"else") (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
y)
  DeclStat Ident
x Maybe JExpr
Nothing  -> String -> Doc
text String
"var" Doc -> Doc -> Doc
<+> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
x
  DeclStat Ident
x (Just JExpr
e) -> String -> Doc
text String
"var" Doc -> Doc -> Doc
<+> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
x Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e
  WhileStat Bool
False JExpr
p JStat
b -> Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"while" Doc -> Doc -> Doc
<> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
p)) (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
  WhileStat Bool
True  JExpr
p JStat
b -> (Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"do") (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)) Doc -> Doc -> Doc
$+$ String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
p)
  UnsatBlock IdentSupply JStat
e        -> RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (JStat -> Doc) -> JStat -> Doc
forall a b. (a -> b) -> a -> b
$ IdentSupply JStat -> JStat
forall a. IdentSupply a -> a
pseudoSaturate IdentSupply JStat
e
  BreakStat Maybe LexicalFastString
l         -> Doc -> (LexicalFastString -> Doc) -> Maybe LexicalFastString -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"break")    (\(LexicalFastString FastString
s) -> (String -> Doc
text String
"break"    Doc -> Doc -> Doc
<+> FastString -> Doc
ftext FastString
s)) Maybe LexicalFastString
l
  ContinueStat Maybe LexicalFastString
l      -> Doc -> (LexicalFastString -> Doc) -> Maybe LexicalFastString -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"continue") (\(LexicalFastString FastString
s) -> (String -> Doc
text String
"continue" Doc -> Doc -> Doc
<+> FastString -> Doc
ftext FastString
s)) Maybe LexicalFastString
l
  LabelStat (LexicalFastString FastString
l) JStat
s -> FastString -> Doc
ftext FastString
l Doc -> Doc -> Doc
<> Char -> Doc
char Char
':' Doc -> Doc -> Doc
$$ JStat -> Doc
printBS JStat
s
        where
          printBS :: JStat -> Doc
printBS (BlockStat [JStat]
ss) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [JStat] -> [Doc]
interSemi ([JStat] -> [Doc]) -> [JStat] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [JStat] -> [JStat]
flattenBlocks [JStat]
ss
          printBS JStat
x = RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x
          interSemi :: [JStat] -> [Doc]
interSemi [JStat
x] = [RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x]
          interSemi [] = []
          interSemi (JStat
x:[JStat]
xs) = (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x Doc -> Doc -> Doc
<> Doc
semi) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [JStat] -> [Doc]
interSemi [JStat]
xs

  ForInStat Bool
each Ident
i JExpr
e JStat
b -> Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
txt Doc -> Doc -> Doc
<> Doc -> Doc
parens (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e)) (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
        where txt :: String
txt | Bool
each = String
"for each"
                  | Bool
otherwise = String
"for"
  SwitchStat JExpr
e [(JExpr, JStat)]
l JStat
d     -> Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"switch" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e)) Doc
cases
        where l' :: [Doc]
l' = ((JExpr, JStat) -> Doc) -> [(JExpr, JStat)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(JExpr
c,JStat
s) -> (String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
c) Doc -> Doc -> Doc
<> Char -> Doc
char Char
':') Doc -> Doc -> Doc
$$$ (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s)) [(JExpr, JStat)]
l [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text String
"default:" Doc -> Doc -> Doc
$$$ (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
d)]
              cases :: Doc
cases = [Doc] -> Doc
vcat [Doc]
l'
  ReturnStat JExpr
e      -> String -> Doc
text String
"return" Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e
  ApplStat JExpr
e [JExpr]
es     -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (JExpr -> Doc) -> [JExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) [JExpr]
es)
  TryStat JStat
s Ident
i JStat
s1 JStat
s2 -> Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"try") (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s) Doc -> Doc -> Doc
$$ Doc
mbCatch Doc -> Doc -> Doc
$$ Doc
mbFinally
        where mbCatch :: Doc
mbCatch | JStat
s1 JStat -> JStat -> Bool
forall a. Eq a => a -> a -> Bool
== [JStat] -> JStat
BlockStat [] = Doc
PP.empty
                      | Bool
otherwise = Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"catch" Doc -> Doc -> Doc
<> Doc -> Doc
parens (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i)) (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s1)
              mbFinally :: Doc
mbFinally | JStat
s2 JStat -> JStat -> Bool
forall a. Eq a => a -> a -> Bool
== [JStat] -> JStat
BlockStat [] = Doc
PP.empty
                        | Bool
otherwise = Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"finally") (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s2)
  AssignStat JExpr
i JExpr
x    -> case JExpr
x of
    -- special treatment for functions, otherwise there is too much left padding
    -- (more than the length of the expression assigned to). E.g.
    --
    --    var long_variable_name = (function()
    --                               {
    --                               ...
    --                             });
    --
    ValExpr (JFunc [Ident]
is JStat
b) -> [Doc] -> Doc
sep [RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
i Doc -> Doc -> Doc
<+> String -> Doc
text String
"= function" Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Ident] -> [Doc]) -> [Ident] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([Ident] -> [Doc]) -> [Ident] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) ([Ident] -> Doc) -> [Ident] -> Doc
forall a b. (a -> b) -> a -> b
$ [Ident]
is) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'{', Int -> Doc -> Doc
nest Int
2 (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b), String -> Doc
text String
"}"]
    JExpr
_                    -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x
  UOpStat JUOp
op JExpr
x
    | JUOp -> Bool
isPre JUOp
op Bool -> Bool -> Bool
&& JUOp -> Bool
isAlphaOp JUOp
op -> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op) Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x
    | JUOp -> Bool
isPre JUOp
op                 -> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op) Doc -> Doc -> Doc
<> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x
    | Bool
otherwise                -> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x Doc -> Doc -> Doc
<> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op)
  BlockStat [JStat]
xs -> RenderJs -> [JStat] -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r ([JStat] -> [JStat]
flattenBlocks [JStat]
xs)

flattenBlocks :: [JStat] -> [JStat]
flattenBlocks :: [JStat] -> [JStat]
flattenBlocks = \case
  BlockStat [JStat]
y:[JStat]
ys -> [JStat] -> [JStat]
flattenBlocks [JStat]
y [JStat] -> [JStat] -> [JStat]
forall a. [a] -> [a] -> [a]
++ [JStat] -> [JStat]
flattenBlocks [JStat]
ys
  JStat
y:[JStat]
ys           -> JStat
y JStat -> [JStat] -> [JStat]
forall a. a -> [a] -> [a]
: [JStat] -> [JStat]
flattenBlocks [JStat]
ys
  []             -> []

optParens :: RenderJs -> JExpr -> Doc
optParens :: RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x = case JExpr
x of
  UOpExpr JUOp
_ JExpr
_ -> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x)
  JExpr
_           -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x

defRenderJsE :: RenderJs -> JExpr -> Doc
defRenderJsE :: RenderJs -> JExpr -> Doc
defRenderJsE RenderJs
r = \case
  ValExpr JVal
x         -> RenderJs -> JVal -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JVal
x
  SelExpr JExpr
x Ident
y       -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
y
  IdxExpr JExpr
x JExpr
y       -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x Doc -> Doc -> Doc
<> Doc -> Doc
brackets (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y)
  IfExpr JExpr
x JExpr
y JExpr
z      -> Doc -> Doc
parens (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'?' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y Doc -> Doc -> Doc
<+> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
z)
  InfixExpr JOp
op JExpr
x JExpr
y  -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
x, FastString -> Doc
ftext (JOp -> FastString
opText JOp
op), RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y]
  UOpExpr JUOp
op JExpr
x
    | JUOp -> Bool
isPre JUOp
op Bool -> Bool -> Bool
&& JUOp -> Bool
isAlphaOp JUOp
op -> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op) Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x
    | JUOp -> Bool
isPre JUOp
op                 -> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op) Doc -> Doc -> Doc
<> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x
    | Bool
otherwise                -> RenderJs -> JExpr -> Doc
optParens RenderJs
r JExpr
x Doc -> Doc -> Doc
<> FastString -> Doc
ftext (JUOp -> FastString
uOpText JUOp
op)
  ApplExpr JExpr
je [JExpr]
xs -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
je Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (JExpr -> Doc) -> [JExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) [JExpr]
xs)
  UnsatExpr IdentSupply JExpr
e    -> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (JExpr -> Doc) -> JExpr -> Doc
forall a b. (a -> b) -> a -> b
$ IdentSupply JExpr -> JExpr
forall a. IdentSupply a -> a
pseudoSaturate IdentSupply JExpr
e

defRenderJsV :: RenderJs -> JVal -> Doc
defRenderJsV :: RenderJs -> JVal -> Doc
defRenderJsV RenderJs
r = \case
  JVar Ident
i    -> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i
  JList [JExpr]
xs  -> Doc -> Doc
brackets (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (JExpr -> Doc) -> [JExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) [JExpr]
xs
  JDouble (SaneDouble Double
d)
    | Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
d -> Doc -> Doc
parens (Double -> Doc
double Double
d)
    | Bool
otherwise                 -> Double -> Doc
double Double
d
  JInt Integer
i
    | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     -> Doc -> Doc
parens (Integer -> Doc
integer Integer
i)
    | Bool
otherwise -> Integer -> Doc
integer Integer
i
  JStr   FastString
s -> FastString -> Doc
pprStringLit FastString
s
  JRegEx FastString
s -> [Doc] -> Doc
hcat [Char -> Doc
char Char
'/',FastString -> Doc
ftext FastString
s, Char -> Doc
char Char
'/']
  JHash UniqMap FastString JExpr
m
    | UniqMap FastString JExpr -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap FastString JExpr
m  -> String -> Doc
text String
"{}"
    | Bool
otherwise -> Doc -> Doc
braceNest (Doc -> Doc)
-> ([(FastString, JExpr)] -> Doc) -> [(FastString, JExpr)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc)
-> ([(FastString, JExpr)] -> [Doc]) -> [(FastString, JExpr)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc])
-> ([(FastString, JExpr)] -> [Doc])
-> [(FastString, JExpr)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          ((FastString, JExpr) -> Doc) -> [(FastString, JExpr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(FastString
x,JExpr
y) -> Doc -> Doc
squotes (FastString -> Doc
ftext FastString
x) Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y)
                          -- nonDetEltsUniqMap doesn't introduce non-determinism here
                          -- because we sort the elements lexically
                          ([(FastString, JExpr)] -> Doc) -> [(FastString, JExpr)] -> Doc
forall a b. (a -> b) -> a -> b
$ ((FastString, JExpr) -> LexicalFastString)
-> [(FastString, JExpr)] -> [(FastString, JExpr)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FastString -> LexicalFastString
LexicalFastString (FastString -> LexicalFastString)
-> ((FastString, JExpr) -> FastString)
-> (FastString, JExpr)
-> LexicalFastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, JExpr) -> FastString
forall a b. (a, b) -> a
fst) (UniqMap FastString JExpr -> [(FastString, JExpr)]
forall k a. UniqMap k a -> [(k, a)]
nonDetEltsUniqMap UniqMap FastString JExpr
m)
  JFunc [Ident]
is JStat
b -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
hangBrace (String -> Doc
text String
"function" Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Ident] -> [Doc]) -> [Ident] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([Ident] -> [Doc]) -> [Ident] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) ([Ident] -> Doc) -> [Ident] -> Doc
forall a b. (a -> b) -> a -> b
$ [Ident]
is)) (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
  UnsatVal IdentSupply JVal
f -> RenderJs -> JVal -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (JVal -> Doc) -> JVal -> Doc
forall a b. (a -> b) -> a -> b
$ IdentSupply JVal -> JVal
forall a. IdentSupply a -> a
pseudoSaturate IdentSupply JVal
f

defRenderJsI :: RenderJs -> Ident -> Doc
defRenderJsI :: RenderJs -> Ident -> Doc
defRenderJsI RenderJs
_ (TxtI FastString
t) = FastString -> Doc
ftext FastString
t


pprStringLit :: FastString -> Doc
pprStringLit :: FastString -> Doc
pprStringLit FastString
s = [Doc] -> Doc
hcat [Char -> Doc
char Char
'\"',FastString -> Doc
encodeJson FastString
s, Char -> Doc
char Char
'\"']

encodeJson :: FastString -> Doc
encodeJson :: FastString -> Doc
encodeJson FastString
xs = [Doc] -> Doc
hcat ((Char -> Doc) -> String -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Doc
encodeJsonChar (FastString -> String
unpackFS FastString
xs))

encodeJsonChar :: Char -> Doc
encodeJsonChar :: Char -> Doc
encodeJsonChar = \case
  Char
'/'  -> String -> Doc
text String
"\\/"
  Char
'\b' -> String -> Doc
text String
"\\b"
  Char
'\f' -> String -> Doc
text String
"\\f"
  Char
'\n' -> String -> Doc
text String
"\\n"
  Char
'\r' -> String -> Doc
text String
"\\r"
  Char
'\t' -> String -> Doc
text String
"\\t"
  Char
'"'  -> String -> Doc
text String
"\\\""
  Char
'\\' -> String -> Doc
text String
"\\\\"
  Char
c
    | Bool -> Bool
not (Char -> Bool
isControl Char
c) Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
127 -> Char -> Doc
char Char
c
    | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xff   -> String -> Int -> Int -> Doc
forall {a}. Integral a => String -> Int -> a -> Doc
hexxs String
"\\x" Int
2 (Char -> Int
ord Char
c)
    | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xffff -> String -> Int -> Int -> Doc
forall {a}. Integral a => String -> Int -> a -> Doc
hexxs String
"\\u" Int
4 (Char -> Int
ord Char
c)
    | Bool
otherwise      -> let cp0 :: Int
cp0 = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x10000 -- output surrogate pair
                        in String -> Int -> Int -> Doc
forall {a}. Integral a => String -> Int -> a -> Doc
hexxs String
"\\u" Int
4 ((Int
cp0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
10) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0xd800) Doc -> Doc -> Doc
<>
                           String -> Int -> Int -> Doc
forall {a}. Integral a => String -> Int -> a -> Doc
hexxs String
"\\u" Int
4 ((Int
cp0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3ff) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0xdc00)
    where hexxs :: String -> Int -> a -> Doc
hexxs String
prefix Int
pad a
cp =
            let h :: String
h = a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
cp String
""
            in  String -> Doc
text (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
h)

uOpText :: JUOp -> FastString
uOpText :: JUOp -> FastString
uOpText = \case
  JUOp
NotOp     -> FastString
"!"
  JUOp
BNotOp    -> FastString
"~"
  JUOp
NegOp     -> FastString
"-"
  JUOp
PlusOp    -> FastString
"+"
  JUOp
NewOp     -> FastString
"new"
  JUOp
TypeofOp  -> FastString
"typeof"
  JUOp
DeleteOp  -> FastString
"delete"
  JUOp
YieldOp   -> FastString
"yield"
  JUOp
VoidOp    -> FastString
"void"
  JUOp
PreIncOp  -> FastString
"++"
  JUOp
PostIncOp -> FastString
"++"
  JUOp
PreDecOp  -> FastString
"--"
  JUOp
PostDecOp -> FastString
"--"

opText :: JOp -> FastString
opText :: JOp -> FastString
opText = \case
  JOp
EqOp          -> FastString
"=="
  JOp
StrictEqOp    -> FastString
"==="
  JOp
NeqOp         -> FastString
"!="
  JOp
StrictNeqOp   -> FastString
"!=="
  JOp
GtOp          -> FastString
">"
  JOp
GeOp          -> FastString
">="
  JOp
LtOp          -> FastString
"<"
  JOp
LeOp          -> FastString
"<="
  JOp
AddOp         -> FastString
"+"
  JOp
SubOp         -> FastString
"-"
  JOp
MulOp         -> FastString
"*"
  JOp
DivOp         -> FastString
"/"
  JOp
ModOp         -> FastString
"%"
  JOp
LeftShiftOp   -> FastString
"<<"
  JOp
RightShiftOp  -> FastString
">>"
  JOp
ZRightShiftOp -> FastString
">>>"
  JOp
BAndOp        -> FastString
"&"
  JOp
BOrOp         -> FastString
"|"
  JOp
BXorOp        -> FastString
"^"
  JOp
LAndOp        -> FastString
"&&"
  JOp
LOrOp         -> FastString
"||"
  JOp
InstanceofOp  -> FastString
"instanceof"
  JOp
InOp          -> FastString
"in"


isPre :: JUOp -> Bool
isPre :: JUOp -> Bool
isPre = \case
  JUOp
PostIncOp -> Bool
False
  JUOp
PostDecOp -> Bool
False
  JUOp
_         -> Bool
True

isAlphaOp :: JUOp -> Bool
isAlphaOp :: JUOp -> Bool
isAlphaOp = \case
  JUOp
NewOp    -> Bool
True
  JUOp
TypeofOp -> Bool
True
  JUOp
DeleteOp -> Bool
True
  JUOp
YieldOp  -> Bool
True
  JUOp
VoidOp   -> Bool
True
  JUOp
_        -> Bool
False