Opt.hs

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

-----------------------------------------------------------------------------
-- |
-- 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 render_pretty = \case
  BlockStat []      -> empty
  s | render_pretty -> jsToDocR defaultRenderJs [s]
    | otherwise     -> jsToDocR optRenderJs [s]
                        -- render as a list of statements to ensure that
                        -- semicolons are added.

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

hdd :: SBS.ShortByteString
hdd = SBS.pack (map (fromIntegral . ord) "h$$")

ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc
ghcjsRenderJsI _ (TxtI 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.
  | hdd `SBS.isPrefixOf` fastStringToShortByteString fs
  , u <- uniqueOfFS fs
  = text "h$$" <> hexDoc (fromIntegral u)
  | otherwise
  = ftext 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 0 = char '0'
hexDoc v = text $ go v
  where
    sym (I# i) = C# (indexCharOffAddr# chars i)
    chars = "0123456789abcdef"#
    go = \case
      0 -> []
      n -> sym (fromIntegral (n .&. 0x0F))
           : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4))
           : go (n `shiftR` 8)




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

-- don't quote keys in our object literals, so closure compiler works
ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
ghcjsRenderJsV r (JHash m)
  | isNullUniqMap m = text "{}"
  | otherwise       = braceNest . fsep . punctuate comma .
                          map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y)
                          -- nonDetEltsUniqMap doesn't introduce non-determinism here because
                          -- we sort the elements lexically
                          . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m
  where
    quoteIfRequired :: IsLine doc => FastString -> doc
    quoteIfRequired x
      | isUnquotedKey x = ftext x
      | otherwise       = char '\'' <> ftext x <> char '\''

    isUnquotedKey :: FastString -> Bool
    isUnquotedKey fs = case unpackFS fs of
      []       -> False
      s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs)

    validFirstIdent c = c == '_' || c == '$' || isAlpha c
    validOtherIdent c = isAlpha c || isDigit c

ghcjsRenderJsV r v = renderJsV defaultRenderJs r v