[Git][ghc/ghc][wip/js-hline] JS: Convert rendering to use HLine instead of SDoc (#22455)
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Wed May 24 11:44:16 UTC 2023
Josh Meredith pushed to branch wip/js-hline at Glasgow Haskell Compiler / GHC
Commits:
dfb47563 by Josh Meredith at 2023-05-24T11:43:55+00:00
JS: Convert rendering to use HLine instead of SDoc (#22455)
- - - - -
11 changed files:
- compiler/GHC/Driver/Config/StgToJS.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Opt.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Types.hs
- docs/users_guide/debugging.rst
Changes:
=====================================
compiler/GHC/Driver/Config/StgToJS.hs
=====================================
@@ -20,6 +20,7 @@ initStgToJSConfig dflags = StgToJSConfig
, csInlineLoadRegs = False
, csInlineEnter = False
, csInlineAlloc = False
+ , csPrettyRender = gopt Opt_DisableJsMinifier dflags
, csTraceRts = False
, csAssertRts = False
, csBoundsCheck = gopt Opt_DoBoundsChecking dflags
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -314,6 +314,9 @@ data GeneralFlag
| Opt_WriteInterface -- forces .hi files to be written even with -fno-code
| Opt_WriteHie -- generate .hie files
+ -- JavaScript opts
+ | Opt_DisableJsMinifier -- render JavaScript using a pretty-printed SDoc rather than compact a HLine
+
-- profiling opts
| Opt_AutoSccsOnIndividualCafs
| Opt_ProfCountEntries
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1859,6 +1859,10 @@ dynamic_flags_deps = [
, (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag)
, (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag)
, (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag)
+ ]
+
+ ------ JavaScript flags -----------------------------------------------
+ ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))
]
------ Language flags -------------------------------------------------
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -184,7 +184,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
) <> semi
_ -> empty
- strlit xs = docToSDoc (pprStringLit xs)
+ strlit xs = pprStringLit xs
-- the target which will form the root of what we ask rts_evalIO to run
the_cfun
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
-- For Outputable instances for JS syntax
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -55,10 +56,9 @@ module GHC.JS.Ppr
, JsToDoc(..)
, defaultRenderJs
, RenderJs(..)
+ , JsRender(..)
, jsToDoc
, pprStringLit
- , braceNest
- , hangBrace
, interSemi
, addSemi
)
@@ -75,16 +75,15 @@ import Data.List (sortOn)
import Numeric(showHex)
-import GHC.Utils.Outputable (Outputable (..), docToSDoc)
-import GHC.Utils.Ppr as PP
+import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Unique.Map
instance Outputable JExpr where
- ppr = docToSDoc . renderJs
+ ppr = renderJs
instance Outputable JVal where
- ppr = docToSDoc . renderJs
+ ppr = renderJs
--------------------------------------------------------------------------------
-- Top level API
@@ -93,87 +92,86 @@ instance Outputable JVal where
-- | 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 :: (JsToDoc a) => a -> SDoc
renderJs = renderJs' defaultRenderJs
-renderJs' :: (JsToDoc a) => RenderJs -> a -> Doc
+{-# 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 = RenderJs
- { renderJsS :: !(RenderJs -> JStat -> Doc)
- , renderJsE :: !(RenderJs -> JExpr -> Doc)
- , renderJsV :: !(RenderJs -> JVal -> Doc)
- , renderJsI :: !(RenderJs -> Ident -> Doc)
+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
+defaultRenderJs :: RenderJs doc
defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI
-jsToDoc :: JsToDoc a => a -> Doc
+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 -> Doc
+renderPrefixJs :: (JsToDoc a, JMacro a) => a -> SDoc
renderPrefixJs = renderPrefixJs' defaultRenderJs
-renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
+renderPrefixJs' :: (JsToDoc a, JMacro a, JsRender doc) => RenderJs doc -> a -> doc
renderPrefixJs' r = jsToDocR r
--------------------------------------------------------------------------------
-- Code Generator
--------------------------------------------------------------------------------
-class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
+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 = vcat . map ((<> semi) . jsToDocR r)
-instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
+instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
+instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
-defRenderJsS :: RenderJs -> JStat -> Doc
+defRenderJsS :: JsRender doc => RenderJs doc -> 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)
+ IfStat cond x y -> hangBrace (text "if" <+?> parens (jsToDocR r cond))
+ (jnest $ optBlock r x)
+ <+?> mbElse
+ where mbElse | y == BlockStat [] = empty
+ | otherwise = hangBrace (text "else") (jnest $ optBlock 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
+ DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e
+ WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (jnest $ optBlock r b)
+ WhileStat True p b -> hangBrace (text "do") (jnest $ 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) = vcat $ interSemi $ map (jsToDocR r) ss
+ printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss
printBS x = jsToDocR r x
- ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb)
+ ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (jnest $ optBlock 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)
+ 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)) (jnest $ 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) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)]
- cases = vcat l'
+ 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 . hsep . punctuate comma $ map (jsToDocR r) es)
+ 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 (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)
+ <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is))
+ (jnest $ 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)) (jnest $ optBlock r s1)
+ mbFinally | s2 == BlockStat [] = empty
+ | otherwise = hangBrace (text "finally") (jnest $ 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.
@@ -183,36 +181,41 @@ defRenderJsS r = \case
-- ...
-- });
--
- 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
+ ValExpr (JFunc is b) -> jsToDocR r i <> ftext (aOpText op) <> text " function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is) <> braceNest (jsToDocR r b)
+ _ -> 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)
+ | isPre op -> ftext (uOpText op) <+> optParens r x
+ | otherwise -> optParens r x <+> ftext (uOpText op)
BlockStat xs -> jsToDocR r xs
-optParens :: RenderJs -> JExpr -> Doc
+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 :: RenderJs -> JExpr -> Doc
+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 <+> char ':' <+> jsToDocR r z)
- InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), 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 . hsep . punctuate comma $ map (jsToDocR r) xs)
+ | 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 :: RenderJs -> JVal -> Doc
+defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
defRenderJsV r = \case
JVar i -> jsToDocR r i
- JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs
+ JList xs -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs
JDouble (SaneDouble d)
| d < 0 || isNegativeZero d -> parens (double d)
| otherwise -> double d
@@ -220,17 +223,17 @@ defRenderJsV r = \case
| i < 0 -> parens (integer i)
| otherwise -> integer i
JStr s -> pprStringLit s
- JRegEx s -> hcat [char '/',ftext s, char '/']
+ JRegEx s -> char '/' <> ftext s <> char '/'
JHash m
| isNullUniqMap m -> text "{}"
- | otherwise -> braceNest . hsep . punctuate comma .
- map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y)
+ | 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 (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
+ JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
-defRenderJsI :: RenderJs -> Ident -> Doc
+defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc
defRenderJsI _ (TxtI t) = ftext t
aOpText :: AOp -> FastString
@@ -298,17 +301,17 @@ isAlphaOp = \case
VoidOp -> True
_ -> False
-pprStringLit :: FastString -> Doc
-pprStringLit s = hcat [char '\"',encodeJson s, char '\"']
+pprStringLit :: IsLine doc => FastString -> doc
+pprStringLit s = char '\"' <> encodeJson s <> char '\"'
--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------
-encodeJson :: FastString -> Doc
+encodeJson :: IsLine doc => FastString -> doc
encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
-encodeJsonChar :: Char -> Doc
+encodeJsonChar :: IsLine doc => Char -> doc
encodeJsonChar = \case
'/' -> text "\\/"
'\b' -> text "\\b"
@@ -329,24 +332,64 @@ encodeJsonChar = \case
let h = showHex cp ""
in text (prefix ++ replicate (pad - length h) '0' ++ h)
-braceNest :: Doc -> Doc
-braceNest x = char '{' <+> nest 2 x $$ char '}'
+-- braceNest :: IsLine doc => doc -> doc
+-- braceNest x = dualsLine (\Refl -> lbrace $$ nest 2 x $$ rbrace) (\Refl -> braces x)
-interSemi :: [Doc] -> [Doc]
-interSemi [] = []
-interSemi [s] = [s]
-interSemi (x:xs) = x <> text ";" : interSemi xs
+interSemi :: JsRender doc => [doc] -> doc
+interSemi = foldl ($$$) empty . punctuateFinal semi semi
-addSemi :: Doc -> Doc
-addSemi x = x <> text ";"
+addSemi :: IsLine doc => doc -> doc
+addSemi x = x <> semi <> char '\n'
-- | 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
+-- hangBrace :: IsLine doc => doc -> doc -> doc
+-- hangBrace hdr body = dualsLine
+-- (\Refl -> hdr <+> braces (nest 2 $ ppr body))
+-- (\Refl -> hdr <> braces body)
+
+-- ($$$) :: IsLine doc => doc -> doc -> doc
+-- x $$$ y = dualsLine (\Refl -> x $$ y) (\Refl -> x <> y)
+
+-- (<+?>) :: IsLine doc => doc -> doc -> doc
+-- x <+?> y = dualsLine (\Refl -> x <+> y) (\Refl -> x <> y)
+
+
+class IsLine doc => JsRender doc where
+ (<+?>) :: doc -> doc -> doc
+ ($$$) :: doc -> doc -> doc
+ hangBrace :: doc -> doc -> doc
+ braceNest :: doc -> doc
+ jcat :: [doc] -> doc
+ jnest :: doc -> doc
+
+instance JsRender SDoc where
+ (<+?>) = (<+>)
+ {-# INLINE (<+?>) #-}
+ ($$$) = ($$)
+ {-# INLINE ($$$) #-}
+ hangBrace hdr body = hdr <+> lbrace $$ nest 2 (ppr body) $$ rbrace
+ {-# INLINE hangBrace #-}
+ braceNest x = lbrace $$ nest 2 x $$ rbrace
+ {-# INLINE braceNest #-}
+ jcat = vcat
+ {-# INLINE jcat #-}
+ jnest = nest 2
+ {-# INLINE jnest #-}
+
+instance JsRender HLine where
+ (<+?>) = (<>)
+ {-# INLINE (<+?>) #-}
+ ($$$) = (<>)
+ {-# INLINE ($$$) #-}
+ hangBrace hdr body = hdr <> braces body
+ {-# INLINE hangBrace #-}
+ braceNest = braces
+ {-# INLINE braceNest #-}
+ jcat = hcat
+ {-# INLINE jcat #-}
+ jnest = id
+ {-# INLINE jnest #-}
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -91,7 +91,7 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
-- Doc to dump when -ddump-js is enabled
when (logHasDumpFlag logger Opt_D_dump_js) $ do
putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
- $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus)
+ $ vcat (fmap (jsToDoc . oiStat . luObjUnit) lus)
-- Write the object file
bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Unit.Types
import GHC.Unit.Module (moduleStableString)
import GHC.Utils.Outputable hiding ((<>))
+import GHC.Utils.BufHandle
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Logger (Logger, logVerbAtLeast)
@@ -80,7 +81,6 @@ import Control.Monad
import Data.Array
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import Data.Function (on)
@@ -118,6 +118,9 @@ newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.A
emptyArchiveState :: IO ArchiveState
emptyArchiveState = ArchiveState <$> newIORef M.empty
+defaultJsContext :: SDocContext
+defaultJsContext = defaultSDocContext{sdocStyle = PprCode}
+
jsLinkBinary
:: JSLinkConfig
-> StgToJSConfig
@@ -173,7 +176,7 @@ link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun ex
-- LTO + rendering of JS code
link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \h ->
- renderLinker h mods jsFiles
+ renderLinker h (csPrettyRender cfg) mods jsFiles
-------------------------------------------------------------
@@ -194,8 +197,13 @@ link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun ex
-- link generated RTS parts into rts.js
unless (lcNoRts lc_cfg) $ do
- BL.writeFile (out </> "rts.js") ( BLC.pack rtsDeclsText
- <> BLC.pack (rtsText cfg))
+ if csPrettyRender cfg
+ then withFile (out </> "rts.js") WriteMode $ \h ->
+ printSDoc defaultJsContext (Ppr.PageMode True) h (rtsDeclsText $$ rtsText cfg)
+ else withFile (out </> "rts.js") WriteMode $ \h -> do
+ bh <- newBufHandle h
+ bPutHDoc bh defaultJsContext (line rtsDeclsText $$ line (rtsText cfg))
+ bFlush bh
-- link dependencies' JS files into lib.js
withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
@@ -302,10 +310,11 @@ data CompactedModuleCode = CompactedModuleCode
-- | Link modules and pretty-print them into the given Handle
renderLinker
:: Handle
+ -> Bool -- ^ should we render readable JS for debugging?
-> [ModuleCode] -- ^ linked code per module
-> [FilePath] -- ^ additional JS files
-> IO LinkerStats
-renderLinker h mods jsFiles = do
+renderLinker h render_pretty mods jsFiles = do
-- link modules
let (compacted_mods, meta) = linkModules mods
@@ -314,8 +323,13 @@ renderLinker h mods jsFiles = do
putBS = B.hPut h
putJS x = do
before <- hTell h
- Ppr.printLeftRender h (pretty x)
- hPutChar h '\n'
+ if render_pretty
+ then do
+ printSDoc defaultJsContext (Ppr.PageMode True) h (pretty x)
+ else do
+ bh <- newBufHandle h
+ bPutHDoc bh defaultJsContext ((line $ pretty x) $$ empty)
+ bFlush bh
after <- hTell h
pure $! (after - before)
=====================================
compiler/GHC/StgToJS/Linker/Opt.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Exts
import GHC.JS.Syntax
import GHC.JS.Ppr
-import GHC.Utils.Ppr as PP
+import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Unique.Map
@@ -39,10 +39,10 @@ import Data.List (sortOn)
import Data.Char (isAlpha,isDigit,ord)
import qualified Data.ByteString.Short as SBS
-pretty :: JStat -> Doc
+pretty :: JsRender doc => JStat -> doc
pretty = jsToDocR ghcjsRenderJs
-ghcjsRenderJs :: RenderJs
+ghcjsRenderJs :: RenderJs doc
ghcjsRenderJs = defaultRenderJs
{ renderJsV = ghcjsRenderJsV
, renderJsS = ghcjsRenderJsS
@@ -52,7 +52,7 @@ ghcjsRenderJs = defaultRenderJs
hdd :: SBS.ShortByteString
hdd = SBS.pack (map (fromIntegral . ord) "h$$")
-ghcjsRenderJsI :: RenderJs -> Ident -> Doc
+ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc
ghcjsRenderJsI _ (TxtI fs)
-- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by
-- name in user code, only in compiled code. Hence we can rename them if we do
@@ -75,7 +75,7 @@ ghcjsRenderJsI _ (TxtI fs)
-- | Render as an hexadecimal number in reversed order (because it's faster and we
-- don't care about the actual value).
-hexDoc :: Word -> Doc
+hexDoc :: IsLine doc => Word -> doc
hexDoc 0 = char '0'
hexDoc v = text $ go v
where
@@ -91,23 +91,23 @@ hexDoc v = text $ go v
-- attempt to resugar some of the common constructs
-ghcjsRenderJsS :: RenderJs -> JStat -> Doc
+ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
ghcjsRenderJsS r s = renderJsS defaultRenderJs r s
-- don't quote keys in our object literals, so closure compiler works
-ghcjsRenderJsV :: RenderJs -> JVal -> Doc
+ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
ghcjsRenderJsV r (JHash m)
| isNullUniqMap m = text "{}"
- | otherwise = braceNest . PP.fsep . punctuate comma .
- map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y)
+ | otherwise = braceNest . fsep . punctuate comma .
+ map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y)
-- nonDetEltsUniqMap doesn't introduce non-determinism here because
-- we sort the elements lexically
. sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m
where
- quoteIfRequired :: FastString -> Doc
+ quoteIfRequired :: IsLine doc => FastString -> doc
quoteIfRequired x
| isUnquotedKey x = ftext x
- | otherwise = PP.squotes (ftext x)
+ | otherwise = char '\'' <> ftext x <> char '\''
isUnquotedKey :: FastString -> Bool
isUnquotedKey fs = case unpackFS fs of
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -O0 #-}
@@ -45,6 +46,7 @@ import GHC.StgToJS.Linker.Opt
import GHC.Data.FastString
import GHC.Types.Unique.Map
+import GHC.JS.Ppr
import Data.Array
import Data.Monoid
@@ -314,12 +316,12 @@ rtsDecls = satJStat (Just "h$RTSD") $
, declRets]
-- | print the embedded RTS to a String
-rtsText :: StgToJSConfig -> String
-rtsText = show . pretty . jsOptimize . rts
+rtsText :: forall doc. JsRender doc => StgToJSConfig -> doc
+rtsText = pretty @doc . jsOptimize . rts
-- | print the RTS declarations to a String.
-rtsDeclsText :: String
-rtsDeclsText = show . pretty . jsOptimize $ rtsDecls
+rtsDeclsText :: forall doc. JsRender doc => doc
+rtsDeclsText = pretty @doc . jsOptimize $ rtsDecls
-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
rts :: StgToJSConfig -> Sat.JStat
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -86,6 +86,7 @@ data StgToJSConfig = StgToJSConfig
, csInlineLoadRegs :: !Bool
, csInlineEnter :: !Bool
, csInlineAlloc :: !Bool
+ , csPrettyRender :: !Bool
, csTraceRts :: !Bool
, csAssertRts :: !Bool
, csBoundsCheck :: !Bool
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -723,6 +723,16 @@ assembler.
Dump the final JavaScript code produced by the JavaScript code generator.
+JavaScript code generator
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+.. ghc-flag:: -ddisable-js-minifier
+ :shortdesc: Generate JavaScript code with whitespace
+ :type: dynamic
+
+ Include human-readable spacing and indentation when generating JavaScript.
+
+
Miscellaneous backend dumps
~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfb475635b61a4f7d14a07d74e0b8ec9618f8fd3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfb475635b61a4f7d14a07d74e0b8ec9618f8fd3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230524/130ece65/attachment-0001.html>
More information about the ghc-commits
mailing list