[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: base: Add build-order import of GHC.Types in GHC.IO.Handle.Types
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Jun 3 13:29:08 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4a4eb761 by Ben Gamari at 2023-06-02T23:53:21-04:00
base: Add build-order import of GHC.Types in GHC.IO.Handle.Types
For reasons similar to those described in Note [Depend on
GHC.Num.Integer].
Fixes #23411.
- - - - -
f53ac0ae by Sylvain Henry at 2023-06-02T23:54:01-04:00
JS: fix and enhance non-minimized code generation (#22455)
Flag -ddisable-js-minimizer was producing invalid code. Fix that and
also a few other things to generate nicer JS code for debugging.
The added test checks that we don't regress when using the flag.
- - - - -
e4827476 by Andrey Mokhov at 2023-06-03T09:28:55-04:00
[hadrian] Fix multiline synopsis rendering
- - - - -
b022caf1 by Bodigrim at 2023-06-03T09:28:59-04:00
Elaborate on performance properties of Data.List.++
- - - - -
14 changed files:
- compiler/GHC/JS/Make.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Opt.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- hadrian/src/Hadrian/Utilities.hs
- libraries/base/GHC/Base.hs
- libraries/base/GHC/IO/Handle/Types.hs-boot
- + testsuite/tests/javascript/T22455.hs
- + testsuite/tests/javascript/T22455.stdout
- testsuite/tests/javascript/all.T
Changes:
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.JS.Make
-- $intro_funcs
, var
, jString
- , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally
+ , jLam, jFun, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally
-- * Combinators
-- $combinators
, (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)
@@ -249,6 +249,15 @@ jLam f = ValExpr . UnsatVal . IS $ do
(block,is) <- runIdentSupply $ toSat_ f []
return $ JFunc is block
+-- | Create a new function. The result is a 'GHC.JS.Syntax.JStat'.
+-- Usage:
+--
+-- > jFun fun_name $ \x -> ...
+jFun :: ToSat a => Ident -> a -> JStat
+jFun n f = UnsatBlock . IS $ do
+ (block,is) <- runIdentSupply $ toSat_ f []
+ return $ FuncStat n is block
+
-- | Introduce a new variable into scope for the duration
-- of the enclosed expression. The result is a block statement.
-- Usage:
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -60,7 +60,6 @@ module GHC.JS.Ppr
, jsToDoc
, pprStringLit
, interSemi
- , addSemi
, braceNest
, hangBrace
)
@@ -138,15 +137,25 @@ 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 -> hangBrace (text "if" <+?> parens (jsToDocR r cond))
- (jnest $ optBlock r x)
- <+?> mbElse
+ 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") (jnest $ optBlock r y)
+ | 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)) (jnest $ optBlock r b)
- WhileStat True p b -> hangBrace (text "do") (jnest $ optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)
+ 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
@@ -154,10 +163,10 @@ defRenderJsS r = \case
printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss
printBS x = jsToDocR r x
- ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (jnest $ optBlock r sb)
+ 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)) (jnest $ optBlock r b)
+ 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
@@ -168,33 +177,35 @@ defRenderJsS r = \case
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))
- (jnest $ optBlock r b)
+ (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)
+ | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1)
mbFinally | s2 == BlockStat [] = empty
- | otherwise = hangBrace (text "finally") (jnest $ optBlock r s2)
+ | 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.
--
- -- var long_variable_name = (function()
+ -- long_variable_name = (function()
-- {
-- ...
-- });
--
- 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
+ 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
+ _ -> addSemi (jsToDocR r x)
optParens :: JsRender doc => RenderJs doc -> JExpr -> doc
optParens r x = case x of
@@ -338,9 +349,6 @@ encodeJsonChar = \case
interSemi :: JsRender doc => [doc] -> doc
interSemi = foldl ($$$) empty . punctuateFinal semi semi
-addSemi :: IsLine doc => doc -> doc
-addSemi x = x <> semi <> char '\n'
-
-- | The structure `{body}`, optionally indented over multiple lines
{-# INLINE braceNest #-}
braceNest :: JsRender doc => doc -> doc
@@ -349,7 +357,11 @@ 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 = hdr <+?> braceNest body
+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
@@ -365,16 +377,21 @@ class IsLine doc => JsRender doc where
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
(<+?>) = (<>)
@@ -385,3 +402,6 @@ instance JsRender HLine where
{-# 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 #-}
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -590,7 +590,7 @@ genericStackApply cfg = closure info body
--
genericFastApply :: StgToJSConfig -> JStat
genericFastApply s =
- TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c ->
+ jFun (TxtI "h$ap_gen_fast") \tag -> jVar \c ->
[traceRts s (jString "h$ap_gen_fast: " + tag)
, c |= closureEntry r1
, SwitchStat (entryClosureType c)
@@ -802,12 +802,12 @@ stackApply s fun_name nargs nvars =
-- h$ap_n_r_fast is entered if a function of unknown arity is called, n
-- arguments are already in r registers
fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
-fastApply s fun_name nargs nvars = func ||= body0
+fastApply s fun_name nargs nvars = body0
where
-- special case for h$ap_0_0_fast
body0 = if nargs == 0 && nvars == 0
- then jLam (enter s r1)
- else toJExpr (JFunc myFunArgs body)
+ then jFun func (enter s r1)
+ else FuncStat func myFunArgs body
func = TxtI fun_name
@@ -875,7 +875,7 @@ fastApply s fun_name nargs nvars = func ||= body0
zeroApply :: StgToJSConfig -> JStat
zeroApply s = mconcat
- [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c)
+ [ jFun (TxtI "h$e") (\c -> (r1 |= c) <> enter s c)
]
-- carefully enter a closure that might be a thunk or a function
@@ -973,13 +973,13 @@ selectors s =
mkSel :: FastString -> (JExpr -> JExpr) -> JStat
mkSel name sel = mconcat
- [TxtI createName ||= jLam \r -> mconcat
+ [jFun (TxtI createName) \r -> mconcat
[ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))
, ifS (isThunk r .||. isBlackhole r)
(returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)]))
(returnS (sel r))
]
- , TxtI resName ||= jLam \r -> mconcat
+ , jFun (TxtI resName) \r -> mconcat
[ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))
, returnS (sel r)
]
@@ -1106,7 +1106,7 @@ papGen cfg =
-- general utilities
-- move the first n registers, starting at R2, m places up (do not use with negative m)
moveRegs2 :: JStat
-moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch
+moveRegs2 = jFun (TxtI "h$moveRegs2") moveSwitch
where
moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m)
-- fast cases
=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -116,7 +116,7 @@ setObjInfo debug obj t name fields a size regs static
closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
-> JStat -- ^ rhs
-> JStat
-closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci
+closure ci body = (jFun (ciVar ci) body) `mappend` closureInfoStat False ci
conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
conClosure symbol name layout constr =
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -366,4 +366,4 @@ genToplevelRhs i rhs = case rhs of
sr)
ccId <- costCentreStackLbl cc
emitStatic idt static ccId
- return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body)))
+ return $ (FuncStat eid [] (ll <> upd <> setcc <> body))
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -198,12 +198,7 @@ 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
withFile (out </> "rts.js") WriteMode $ \h -> do
- if csPrettyRender cfg
- then printSDoc defaultJsContext (Ppr.PageMode True) h (rtsDeclsText $$ rtsText cfg)
- else do
- bh <- newBufHandle h
- bPutHDoc bh defaultJsContext (line rtsDeclsText $$ line (rtsText cfg))
- bFlush bh
+ void $ hPutJS (csPrettyRender cfg) h (rts cfg)
-- link dependencies' JS files into lib.js
withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
@@ -307,6 +302,24 @@ data CompactedModuleCode = CompactedModuleCode
, cmc_exports :: !B.ByteString -- ^ rendered exports
}
+-- | Output JS statements and return the output size in bytes.
+hPutJS :: Bool -> Handle -> Sat.JStat -> IO Integer
+hPutJS render_pretty h = \case
+ Sat.BlockStat [] -> pure 0
+ x -> do
+ before <- hTell h
+ if render_pretty
+ then do
+ printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x)
+ else do
+ bh <- newBufHandle h
+ bPutHDoc bh defaultJsContext (line $ pretty render_pretty x)
+ bFlush bh
+ -- Append an empty line to correctly end the file in a newline
+ hPutChar h '\n'
+ after <- hTell h
+ pure $! (after - before)
+
-- | Link modules and pretty-print them into the given Handle
renderLinker
:: Handle
@@ -321,18 +334,7 @@ renderLinker h render_pretty mods jsFiles = do
let
putBS = B.hPut h
- putJS x = do
- before <- hTell h
- if render_pretty
- then do
- printSDoc defaultJsContext (Ppr.PageMode True) h (pretty x)
- else do
- bh <- newBufHandle h
- -- Append an empty line to correctly end the file in a newline
- bPutHDoc bh defaultJsContext ((line $ pretty x) $$ empty)
- bFlush bh
- after <- hTell h
- pure $! (after - before)
+ putJS = hPutJS render_pretty h
---------------------------------------------------------
-- Pretty-print JavaScript code for all the dependencies.
=====================================
compiler/GHC/StgToJS/Linker/Opt.hs
=====================================
@@ -20,7 +20,7 @@
-----------------------------------------------------------------------------
module GHC.StgToJS.Linker.Opt
( pretty
- , ghcjsRenderJs
+ , optRenderJs
)
where
@@ -39,11 +39,17 @@ import Data.List (sortOn)
import Data.Char (isAlpha,isDigit,ord)
import qualified Data.ByteString.Short as SBS
-pretty :: JsRender doc => JStat -> doc
-pretty = jsToDocR ghcjsRenderJs
-
-ghcjsRenderJs :: RenderJs doc
-ghcjsRenderJs = defaultRenderJs
+pretty :: JsRender doc => Bool -> JStat -> doc
+pretty render_pretty = \case
+ BlockStat [] -> empty
+ s | render_pretty -> jsToDocR defaultRenderJs [s]
+ | otherwise -> jsToDocR optRenderJs [s]
+ -- render as a list of statements to ensure that
+ -- semicolons are added.
+
+-- | Render JS with code size minimization enabled
+optRenderJs :: RenderJs doc
+optRenderJs = defaultRenderJs
{ renderJsV = ghcjsRenderJsV
, renderJsS = ghcjsRenderJsS
, renderJsI = ghcjsRenderJsI
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
-
-{-# OPTIONS_GHC -O0 #-}
+{-# LANGUAGE BlockArguments #-}
-----------------------------------------------------------------------------
-- |
@@ -24,7 +23,11 @@
--
-----------------------------------------------------------------------------
-module GHC.StgToJS.Rts.Rts where
+module GHC.StgToJS.Rts.Rts
+ ( rts
+ , assignRegs
+ )
+where
import GHC.Prelude
@@ -42,11 +45,8 @@ import GHC.StgToJS.Regs
import GHC.StgToJS.Types
import GHC.StgToJS.Stack
-import GHC.StgToJS.Linker.Opt
-
import GHC.Data.FastString
import GHC.Types.Unique.Map
-import GHC.JS.Ppr
import Data.Array
import Data.Monoid
@@ -56,8 +56,8 @@ import qualified Data.Bits as Bits
-- | The garbageCollector resets registers and result variables.
garbageCollector :: JStat
garbageCollector =
- mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound])
- , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound])
+ mconcat [ jFun (TxtI "h$resetRegisters") (mconcat $ map resetRegister [minBound..maxBound])
+ , jFun (TxtI "h$resetResultVars") (mconcat $ map resetResultVar [minBound..maxBound])
]
-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the
@@ -233,8 +233,8 @@ declRegs =
-- | JS payload to define getters and setters on the registers.
regGettersSetters :: JStat
regGettersSetters =
- mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty)
- , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty)
+ mconcat [ jFun (TxtI "h$getReg") (\n -> SwitchStat n getRegCases mempty)
+ , jFun (TxtI "h$setReg") (\n v -> SwitchStat n (setRegCases v) mempty)
]
where
getRegCases =
@@ -292,17 +292,16 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo
mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE"
in s ||= toJExpr c
closureTypeName :: JStat
- closureTypeName =
- TxtI "h$closureTypeName" ||= jLam (\c ->
- mconcat (map (ifCT c) [minBound..maxBound])
- <> returnS (jString "InvalidClosureType"))
+ closureTypeName = jFun (TxtI "h$closureTypeName") \c ->
+ mconcat (map (ifCT c) [minBound..maxBound])
+ <> returnS (jString "InvalidClosureType")
ifCT :: JExpr -> ClosureType -> JStat
ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
-- | JS payload declaring the RTS functions.
-rtsDecls :: Sat.JStat
-rtsDecls = satJStat (Just "h$RTSD") $
+rtsDecls :: JStat
+rtsDecls =
mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread
, TxtI "h$stack" ||= null_ -- stack for the current thread
, TxtI "h$sp" ||= 0 -- stack pointer for the current thread
@@ -315,17 +314,12 @@ rtsDecls = satJStat (Just "h$RTSD") $
, declRegs
, declRets]
--- | print the embedded RTS to a String
-rtsText :: forall doc. JsRender doc => StgToJSConfig -> doc
-rtsText = pretty @doc . jsOptimize . rts
-
--- | print the RTS declarations to a String.
-rtsDeclsText :: forall doc. JsRender doc => doc
-rtsDeclsText = pretty @doc . jsOptimize $ rtsDecls
-
--- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
+-- | Generated RTS code
rts :: StgToJSConfig -> Sat.JStat
-rts = satJStat (Just "h$RTS") . rts'
+rts cfg = jsOptimize $ satJStat (Just "h$RTS") $ mconcat
+ [ rtsDecls
+ , rts' cfg
+ ]
-- | JS Payload which defines the embedded RTS.
rts' :: StgToJSConfig -> JStat
@@ -349,8 +343,8 @@ rts' s =
, TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV
, TxtI "h$vt_obj" ||= toJExpr ObjV
, TxtI "h$vt_arr" ||= toJExpr ArrV
- , TxtI "h$bh" ||= jLam (bhStats s True)
- , TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize)
+ , jFun (TxtI "h$bh") (bhStats s True)
+ , jFun (TxtI "h$bh_lne") (\x frameSize -> bhLneStats s x frameSize)
, closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
(appS "throw" [jString "oops: entered black hole"])
, closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -574,22 +574,36 @@ renderCreateFileLink linkTarget link' = do
where
link = unifyPath link'
+-- | Render a multiline string, prefixing the first line with a header.
+renderMultiLineString :: String -> String -> [String]
+renderMultiLineString header string =
+ [ linePrefix index ++ line | (index, line) <- zip [0..] (lines string) ]
+ where
+ linePrefix :: Int -> String
+ linePrefix index
+ | index == 0 = header
+ | otherwise = replicate (length header) ' '
+
+-- | Render a (possibly multiline) synopsis, making sure it ends with a dot.
+renderSynopsis :: String -> String -> [String]
+renderSynopsis header synopsis
+ | null synopsis = []
+ | otherwise = renderMultiLineString header (endWithADot synopsis)
+ where
+ endWithADot :: String -> String
+ endWithADot s = dropWhileEnd isPunctuation s ++ "."
+
-- | Render the successful build of a program.
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox $
- [ "Successfully built program " ++ name
- , "Executable: " ++ bin ] ++
- [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
+ [ "Successfully built program " ++ name, "Executable: " ++ bin ] ++
+ renderSynopsis "Program synopsis: " synopsis
-- | Render the successful build of a library.
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox $
- [ "Successfully built library " ++ name
- , "Library: " ++ lib ] ++
- [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
-
-endWithADot :: String -> String
-endWithADot s = dropWhileEnd isPunctuation s ++ "."
+ [ "Successfully built library " ++ name, "Library: " ++ lib ] ++
+ renderSynopsis "Library synopsis: " synopsis
-- | Render the given set of lines in an ASCII box. The minimum width and
-- whether to use Unicode symbols are hardcoded in the function's body.
=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -1461,8 +1461,13 @@ The rules for map work like this.
--
-- If the first list is not finite, the result is the first list.
--
--- WARNING: This function takes linear time in the number of elements of the
--- first list.
+-- This function takes linear time in the number of elements of the
+-- __first__ list. Thus it is better to associate repeated
+-- applications of '(++)' to the right (which is the default behaviour):
+-- @xs ++ (ys ++ zs)@ or simply @xs ++ ys ++ zs@, but not @(xs ++ ys) ++ zs at .
+-- For the same reason 'Data.List.concat' @=@ 'Data.List.foldr' '(++)' @[]@
+-- has linear performance, while 'Data.List.foldl' '(++)' @[]@ is prone
+-- to quadratic slowdown.
(++) :: [a] -> [a] -> [a]
{-# NOINLINE [2] (++) #-}
=====================================
libraries/base/GHC/IO/Handle/Types.hs-boot
=====================================
@@ -2,4 +2,7 @@
module GHC.IO.Handle.Types ( Handle ) where
+-- See Note [Depend on GHC.Num.Integer] in GHC.Base
+import GHC.Types ()
+
data Handle
=====================================
testsuite/tests/javascript/T22455.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "Hello World"
=====================================
testsuite/tests/javascript/T22455.stdout
=====================================
@@ -0,0 +1 @@
+Hello World
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -17,3 +17,4 @@ test('js-callback04', js_skip, compile_and_run, [''])
test('js-callback05', js_skip, compile_and_run, [''])
test('T23346', normal, compile_and_run, [''])
+test('T22455', normal, compile_and_run, ['-ddisable-js-minifier'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f442f113eba70491eeb21636485e2dd480d7c2b0...b022caf1b80442c58cdb6ca97913b442d923d92a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f442f113eba70491eeb21636485e2dd480d7c2b0...b022caf1b80442c58cdb6ca97913b442d923d92a
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/20230603/2ee696d9/attachment-0001.html>
More information about the ghc-commits
mailing list