{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
module GHC.StgToJS.Printer
( pretty
, ghcjsRenderJs
, prettyBlock
)
where
import GHC.Prelude
import GHC.Int
import GHC.Exts
import GHC.JS.Syntax
import GHC.JS.Ppr
import GHC.Utils.Ppr as PP
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 :: JStat -> Doc
pretty :: JStat -> Doc
pretty = RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
ghcjsRenderJs
ghcjsRenderJs :: RenderJs
ghcjsRenderJs :: RenderJs
ghcjsRenderJs = RenderJs
defaultRenderJs
{ renderJsV = ghcjsRenderJsV
, renderJsS = ghcjsRenderJsS
, renderJsI = ghcjsRenderJsI
}
hdd :: SBS.ShortByteString
hdd :: ShortByteString
hdd = [Word8] -> ShortByteString
SBS.pack ((Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) [Char]
"h$$")
ghcjsRenderJsI :: RenderJs -> Ident -> Doc
ghcjsRenderJsI :: RenderJs -> Ident -> Doc
ghcjsRenderJsI RenderJs
_ (TxtI FastString
fs)
| ShortByteString
hdd ShortByteString -> ShortByteString -> Bool
`SBS.isPrefixOf` FastString -> ShortByteString
fastStringToShortByteString FastString
fs
, Int
u <- FastString -> Int
uniqueOfFS FastString
fs
= [Char] -> Doc
text [Char]
"h$$" Doc -> Doc -> Doc
<> Word -> Doc
hexDoc (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u)
| Bool
otherwise
= FastString -> Doc
ftext FastString
fs
hexDoc :: Word -> Doc
hexDoc :: Word -> Doc
hexDoc Word
0 = Char -> Doc
char Char
'0'
hexDoc Word
v = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ Word -> [Char]
go Word
v
where
sym :: Int -> Char
sym (I# Int#
i) = Char# -> Char
C# (Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
chars Int#
i)
chars :: Addr#
chars = Addr#
"0123456789abcdef"#
go :: Word -> [Char]
go = \case
Word
0 -> []
Word
n -> Int -> Char
sym (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
n Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F))
Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char
sym (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
n Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0xF0) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
4))
Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Word -> [Char]
go (Word
n Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
ghcjsRenderJsS :: RenderJs -> JStat -> Doc
ghcjsRenderJsS :: RenderJs -> JStat -> Doc
ghcjsRenderJsS RenderJs
r (BlockStat [JStat]
xs) = RenderJs -> [JStat] -> Doc
prettyBlock RenderJs
r ([JStat] -> [JStat]
flattenBlocks [JStat]
xs)
ghcjsRenderJsS RenderJs
r JStat
s = RenderJs -> RenderJs -> JStat -> Doc
renderJsS RenderJs
defaultRenderJs RenderJs
r JStat
s
ghcjsRenderJsV :: RenderJs -> JVal -> Doc
ghcjsRenderJsV :: RenderJs -> JVal -> Doc
ghcjsRenderJsV RenderJs
r (JHash UniqMap FastString JExpr
m)
| UniqMap FastString JExpr -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap FastString JExpr
m = [Char] -> Doc
text [Char]
"{}"
| Bool
otherwise = Doc -> Doc
braceNest (Doc -> Doc)
-> ([(FastString, JExpr)] -> Doc) -> [(FastString, JExpr)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.fsep ([Doc] -> Doc)
-> ([(FastString, JExpr)] -> [Doc]) -> [(FastString, JExpr)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc])
-> ([(FastString, JExpr)] -> [Doc])
-> [(FastString, JExpr)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((FastString, JExpr) -> Doc) -> [(FastString, JExpr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(FastString
x,JExpr
y) -> FastString -> Doc
quoteIfRequired FastString
x Doc -> Doc -> Doc
<> Doc
PP.colon Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y)
([(FastString, JExpr)] -> [Doc])
-> ([(FastString, JExpr)] -> [(FastString, JExpr)])
-> [(FastString, JExpr)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FastString, JExpr) -> LexicalFastString)
-> [(FastString, JExpr)] -> [(FastString, JExpr)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FastString -> LexicalFastString
LexicalFastString (FastString -> LexicalFastString)
-> ((FastString, JExpr) -> FastString)
-> (FastString, JExpr)
-> LexicalFastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, JExpr) -> FastString
forall a b. (a, b) -> a
fst) ([(FastString, JExpr)] -> Doc) -> [(FastString, JExpr)] -> Doc
forall a b. (a -> b) -> a -> b
$ UniqMap FastString JExpr -> [(FastString, JExpr)]
forall k a. UniqMap k a -> [(k, a)]
nonDetEltsUniqMap UniqMap FastString JExpr
m
where
quoteIfRequired :: FastString -> Doc
quoteIfRequired :: FastString -> Doc
quoteIfRequired FastString
x
| [Char] -> Bool
isUnquotedKey [Char]
x' = [Char] -> Doc
text [Char]
x'
| Bool
otherwise = Doc -> Doc
PP.squotes ([Char] -> Doc
text [Char]
x')
where x' :: [Char]
x' = FastString -> [Char]
unpackFS FastString
x
isUnquotedKey :: String -> Bool
isUnquotedKey :: [Char] -> Bool
isUnquotedKey [Char]
x | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x = Bool
False
| (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
x = Bool
True
| Bool
otherwise = Char -> Bool
validFirstIdent ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
x)
Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validOtherIdent ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
x)
validFirstIdent :: Char -> Bool
validFirstIdent Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
c
validOtherIdent :: Char -> Bool
validOtherIdent Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
ghcjsRenderJsV RenderJs
r JVal
v = RenderJs -> RenderJs -> JVal -> Doc
renderJsV RenderJs
defaultRenderJs RenderJs
r JVal
v
prettyBlock :: RenderJs -> [JStat] -> Doc
prettyBlock :: RenderJs -> [JStat] -> Doc
prettyBlock RenderJs
r [JStat]
xs = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
addSemi (RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs)
prettyBlock' :: RenderJs -> [JStat] -> [Doc]
prettyBlock' :: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r ( x :: JStat
x@(ReturnStat JExpr
_)
: [JStat]
xs
)
| Bool -> Bool
not ([JStat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
xs)
= RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat
x]
prettyBlock' RenderJs
r ( (DeclStat Ident
i Maybe JExpr
Nothing)
: (AssignStat (ValExpr (JVar Ident
i')) JExpr
v)
: [JStat]
xs
)
| Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
i'
= RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r (Ident -> Maybe JExpr -> JStat
DeclStat Ident
i (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
v) JStat -> [JStat] -> [JStat]
forall a. a -> [a] -> [a]
: [JStat]
xs)
prettyBlock' RenderJs
r ( (DeclStat Ident
i (Just JExpr
v0))
: (WhileStat Bool
False JExpr
p (BlockStat [JStat]
bs))
: [JStat]
xs
)
| Bool -> Bool
not ([JStat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat ([JStat] -> JStat
forall a. HasCallStack => [a] -> a
last [JStat]
flat)
= RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
True Ident
i JExpr
v0 JExpr
p ([JStat] -> JStat
forall a. HasCallStack => [a] -> a
last [JStat]
flat) ([JStat] -> [JStat]
forall a. HasCallStack => [a] -> [a]
init [JStat]
flat) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
where
flat :: [JStat]
flat = [JStat] -> [JStat]
flattenBlocks [JStat]
bs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) JExpr
v0)
: (WhileStat Bool
False JExpr
p (BlockStat [JStat]
bs))
: [JStat]
xs
)
| Bool -> Bool
not ([JStat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat ([JStat] -> JStat
forall a. HasCallStack => [a] -> a
last [JStat]
flat)
= RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
False Ident
i JExpr
v0 JExpr
p ([JStat] -> JStat
forall a. HasCallStack => [a] -> a
last [JStat]
flat) ([JStat] -> [JStat]
forall a. HasCallStack => [a] -> [a]
init [JStat]
flat) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
where
flat :: [JStat]
flat = [JStat] -> [JStat]
flattenBlocks [JStat]
bs
prettyBlock' RenderJs
r ( (DeclStat Ident
i (Just (ValExpr (JFunc [Ident]
is JStat
b))))
: [JStat]
xs
)
= (Doc -> Doc -> Doc
hangBrace ([Char] -> Doc
text [Char]
"function" Doc -> Doc -> Doc
<+> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
fsep ([Doc] -> Doc) -> ([Ident] -> [Doc]) -> [Ident] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([Ident] -> [Doc]) -> [Ident] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) ([Ident] -> Doc) -> [Ident] -> Doc
forall a b. (a -> b) -> a -> b
$ [Ident]
is))
(RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
AddOp (ValExpr (JVar Ident
i')) (ValExpr (JInt Integer
1))))
: [JStat]
xs
)
| Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"++" Doc -> Doc -> Doc
<> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
SubOp (ValExpr (JVar Ident
i')) (ValExpr (JInt Integer
1))))
: [JStat]
xs
)
| Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"--" Doc -> Doc -> Doc
<> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
AddOp (ValExpr (JVar Ident
i')) JExpr
e))
: [JStat]
xs
)
| Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
i' = (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"+=" Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r ( (AssignStat (ValExpr (JVar Ident
i)) (InfixExpr JOp
SubOp (ValExpr (JVar Ident
i')) JExpr
e))
: [JStat]
xs
)
| Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
i' = (RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"-=" Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r (JStat
x:[JStat]
xs) = RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
_ [] = []
mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor :: RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
decl Ident
i JExpr
v0 JExpr
p JStat
s1 [JStat]
sb = Doc -> Doc -> Doc
hangBrace ([Char] -> Doc
text [Char]
"for" Doc -> Doc -> Doc
<> Doc
forCond)
(RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r (JStat -> Doc) -> JStat -> Doc
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
BlockStat [JStat]
sb)
where
c0 :: Doc
c0 | Bool
decl = [Char] -> Doc
text [Char]
"var" Doc -> Doc -> Doc
<+> RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
| Bool
otherwise = RenderJs -> Ident -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
forCond :: Doc
forCond = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
interSemi
[ Doc
c0
, RenderJs -> JExpr -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
p
, Doc -> Doc
parens (RenderJs -> JStat -> Doc
forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
s1)
]
isForUpdStat :: JStat -> Bool
isForUpdStat :: JStat -> Bool
isForUpdStat UOpStat {} = Bool
True
isForUpdStat AssignStat {} = Bool
True
isForUpdStat ApplStat {} = Bool
True
isForUpdStat JStat
_ = Bool
False
interSemi :: [Doc] -> [Doc]
interSemi :: [Doc] -> [Doc]
interSemi [] = [Doc
PP.empty]
interSemi [Doc
s] = [Doc
s]
interSemi (Doc
x:[Doc]
xs) = Doc
x Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
";" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
interSemi [Doc]
xs
addSemi :: Doc -> Doc
addSemi :: Doc -> Doc
addSemi Doc
x = Doc
x Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
";"