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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Linker.Opt
-- 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
--
-- Optimization pass at link time
--
--
--
-----------------------------------------------------------------------------
module GHC.StgToJS.Linker.Opt
  ( pretty
  , optRenderJs
  )
where

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

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

import GHC.Utils.Outputable
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 :: JsRender doc => Bool -> JStat -> doc
pretty :: forall doc. JsRender doc => Bool -> JStat -> doc
pretty Bool
render_pretty = \case
  BlockStat []      -> doc
forall doc. IsOutput doc => doc
empty
  JStat
s | Bool
render_pretty -> RenderJs doc -> [JStat] -> doc
forall doc. JsRender doc => RenderJs doc -> [JStat] -> doc
forall a doc. (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
jsToDocR RenderJs doc
forall doc. RenderJs doc
defaultRenderJs [JStat
s]
    | Bool
otherwise     -> RenderJs doc -> [JStat] -> doc
forall doc. JsRender doc => RenderJs doc -> [JStat] -> doc
forall a doc. (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
jsToDocR RenderJs doc
forall doc. RenderJs doc
optRenderJs [JStat
s]
                        -- render as a list of statements to ensure that
                        -- semicolons are added.

-- | Render JS with code size minimization enabled
optRenderJs :: RenderJs doc
optRenderJs :: forall doc. RenderJs doc
optRenderJs = RenderJs doc
forall doc. RenderJs doc
defaultRenderJs
  { renderJsV = ghcjsRenderJsV
  , renderJsS = ghcjsRenderJsS
  , renderJsI = ghcjsRenderJsI
  }

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

ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc
ghcjsRenderJsI :: forall doc. IsLine doc => RenderJs doc -> Ident -> doc
ghcjsRenderJsI RenderJs doc
_ (Ident -> FastString
identFS -> 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
forall doc. IsLine doc => [Char] -> doc
text [Char]
"h$$" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Word -> doc
forall doc. IsLine doc => Word -> doc
hexDoc (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u)
  | Bool
otherwise
  = FastString -> doc
forall doc. IsLine doc => 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 :: IsLine doc => Word -> doc
hexDoc :: forall doc. IsLine doc => Word -> doc
hexDoc Word
0 = Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'0'
hexDoc Word
v = [Char] -> doc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> doc) -> [Char] -> doc
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 (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
n Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F))
           Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char
sym (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
n Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0xF0) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
4))
           Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Word -> [Char]
go (Word
n Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)




-- attempt to resugar some of the common constructs
ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
ghcjsRenderJsS :: forall doc. JsRender doc => RenderJs doc -> JStat -> doc
ghcjsRenderJsS RenderJs doc
r JStat
s = RenderJs doc -> JsRender doc => RenderJs doc -> JStat -> doc
forall doc.
RenderJs doc -> JsRender doc => RenderJs doc -> JStat -> doc
renderJsS RenderJs doc
forall doc. RenderJs doc
defaultRenderJs RenderJs doc
r JStat
s

-- don't quote keys in our object literals, so closure compiler works
ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
ghcjsRenderJsV :: forall doc. JsRender doc => RenderJs doc -> JVal -> doc
ghcjsRenderJsV RenderJs doc
r (JHash UniqMap FastString JExpr
m)
  | UniqMap FastString JExpr -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap FastString JExpr
m = [Char] -> doc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"{}"
  | Bool
otherwise       = doc -> doc
forall doc. JsRender doc => doc -> doc
braceNest (doc -> doc)
-> ([(FastString, JExpr)] -> doc) -> [(FastString, JExpr)] -> doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [doc] -> doc
forall doc. IsLine doc => [doc] -> doc
fsep ([doc] -> doc)
-> ([(FastString, JExpr)] -> [doc]) -> [(FastString, JExpr)] -> doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. doc -> [doc] -> [doc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate doc
forall doc. IsLine doc => 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) -> FastString -> doc
forall doc. IsLine doc => FastString -> doc
quoteIfRequired FastString
x doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> doc
forall doc. IsLine doc => doc
colon doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> RenderJs doc -> JExpr -> doc
forall doc. JsRender doc => RenderJs doc -> JExpr -> doc
forall a doc. (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
jsToDocR RenderJs doc
r JExpr
y)
                          -- nonDetEltsUniqMap doesn't introduce non-determinism here because
                          -- we sort the elements lexically
                          ([(FastString, JExpr)] -> [doc])
-> ([(FastString, JExpr)] -> [(FastString, JExpr)])
-> [(FastString, JExpr)]
-> [doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((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) ([(FastString, JExpr)] -> doc) -> [(FastString, JExpr)] -> doc
forall a b. (a -> b) -> a -> b
$ UniqMap FastString JExpr -> [(FastString, JExpr)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap FastString JExpr
m
  where
    quoteIfRequired :: IsLine doc => FastString -> doc
    quoteIfRequired :: forall doc. IsLine doc => FastString -> doc
quoteIfRequired FastString
x
      | FastString -> Bool
isUnquotedKey FastString
x = FastString -> doc
forall doc. IsLine doc => FastString -> doc
ftext FastString
x
      | Bool
otherwise       = Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'\'' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> doc
forall doc. IsLine doc => FastString -> doc
ftext FastString
x doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'\''

    isUnquotedKey :: FastString -> Bool
    isUnquotedKey :: FastString -> Bool
isUnquotedKey FastString
fs = case FastString -> [Char]
unpackFS FastString
fs of
      []       -> Bool
False
      s :: [Char]
s@(Char
c:[Char]
cs) -> (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
s Bool -> Bool -> Bool
|| (Char -> Bool
validFirstIdent Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validOtherIdent [Char]
cs)

    validFirstIdent :: Char -> Bool
validFirstIdent Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
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 doc
r JVal
v = RenderJs doc -> JsRender doc => RenderJs doc -> JVal -> doc
forall doc.
RenderJs doc -> JsRender doc => RenderJs doc -> JVal -> doc
renderJsV RenderJs doc
forall doc. RenderJs doc
defaultRenderJs RenderJs doc
r JVal
v