content: {-# 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 #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  GHC.JS.Ppr
  -- 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>
  --                Josh Meredith  <josh.meredith@iohk.io>
  -- Stability   :  experimental
  --
  --
  -- * Domain and Purpose
  --
  --     GHC.JS.Ppr defines the code generation facilities for the JavaScript
  --     backend. That is, this module exports a function from the JS backend IR
  --     to JavaScript compliant concrete syntax that can readily be executed by
  --     nodejs or called in a browser.
  --
  -- * Design
  --
  --     This module follows the architecture and style of the other backends in
  --     GHC: it instances Outputable for the relevant types, creates a class that
  --     describes a morphism from the IR domain to JavaScript concrete Syntax and
  --     then generates that syntax on a case by case basis.
  --
  -- * How to use
  --
  --     The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record.
  --     Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for
  --     specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a
  --     custom renderer ensures all @Ident@ generated by the linker optimization
  --     pass are prefixed differently than the default. Use @renderJS@ to
  --     generate JavaScript concrete syntax in the general case, suitable for
  --     human consumption.
  -----------------------------------------------------------------------------
  
  module GHC.JS.Ppr
    ( renderJs
    , renderPrefixJs
    , renderPrefixJs'
    , JsToDoc(..)
    , defaultRenderJs
    , RenderJs(..)
    , JsRender(..)
    , jsToDoc
    , pprStringLit
    , interSemi
    , braceNest
    , hangBrace
    )
  where
  
  import GHC.Prelude
  
  import GHC.JS.Ident
  import GHC.JS.Syntax
  
  import Data.Char (isControl, ord)
  import Data.List (sortOn)
  
  import Numeric(showHex)
  
  import GHC.Utils.Misc
  import GHC.Utils.Outputable
  import GHC.Data.FastString
  import GHC.Types.Unique.Map
  
  instance Outputable JExpr where
    ppr = renderJs
  
  instance Outputable JVal where
    ppr = renderJs
  
  --------------------------------------------------------------------------------
  --                            Top level API
  --------------------------------------------------------------------------------
  
  -- | Render a syntax tree as a pretty-printable document
  -- (simply showing the resultant doc produces a nice,
  -- well formatted String).
  renderJs :: (JsToDoc a) => a -> SDoc
  renderJs = renderJs' defaultRenderJs
  
  {-# SPECIALISE renderJs' :: JsToDoc a => RenderJs HLine -> a -> HLine #-}
  {-# SPECIALISE renderJs' :: JsToDoc a => RenderJs SDoc  -> a -> SDoc  #-}
  renderJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
  renderJs' r = jsToDocR r
  
  data RenderJs doc = RenderJs
    { renderJsS :: !(JsRender doc => RenderJs doc -> JStat -> doc)
    , renderJsE :: !(JsRender doc => RenderJs doc -> JExpr -> doc)
    , renderJsV :: !(JsRender doc => RenderJs doc -> JVal  -> doc)
    , renderJsI :: !(JsRender doc => RenderJs doc -> Ident -> doc)
    }
  
  defaultRenderJs :: RenderJs doc
  defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI
  
  jsToDoc :: JsToDoc a => a -> SDoc
  jsToDoc = jsToDocR 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) => a -> SDoc
  renderPrefixJs = renderPrefixJs' defaultRenderJs
  
  renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
  renderPrefixJs' r = jsToDocR r
  
  --------------------------------------------------------------------------------
  --                            Code Generator
  --------------------------------------------------------------------------------
  
  class JsToDoc a where jsToDocR :: JsRender doc => RenderJs doc -> a -> doc
  instance JsToDoc JStat   where jsToDocR r = renderJsS r r
  instance JsToDoc JExpr   where jsToDocR r = renderJsE r r
  instance JsToDoc JVal    where jsToDocR r = renderJsV r r
  instance JsToDoc Ident   where jsToDocR r = renderJsI r r
  instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
  instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
  
  defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
  defRenderJsS r = \case
    IfStat cond x y -> jcat
                          [ hangBrace (text "if" <+?> parens (jsToDocR r cond)) (optBlock r x)
                          , mbElse
                          ]
          where mbElse | y == BlockStat []  = empty
                       | otherwise = hangBrace (text "else") (optBlock r y)
    DeclStat x Nothing  -> text "var" <+> jsToDocR r x
      -- 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()
      --                               {
      --                               ...
      --                             });
      --
    DeclStat x (Just (ValExpr f@(JFunc {}))) -> jhang (text "var" <+> jsToDocR r x <+?> char '=') (jsToDocR r f)
    DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e
    WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (optBlock r b)
    WhileStat True  p b -> hangBrace (text "do") (optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)
    BreakStat l         -> addSemi $ maybe (text "break")    (\(LexicalFastString s) -> (text "break"    <+> ftext s)) l
    ContinueStat l      -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
    LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s
          where
            printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss
            printBS x = jsToDocR r x
  
    ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (optBlock r sb)
      where
        forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1)
    ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (optBlock r b)
          where txt | each = "for each"
                    | otherwise = "for"
    SwitchStat e l d     -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases
          where l' = map (\(c,s) -> (text "case" <+?> parens (jsToDocR r c) <> colon) $$$ jnest (optBlock r s)) l
                     ++ [(text "default:") $$$ jnest (optBlock r d)]
                cases = foldl1 ($$$) $ expectNonEmpty l'
    ReturnStat e      -> text "return" <+> jsToDocR r e
    ApplStat e es     -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es)
    FuncStat i is b   -> hangBrace (text "function" <+> jsToDocR r i
                                    <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is))
                               (optBlock r b)
    TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally
          where mbCatch | s1 == BlockStat [] = empty
                        | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1)
                mbFinally | s2 == BlockStat [] = empty
                          | otherwise = hangBrace (text "finally") (optBlock r s2)
    AssignStat i op x    -> case x of
      -- special treatment for functions, otherwise there is too much left padding
      -- (more than the length of the expression assigned to). E.g.
      --
      --    long_variable_name = (function()
      --                               {
      --                               ...
      --                             });
      --
      ValExpr f@(JFunc {}) -> jhang (jsToDocR r i <> ftext (aOpText op)) (jsToDocR r f)
      _                    -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x
    UOpStat op x
      | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
      | isPre op                 -> ftext (uOpText op) <+> optParens r x
      | otherwise                -> optParens r x <+> ftext (uOpText op)
    BlockStat xs -> jsToDocR r xs
  
  -- | Remove one Block layering if we know we already have braces around the
  -- statement
  optBlock :: JsRender doc => RenderJs doc -> JStat -> doc
  optBlock r x = case x of
    BlockStat{} -> jsToDocR r x
    _           -> addSemi (jsToDocR r x)
  
  optParens :: JsRender doc => RenderJs doc -> JExpr -> doc
  optParens r x = case x of
    UOpExpr _ _ -> parens (jsToDocR r x)
    _           -> jsToDocR r x
  
  defRenderJsE :: JsRender doc => RenderJs doc -> JExpr -> doc
  defRenderJsE r = \case
    ValExpr x         -> jsToDocR r x
    SelExpr x y       -> jsToDocR r x <> char '.' <> jsToDocR r y
    IdxExpr x y       -> jsToDocR r x <> brackets (jsToDocR r y)
    IfExpr x y z      -> parens (jsToDocR r x <+?> char '?' <+?> jsToDocR r y <+?> colon <+?> jsToDocR r z)
    InfixExpr op x y  -> parens $ jsToDocR r x <+?> ftext (opText op) <+?> jsToDocR r y
    UOpExpr op x
      | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
      | isPre op                 -> ftext (uOpText op) <+> optParens r x
      | otherwise                -> optParens r x <+> ftext (uOpText op)
    ApplExpr je xs -> jsToDocR r je <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs)
  
  defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
  defRenderJsV r = \case
    JVar i    -> jsToDocR r i
    JList xs  -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs
    JDouble (SaneDouble d)
      | d < 0 || isNegativeZero d -> parens (double d)
      | otherwise                 -> double d
    JInt i
      | i < 0     -> parens (integer i)
      | otherwise -> integer i
    JStr   s -> pprStringLit s
    JRegEx s -> char '/' <> ftext s <> char '/'
    JBool b -> text (if b then "true" else "false")
    JHash m
      | isNullUniqMap m  -> text "{}"
      | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma .
                            map (\(x,y) -> char '\'' <> ftext x <> char '\'' <> colon <+?> jsToDocR r y)
                            -- nonDetKeysUniqMap doesn't introduce non-determinism here
                            -- because we sort the elements lexically
                            $ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m)
    JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
  
  defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc
  defRenderJsI _  t = ftext (identFS t)
  
  aOpText :: AOp -> FastString
  aOpText = \case
    AssignOp    -> "="
    AddAssignOp -> "+="
    SubAssignOp -> "-="
  
  
  uOpText :: UOp -> FastString
  uOpText = \case
    NotOp     -> "!"
    BNotOp    -> "~"
    NegOp     -> "-"
    PlusOp    -> "+"
    NewOp     -> "new"
    TypeofOp  -> "typeof"
    DeleteOp  -> "delete"
    YieldOp   -> "yield"
    VoidOp    -> "void"
    PreIncOp  -> "++"
    PostIncOp -> "++"
    PreDecOp  -> "--"
    PostDecOp -> "--"
  
  opText :: Op -> FastString
  opText = \case
    EqOp          -> "=="
    StrictEqOp    -> "==="
    NeqOp         -> "!="
    StrictNeqOp   -> "!=="
    GtOp          -> ">"
    GeOp          -> ">="
    LtOp          -> "<"
    LeOp          -> "<="
    AddOp         -> "+"
    SubOp         -> "-"
    MulOp         -> "*"
    DivOp         -> "/"
    ModOp         -> "%"
    LeftShiftOp   -> "<<"
    RightShiftOp  -> ">>"
    ZRightShiftOp -> ">>>"
    BAndOp        -> "&"
    BOrOp         -> "|"
    BXorOp        -> "^"
    LAndOp        -> "&&"
    LOrOp         -> "||"
    InstanceofOp  -> "instanceof"
    InOp          -> "in"
  
  
  isPre :: UOp -> Bool
  isPre = \case
    PostIncOp -> False
    PostDecOp -> False
    _         -> True
  
  isAlphaOp :: UOp -> Bool
  isAlphaOp = \case
    NewOp    -> True
    TypeofOp -> True
    DeleteOp -> True
    YieldOp  -> True
    VoidOp   -> True
    _        -> False
  
  pprStringLit :: IsLine doc => FastString -> doc
  pprStringLit s = char '\"' <> encodeJson s <> char '\"'
  
  --------------------------------------------------------------------------------
  --                            Utilities
  --------------------------------------------------------------------------------
  
  encodeJson :: IsLine doc => FastString -> doc
  encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
  
  encodeJsonChar :: IsLine doc => Char -> doc
  encodeJsonChar = \case
    '/'  -> text "\\/"
    '\b' -> text "\\b"
    '\f' -> text "\\f"
    '\n' -> text "\\n"
    '\r' -> text "\\r"
    '\t' -> text "\\t"
    '"'  -> text "\\\""
    '\\' -> text "\\\\"
    c
      | not (isControl c) && ord c <= 127 -> char c
      | ord c <= 0xff   -> hexxs "\\x" 2 (ord c)
      | ord c <= 0xffff -> hexxs "\\u" 4 (ord c)
      | otherwise      -> let cp0 = ord c - 0x10000 -- output surrogate pair
                          in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <>
                             hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)
      where hexxs prefix pad cp =
              let h = showHex cp ""
              in  text (prefix ++ replicate (pad - length h) '0' ++ h)
  
  
  interSemi :: JsRender doc => [doc] -> doc
  interSemi = foldl ($$$) empty . punctuateFinal semi semi
  
  -- | The structure `{body}`, optionally indented over multiple lines
  {-# INLINE braceNest #-}
  braceNest :: JsRender doc => doc -> doc
  braceNest x = lbrace $$$ jnest x $$$ rbrace
  
  -- | The structure `hdr {body}`, optionally indented over multiple lines
  {-# INLINE hangBrace #-}
  hangBrace :: JsRender doc => doc -> doc -> doc
  hangBrace hdr body = jcat [ hdr <> char ' ' <> char '{', jnest body, char '}' ]
  
  {-# INLINE jhang #-}
  jhang :: JsRender doc => doc -> doc -> doc
  jhang hdr body = jcat [ hdr, jnest body]
  
  -- | JsRender controls the differences in whitespace between HLine and SDoc.
  -- Generally, this involves the indentation and newlines in the human-readable
  -- SDoc implementation being replaced in the HLine version by the minimal
  -- whitespace required for valid JavaScript syntax.
  class IsLine doc => JsRender doc where
  
    -- | Concatenate with an optional single space
    (<+?>)    :: doc -> doc -> doc
    -- | Concatenate with an optional newline
    ($$$)     :: doc -> doc -> doc
    -- | Concatenate these `doc`s, either vertically (SDoc) or horizontally (HLine)
    jcat      :: [doc] -> doc
    -- | Optionally indent the following
    jnest     :: doc -> doc
    -- | Append semi-colon (and line-break in HLine mode)
    addSemi   :: doc -> doc
  
  instance JsRender SDoc where
    (<+?>) = (<+>)
    {-# INLINE (<+?>) #-}
    ($$$)  = ($+$)
    {-# INLINE ($$$) #-}
    jcat               = vcat
    {-# INLINE jcat #-}
    jnest              = nest 2
    {-# INLINE jnest #-}
    addSemi x = x <> semi
    {-# INLINE addSemi #-}
  
  
  instance JsRender HLine where
    (<+?>) = (<>)
    {-# INLINE (<+?>) #-}
    ($$$)  = (<>)
    {-# INLINE ($$$) #-}
    jcat               = hcat
    {-# INLINE jcat #-}
    jnest              = id
    {-# INLINE jnest #-}
    addSemi x = x <> semi <> char '\n'
    -- we add a line-break to avoid issues with lines too long in minified outputs
    {-# INLINE addSemi #-}
  