[Git][ghc/ghc][wip/js-hline] JS: Convert rendering to use HLine instead of SDoc

Josh Meredith (@JoshMeredith) gitlab at gitlab.haskell.org
Tue May 23 16:05:58 UTC 2023



Josh Meredith pushed to branch wip/js-hline at Glasgow Haskell Compiler / GHC


Commits:
cbbbe272 by Josh Meredith at 2023-05-23T16:05:26+00:00
JS: Convert rendering to use HLine instead of SDoc

- - - - -


10 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


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cbbbe272899f66a9a8001007096cbc99dedfefd6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cbbbe272899f66a9a8001007096cbc99dedfefd6
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/20230523/4e70e9b5/attachment-0001.html>


More information about the ghc-commits mailing list