{-# 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(..)
  , jsToDoc
  , pprStringLit
  , braceNest
  , hangBrace
  , interSemi
  , addSemi
  )
where

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Transform


import Data.Char (isControl, ord)
import Data.List (sortOn)

import Numeric(showHex)

import GHC.Utils.Outputable (Outputable (..), docToSDoc)
import GHC.Utils.Ppr as PP
import GHC.Data.FastString
import GHC.Types.Unique.Map

instance Outputable JExpr where
  ppr = docToSDoc . renderJs

instance Outputable JVal where
  ppr = docToSDoc . 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 -> Doc
renderJs = renderJs' defaultRenderJs

renderJs' :: (JsToDoc a) => RenderJs -> a -> Doc
renderJs' r = jsToDocR r

data RenderJs = RenderJs
  { renderJsS :: !(RenderJs -> JStat -> Doc)
  , renderJsE :: !(RenderJs -> JExpr -> Doc)
  , renderJsV :: !(RenderJs -> JVal  -> Doc)
  , renderJsI :: !(RenderJs -> Ident -> Doc)
  }

defaultRenderJs :: RenderJs
defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI

jsToDoc :: JsToDoc a => a -> Doc
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, JMacro a) => a -> Doc
renderPrefixJs = renderPrefixJs' defaultRenderJs

renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderPrefixJs' r = jsToDocR r

--------------------------------------------------------------------------------
--                            Code Generator
--------------------------------------------------------------------------------

class JsToDoc a where jsToDocR :: RenderJs -> 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 = vcat . map ((<> semi) . jsToDocR r)
instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)

defRenderJsS :: RenderJs -> JStat -> Doc
defRenderJsS r = \case
  IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond))
                      (jsToDocR r x)
                      $$ mbElse
        where mbElse | y == BlockStat []  = PP.empty
                     | otherwise = hangBrace (text "else") (jsToDocR r y)
  DeclStat x Nothing  -> text "var" <+> jsToDocR r x
  DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e
  WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b)
  WhileStat True  p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
  BreakStat l         -> maybe (text "break")    (\(LexicalFastString s) -> (text "break"    <+> ftext s)) l
  ContinueStat l      -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
  LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s
        where
          printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss
          printBS x = jsToDocR r x

  ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb)
    where
      forCond = parens $ hcat $ interSemi
                            [ jsToDocR r init
                            , jsToDocR r p
                            , parens (jsToDocR r s1)
                            ]
  ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR 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) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)]
              cases = vcat l'
  ReturnStat e      -> text "return" <+> jsToDocR r e
  ApplStat e es     -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es)
  FuncStat i is b   -> hangBrace (text "function" <+> jsToDocR r i
                                  <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
                             (jsToDocR r b)
  TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally
        where mbCatch | s1 == BlockStat [] = PP.empty
                      | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1)
              mbFinally | s2 == BlockStat [] = PP.empty
                        | otherwise = hangBrace (text "finally") (jsToDocR 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.
    --
    --    var long_variable_name = (function()
    --                               {
    --                               ...
    --                             });
    --
    ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
    _                      -> 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

optParens :: RenderJs -> JExpr -> Doc
optParens r x = case x of
  UOpExpr _ _ -> parens (jsToDocR r x)
  _           -> jsToDocR r x

defRenderJsE :: RenderJs -> 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 <+> char ':' <+> jsToDocR r z)
  InfixExpr op x y  -> parens $ hsep [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 . hsep . punctuate comma $ map (jsToDocR r) xs)

defRenderJsV :: RenderJs -> JVal -> Doc
defRenderJsV r = \case
  JVar i    -> jsToDocR r i
  JList xs  -> brackets . hsep . 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 -> hcat [char '/',ftext s, char '/']
  JHash m
    | isNullUniqMap m  -> text "{}"
    | otherwise -> braceNest . hsep . punctuate comma .
                          map (\(x,y) -> squotes (ftext x) <> 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 (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)

defRenderJsI :: RenderJs -> Ident -> Doc
defRenderJsI _ (TxtI t) = ftext 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 :: FastString -> Doc
pprStringLit s = hcat [char '\"',encodeJson s, char '\"']

--------------------------------------------------------------------------------
--                            Utilities
--------------------------------------------------------------------------------

encodeJson :: FastString -> Doc
encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))

encodeJsonChar :: 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)

braceNest :: Doc -> Doc
braceNest x = char '{' <+> nest 2 x $$ char '}'

interSemi :: [Doc] -> [Doc]
interSemi []     = []
interSemi [s]    = [s]
interSemi (x:xs) = x <> text ";" : interSemi xs

addSemi :: Doc -> Doc
addSemi x = x <> text ";"

-- | Hang with braces:
--
--  hdr {
--    body
--  }
hangBrace :: Doc -> Doc -> Doc
hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]

($$$) :: Doc -> Doc -> Doc
x $$$ y = nest 2 $ x $+$ y