ghc-9.8.1: GHC/JS/Ppr.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeApplications #-}
-- 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.Syntax
import GHC.JS.Transform
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, JMacro a) => a -> SDoc
renderPrefixJs = renderPrefixJs' defaultRenderJs
renderPrefixJs' :: (JsToDoc a, JMacro 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 '/'
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 _ (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 :: 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 #-}