{-# 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 = forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
ghcjsRenderJs
ghcjsRenderJs :: RenderJs
ghcjsRenderJs :: RenderJs
ghcjsRenderJs = RenderJs
defaultRenderJs
{ renderJsV :: RenderJs -> JVal -> Doc
renderJsV = RenderJs -> JVal -> Doc
ghcjsRenderJsV
, renderJsS :: RenderJs -> JStat -> Doc
renderJsS = RenderJs -> JStat -> Doc
ghcjsRenderJsS
, renderJsI :: RenderJs -> Ident -> Doc
renderJsI = RenderJs -> Ident -> Doc
ghcjsRenderJsI
}
hdd :: SBS.ShortByteString
hdd :: ShortByteString
hdd = [Word8] -> ShortByteString
SBS.pack (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 (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 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
n forall a. Bits a => a -> a -> a
.&. Word
0x0F))
forall a. a -> [a] -> [a]
: Int -> Char
sym (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
n forall a. Bits a => a -> a -> a
.&. Word
0xF0) forall a. Bits a => a -> Int -> a
`shiftR` Int
4))
forall a. a -> [a] -> [a]
: Word -> [Char]
go (Word
n 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)
| forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap FastString JExpr
m = [Char] -> Doc
text [Char]
"{}"
| Bool
otherwise = Doc -> Doc
braceNest forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
.
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
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FastString -> LexicalFastString
LexicalFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x = Bool
False
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
x = Bool
True
| Bool
otherwise = Char -> Bool
validFirstIdent (forall a. [a] -> a
head [Char]
x)
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validOtherIdent (forall a. [a] -> [a]
tail [Char]
x)
validFirstIdent :: Char -> Bool
validFirstIdent Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c 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 forall a b. (a -> b) -> a -> b
$ 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 (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 forall a. Eq a => a -> a -> Bool
== Ident
i'
= RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r (Ident -> Maybe JExpr -> JStat
DeclStat Ident
i (forall a. a -> Maybe a
Just JExpr
v) 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat (forall a. [a] -> a
last [JStat]
flat)
= RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
True Ident
i JExpr
v0 JExpr
p (forall a. [a] -> a
last [JStat]
flat) (forall a. [a] -> [a]
init [JStat]
flat) 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JStat]
flat) Bool -> Bool -> Bool
&& JStat -> Bool
isForUpdStat (forall a. [a] -> a
last [JStat]
flat)
= RenderJs
-> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
mkFor RenderJs
r Bool
False Ident
i JExpr
v0 JExpr
p (forall a. [a] -> a
last [JStat]
flat) (forall a. [a] -> [a]
init [JStat]
flat) 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
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r) forall a b. (a -> b) -> a -> b
$ [Ident]
is))
(forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
b)
) 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 forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"++" Doc -> Doc -> Doc
<> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) 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 forall a. Eq a => a -> a -> Bool
== Ident
i' = ([Char] -> Doc
text [Char]
"--" Doc -> Doc -> Doc
<> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i) 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 forall a. Eq a => a -> a -> Bool
== Ident
i' = (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"+=" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) 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 forall a. Eq a => a -> a -> Bool
== Ident
i' = (forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"-=" Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
e) forall a. a -> [a] -> [a]
: RenderJs -> [JStat] -> [Doc]
prettyBlock' RenderJs
r [JStat]
xs
prettyBlock' RenderJs
r (JStat
x:[JStat]
xs) = forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JStat
x 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)
(forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r 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
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
| Bool
otherwise = forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r Ident
i Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
v0
forCond :: Doc
forCond = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
interSemi
[ Doc
c0
, forall a. JsToDoc a => RenderJs -> a -> Doc
jsToDocR RenderJs
r JExpr
p
, Doc -> Doc
parens (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]
";" 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]
";"