{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Printer
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
-- Stability   :  experimental
--
-- Custom prettyprinter for JS AST uses the JS PPr module for most of
-- the work
--
--
-----------------------------------------------------------------------------
module GHC.StgToJS.Printer
  ( pretty
  , ghcjsRenderJs
  , prettyBlock
  )
where

import GHC.Prelude
import GHC.Int
import GHC.Exts

import GHC.JS.Syntax
import GHC.JS.Ppr

import GHC.Utils.Ppr      as PP
import GHC.Data.FastString
import GHC.Types.Unique.Map

import Data.List (sortOn)
import Data.Char (isAlpha,isDigit,ord)
import qualified Data.ByteString.Short as SBS

pretty :: JStat -> Doc
pretty :: JStat -> Doc
pretty = forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
ghcjsRenderJs

ghcjsRenderJs :: RenderJs
ghcjsRenderJs :: RenderJs
ghcjsRenderJs = RenderJs
defaultRenderJs
  { renderJsV :: RenderJs -> JVal -> Doc
renderJsV = RenderJs -> JVal -> Doc
ghcjsRenderJsV
  , renderJsS :: RenderJs -> JStat -> Doc
renderJsS = RenderJs -> JStat -> Doc
ghcjsRenderJsS
  , renderJsI :: RenderJs -> Ident -> Doc
renderJsI = RenderJs -> Ident -> Doc
ghcjsRenderJsI
  }

hdd :: SBS.ShortByteString
hdd :: ShortByteString
hdd = [Word8] -> ShortByteString
SBS.pack (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) [Char]
"h$$")

ghcjsRenderJsI :: RenderJs -> Ident -> Doc
ghcjsRenderJsI :: RenderJs -> Ident -> Doc
ghcjsRenderJsI RenderJs
_ (TxtI FastString
fs)
  -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by
  -- name in user code, only in compiled code. Hence we can rename them if we do
  -- it consistently in all the linked code.
  --
  -- These symbols are usually very large because their name includes the
  -- unit-id, the module name, and some unique number. So we rename these
  -- symbols with a much shorter globally unique number.
  --
  -- Here we reuse their FastString unique for this purpose! Note that it only
  -- works if we pretty-print all the JS code linked together at once, which we
  -- currently do. GHCJS used to maintain a CompactorState to support
  -- incremental linking: it contained the mapping between original symbols and
  -- their renaming.
  | ShortByteString
hdd ShortByteString -> ShortByteString -> Bool
`SBS.isPrefixOf` FastString -> ShortByteString
fastStringToShortByteString FastString
fs
  , Int
u <- FastString -> Int
uniqueOfFS FastString
fs
  = [Char] -> Doc
text [Char]
"h$$" Doc -> Doc -> Doc
<> Word -> Doc
hexDoc (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u)
  | Bool
otherwise
  = FastString -> Doc
ftext FastString
fs

-- | Render as an hexadecimal number in reversed order (because it's faster and we
-- don't care about the actual value).
hexDoc :: Word -> Doc
hexDoc :: Word -> Doc
hexDoc Word
0 = Char -> Doc
char Char
'0'
hexDoc Word
v = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ Word -> [Char]
go Word
v
  where
    sym :: Int -> Char
sym (I# Int#
i) = Char# -> Char
C# (Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
chars Int#
i)
    chars :: Addr#
chars = Addr#
"0123456789abcdef"#
    go :: Word -> [Char]
go = \case
      Word
0 -> []
      Word
n -> Int -> Char
sym (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
n forall a. Bits a => a -> a -> a
.&. Word
0x0F))
           forall a. a -> [a] -> [a]
: Int -> Char
sym (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
n forall a. Bits a => a -> a -> a
.&. Word
0xF0) forall a. Bits a => a -> Int -> a
`shiftR` Int
4))
           forall a. a -> [a] -> [a]
: Word -> [Char]
go (Word
n forall a. Bits a => a -> Int -> a
`shiftR` Int
8)




-- attempt to resugar some of the common constructs
ghcjsRenderJsS :: RenderJs -> JStat -> Doc
ghcjsRenderJsS :: RenderJs -> JStat -> Doc
ghcjsRenderJsS RenderJs
r (BlockStat [JStat]
xs) = RenderJs -> [JStat] -> Doc
prettyBlock RenderJs
r ([JStat] -> [JStat]
flattenBlocks [JStat]
xs)
ghcjsRenderJsS RenderJs
r JStat
s              = RenderJs -> RenderJs -> JStat -> Doc
renderJsS RenderJs
defaultRenderJs RenderJs
r JStat
s

-- don't quote keys in our object literals, so closure compiler works
ghcjsRenderJsV :: RenderJs -> JVal -> Doc
ghcjsRenderJsV :: RenderJs -> JVal -> Doc
ghcjsRenderJsV RenderJs
r (JHash UniqMap FastString JExpr
m)
  | forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap FastString JExpr
m = [Char] -> Doc
text [Char]
"{}"
  | Bool
otherwise       = Doc -> Doc
braceNest forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall a b. (a -> b) -> [a] -> [b]
map (\(FastString
x,JExpr
y) -> FastString -> Doc
quoteIfRequired FastString
x Doc -> Doc -> Doc
<> Doc
PP.colon Doc -> Doc -> 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
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FastString -> LexicalFastString
LexicalFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. UniqMap k a -> [(k, a)]
nonDetEltsUniqMap UniqMap FastString JExpr
m
  where
    quoteIfRequired :: FastString -> Doc
    quoteIfRequired :: FastString -> Doc
quoteIfRequired FastString
x
      | [Char] -> Bool
isUnquotedKey [Char]
x' = [Char] -> Doc
text [Char]
x'
      | Bool
otherwise        = Doc -> Doc
PP.squotes ([Char] -> Doc
text [Char]
x')
      where x' :: [Char]
x' = FastString -> [Char]
unpackFS FastString
x

    isUnquotedKey :: String -> Bool
    isUnquotedKey :: [Char] -> Bool
isUnquotedKey [Char]
x | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x        = Bool
False
                    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
x = Bool
True
                    | Bool
otherwise     = Char -> Bool
validFirstIdent (forall a. [a] -> a
head [Char]
x)
                                      Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validOtherIdent (forall a. [a] -> [a]
tail [Char]
x)


    validFirstIdent :: Char -> Bool
validFirstIdent Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
c
    validOtherIdent :: Char -> Bool
validOtherIdent Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
ghcjsRenderJsV RenderJs
r JVal
v = RenderJs -> RenderJs -> JVal -> Doc
renderJsV RenderJs
defaultRenderJs RenderJs
r JVal
v

prettyBlock :: RenderJs -> [JStat] -> Doc
prettyBlock :: RenderJs -> [JStat] -> Doc
prettyBlock RenderJs
r [JStat]
xs = [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
addSemi (RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs)

-- recognize common patterns in a block and convert them to more idiomatic/concise javascript
prettyBlock' :: RenderJs -> [JStat] -> [Doc]
-- return/...
prettyBlock' :: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r ( x :: JStat
x@(ReturnStat JExpr
_)
               : [JStat]
xs
               )
      | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
xs)
      = RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat
x]
-- declare/assign
prettyBlock' RenderJs
r ( (DeclStat Ident
i Maybe JExpr
Nothing)
               : (AssignStat (ValExpr (JVar Ident
i')) JExpr
v)
               : [JStat]
xs
               )
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i'
      = RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r (Ident -> Maybe JExpr -> JStat
DeclStat Ident
i (forall a. a -> Maybe a
Just JExpr
v) forall a. a -> [a] -> [a]
: [JStat]
xs)

-- resugar for loops with/without var declaration
prettyBlock' RenderJs
r ( (DeclStat Ident
i (Just JExpr
v0))
               : (WhileStat Bool
False JExpr
p (BlockStat [JStat]
bs))
               : [JStat]
xs
               )
     | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat (forall a. [a] -> a
last [JStat]
flat)
     = RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
True Ident
i JExpr
v0 JExpr
p (forall a. [a] -> a
last [JStat]
flat) (forall a. [a] -> [a]
init [JStat]
flat) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
        where
          flat :: [JStat]
flat = [JStat] -> [JStat]
flattenBlocks [JStat]
bs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) JExpr
v0)
               : (WhileStat Bool
False JExpr
p (BlockStat [JStat]
bs))
               : [JStat]
xs
               )
     | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat (forall a. [a] -> a
last [JStat]
flat)
     = RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
False Ident
i JExpr
v0 JExpr
p (forall a. [a] -> a
last [JStat]
flat) (forall a. [a] -> [a]
init [JStat]
flat) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
        where
          flat :: [JStat]
flat = [JStat] -> [JStat]
flattenBlocks [JStat]
bs

-- global function (does not preserve semantics but works for GHCJS)
prettyBlock' RenderJs
r ( (DeclStat Ident
i (Just (ValExpr (JFunc [Ident]
is JStat
b))))
               : [JStat]
xs
               )
      = (Doc -> Doc -> Doc
hangBrace ([Char] -> Doc
text [Char]
"function" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) forall a b. (a -> b) -> a -> b
$ [Ident]
is))
                             (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
                  ) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
-- modify/assign operators
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
AddOp (ValExpr (JVar Ident
i')) (ValExpr (JInt Integer
1))))
               : [JStat]
xs
               )
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"++" Doc -> Doc -> Doc
<> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
SubOp (ValExpr (JVar Ident
i')) (ValExpr (JInt Integer
1))))
               : [JStat]
xs
               )
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"--" Doc -> Doc -> Doc
<> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
AddOp (ValExpr (JVar Ident
i')) JExpr
e))
               : [JStat]
xs
               )
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i' = (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"+=" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
SubOp (ValExpr (JVar Ident
i')) JExpr
e))
               : [JStat]
xs
               )
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i' = (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"-=" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs


prettyBlock' RenderJs
r (JStat
x:[JStat]
xs) = forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
_ [] = []

-- build the for block
mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor :: RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
decl Ident
i JExpr
v0 JExpr
p JStat
s1 [JStat]
sb = Doc -> Doc -> Doc
hangBrace ([Char] -> Doc
text [Char]
"for" Doc -> Doc -> Doc
<> Doc
forCond)
                                      (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
BlockStat [JStat]
sb)
    where
      c0 :: Doc
c0 | Bool
decl      = [Char] -> Doc
text [Char]
"var" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
         | Bool
otherwise =                forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
      forCond :: Doc
forCond = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
interSemi
                            [ Doc
c0
                            , forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
p
                            , Doc -> Doc
parens (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s1)
                            ]

-- check if a statement is suitable to be converted to something in the for(;;x) position
isForUpdStat :: JStat -> Bool
isForUpdStat :: JStat -> Bool
isForUpdStat UOpStat {}    = Bool
True
isForUpdStat AssignStat {} = Bool
True
isForUpdStat ApplStat {}   = Bool
True
isForUpdStat JStat
_             = Bool
False

interSemi :: [Doc] -> [Doc]
interSemi :: [Doc] -> [Doc]
interSemi [] = [Doc
PP.empty]
interSemi [Doc
s] = [Doc
s]
interSemi (Doc
x:[Doc]
xs) = Doc
x Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
";" forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
interSemi [Doc]
xs

addSemi :: Doc -> Doc
addSemi :: Doc -> Doc
addSemi Doc
x = Doc
x Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
";"