{-# 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 intances 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.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 ($$$) 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 #-}