December 2025 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/fast-eq
by Cheng Shao (＠TerrorJack) 07 Dec '25

07 Dec '25

Cheng Shao pushed new branch wip/fast-eq at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fast-eq You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: ci: Try using multi repl in ghc-in-ghci test
by Marge Bot (＠marge-bot) 07 Dec '25

07 Dec '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d5d940b3 by Matthew Pickering at 2025-12-07T03:58:31-05:00 ci: Try using multi repl in ghc-in-ghci test This should be quite a bit faster than the ./hadrian/ghci command as it doesn't properly build all the dependencies. - - - - - f6cbfed3 by Rodrigo Mesquita at 2025-12-07T03:58:32-05:00 Stack.Decode: Don't error on bitmap size 0 A RET_BCO may have a bitmap with no payload. In that case, the bitmap = 0. One can observe this by using -ddump-bcos and interpreting ``` main = pure () ``` Observe, for instance, that the BCO for this main function has size 0: ``` ProtoBCO Main.main#0: \u [] break<main:Main,0>() GHC.Internal.Base.pure GHC.Internal.Base.$fApplicativeIO GHC.Internal.Tuple.() bitmap: 0 [] BRK_FUN <breakarray> main:Main 0 <cc> PACK () 0 PUSH_G GHC.Internal.Base.$fApplicativeIO PUSH_APPLY_PP PUSH_G GHC.Internal.Base.pure ENTER ``` Perhaps we never tried to decode a stack in which a BCO like this was present. However, for the debugger, we want to decode stacks of threads stopped at breakpoints, and these kind of BCOs do get on a stack under e.g. `stg_apply_interp_info` frames. See the accompanying test in the next commit for an example to trigger the bug this commit fixes. Fixes #26640 - - - - - d844061d by Rodrigo Mesquita at 2025-12-07T03:58:32-05:00 Add test for #26640 - - - - - 6 changed files: - .gitlab-ci.yml - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + testsuite/tests/bytecode/T26640.hs - + testsuite/tests/bytecode/T26640.script - + testsuite/tests/bytecode/T26640.stdout - testsuite/tests/bytecode/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -416,7 +416,7 @@ hadrian-ghc-in-ghci: # workaround for docker permissions - sudo chown ghc:ghc -R . variables: - GHC_FLAGS: -Werror + GHC_FLAGS: -Werror -Wwarn=unused-imports tags: - x86_64-linux script: @@ -428,7 +428,7 @@ hadrian-ghc-in-ghci: - "echo ' ghc-options: -Werror' >> hadrian/cabal.project.local" # Load ghc-in-ghci then immediately exit and check the modules loaded - export CORES="$(mk/detect-cpu-count.sh)" - - echo ":q" | HADRIAN_ARGS=-j$CORES hadrian/ghci -j$CORES | tail -n2 | grep "Ok," + - echo ":q" | HADRIAN_ARGS=-j$CORES hadrian/ghci-multi -j$CORES | tail -n2 | grep "Ok," after_script: - .gitlab/ci.sh save_cache - cat ci_timings.txt ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -269,7 +269,7 @@ decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)] usedBitmapWords :: Int -> Int - usedBitmapWords 0 = error "Invalid large bitmap size 0." + usedBitmapWords 0 = 0 usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1 bitmapWordsPointerness :: Word -> [Word] -> [Pointerness] ===================================== testsuite/tests/bytecode/T26640.hs ===================================== @@ -0,0 +1,4 @@ +-- Main.hs +module Main where +main = pure () + ===================================== testsuite/tests/bytecode/T26640.script ===================================== @@ -0,0 +1,6 @@ +:l T26640 +:break 3 +main +import GHC.Conc +import GHC.Stack.CloneStack +() <- mapM_ (\ix -> do !_ <- decode =<< cloneThreadStack ix; return ()) =<< listThreads ===================================== testsuite/tests/bytecode/T26640.stdout ===================================== @@ -0,0 +1,3 @@ +Breakpoint 0 activated at T26640.hs:3:8-14 +Stopped in Main.main, T26640.hs:3:8-14 +_result :: IO () = _ ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -8,6 +8,7 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, test('T26565', extra_files(["T26565.hs"]), ghci_script, ['T26565.script']) test('T23973', extra_files(["T23973.hs"]), ghci_script, ['T23973.script']) +test('T26640', extra_files(["T26640.hs"]), ghci_script, ['T26640.script']) # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e337061f82ce0c564b1ca48fd3e44… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e337061f82ce0c564b1ca48fd3e44… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/no-binary-char-2] WIP
by Cheng Shao (＠TerrorJack) 07 Dec '25

07 Dec '25

Cheng Shao pushed to branch wip/no-binary-char-2 at Glasgow Haskell Compiler / GHC Commits: 82d390b5 by Cheng Shao at 2025-12-07T07:49:30+01:00 WIP - - - - - 2 changed files: - compiler/GHC/Data/FastString.hs - compiler/GHC/Iface/Recomp.hs Changes: ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -55,6 +55,7 @@ module GHC.Data.FastString -- * ShortByteString fastStringToShortByteString, + fastStringToOsPath, mkFastStringShortByteString, -- * ShortText @@ -142,6 +143,7 @@ import System.IO import Data.Data import Data.IORef import Data.Semigroup as Semi +import Data.Type.Coercion (coerceWith, sym) import Foreign @@ -149,6 +151,12 @@ import GHC.Conc.Sync (sharedCAF) import GHC.Exts import GHC.IO +import System.OsString.Internal.Types + ( PosixString(..) + , WindowsString(..) + , coercionToPlatformTypes + ) +import System.OsPath (OsPath) -- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' bytesFS, fastStringToByteString :: FastString -> ByteString @@ -161,6 +169,14 @@ fastStringToByteString = bytesFS fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs +fastStringToOsPath :: FastString -> OsPath +fastStringToOsPath fs = + case coercionToPlatformTypes of + Left (_cChar, cStr) -> + coerceWith (sym cStr) (WindowsString (fastStringToShortByteString fs)) + Right (_cChar, cStr) -> + coerceWith (sym cStr) (PosixString (fastStringToShortByteString fs)) + fastStringToShortText :: FastString -> ShortText fastStringToShortText = ShortText . fs_sbs ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -53,7 +53,7 @@ import GHC.Utils.Exception import GHC.Utils.Logger import GHC.Utils.Constants (debugIsOn) import qualified GHC.Data.ShortText as ST -import GHC.Data.OsPath (unsafeDecodeUtf) +import GHC.Data.OsPath (OsPath, unsafeDecodeUtf) import GHC.Types.Annotations import GHC.Types.Avail @@ -195,9 +195,9 @@ data RecompReason | ModuleAdded (ImportLevel, UnitId, ModuleName) | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName - | FileChanged FilePath - | DirChanged FilePath - | CustomReason String + | FileChanged !OsPath + | DirChanged !OsPath + | CustomReason !ST.ShortText | FlagsChanged | LinkFlagsChanged | OptimFlagsChanged @@ -232,9 +232,9 @@ instance Outputable RecompReason where ModuleChangedIface m -> ppr m <+> text "changed (interface)" ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed" ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" - FileChanged fp -> text fp <+> text "changed" - DirChanged dp -> text "Contents of" <+> text dp <+> text "changed" - CustomReason s -> text s + FileChanged fp -> text (unsafeDecodeUtf fp) <+> text "changed" + DirChanged dp -> text "Contents of" <+> text (unsafeDecodeUtf dp) <+> text "changed" + CustomReason s -> text (ST.unpack s) FlagsChanged -> text "Flags changed" LinkFlagsChanged -> text "Flags changed" OptimFlagsChanged -> text "Optimisation flags changed" @@ -812,10 +812,11 @@ checkModUsage fc UsageFile{ usg_file_path = file, if (old_hash /= new_hash) then return recomp else return UpToDate - where - reason = FileChanged $ unpackFS file - recomp = needsRecompileBecause $ fromMaybe reason $ fmap (CustomReason . ST.unpack) mlabel - handler = if debugIsOn + where + pathOs = fastStringToOsPath file + reason = FileChanged pathOs + recomp = needsRecompileBecause $ fromMaybe reason (CustomReason <$> mlabel) + handler = if debugIsOn then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail @@ -828,10 +829,11 @@ checkModUsage fc UsageDirectory{ usg_dir_path = dir, if (old_hash /= new_hash) then return recomp else return UpToDate - where - reason = DirChanged $ unpackFS dir - recomp = needsRecompileBecause $ fromMaybe reason $ fmap (CustomReason . ST.unpack) mlabel - handler = if debugIsOn + where + dirOs = fastStringToOsPath dir + reason = DirChanged dirOs + recomp = needsRecompileBecause $ fromMaybe reason (CustomReason <$> mlabel) + handler = if debugIsOn then \e -> pprTrace "UsageDirectory" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the dir, just recompile, don't fail View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82d390b5649b4de95ba99f50da6059d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82d390b5649b4de95ba99f50da6059d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-part2] 39 commits: Build external interpreter program on demand (#24731)
by Simon Peyton Jones (＠simonpj) 07 Dec '25

07 Dec '25

Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 55eab80d by Sylvain Henry at 2025-11-20T17:33:13-05:00 Build external interpreter program on demand (#24731) This patch teaches GHC how to build the external interpreter program when it is missing. As long as we have the `ghci` library, doing this is trivial so most of this patch is refactoring for doing it sanely. - - - - - 08bbc028 by Rodrigo Mesquita at 2025-11-20T17:33:54-05:00 Add tests for #23973 and #26565 These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417 - - - - - 6b42232c by sheaf at 2025-11-20T17:34:35-05:00 Mark T26410_ffi as fragile on Windows As seen in #26595, this test intermittently fails on Windows. This commit marks it as fragile, until we get around to fixing it. - - - - - b7b7c049 by Andrew Lelechenko at 2025-11-21T21:04:01+00:00 Add nubOrd / nubOrdBy to Data.List and Data.List.NonEmpty As per https://github.com/haskell/core-libraries-committee/issues/336 - - - - - 352d5462 by Marc Scholten at 2025-11-22T10:33:03-05:00 Fix haddock test runner to handle UTF-8 output xhtml 3000.4.0.0 now produces UTF-8 output instead of escaping non-ASCII characters. When using --test-accept it previously wrote files in the wrong encoding because they have not been decoded properly when reading the files. - - - - - 48a3ed57 by Simon Peyton Jones at 2025-11-25T15:33:54+00:00 Add a fast-path for args=[] to occAnalApp In the common case of having not arguments, occAnalApp was doing redundant work. - - - - - 951e5ed9 by Simon Peyton Jones at 2025-11-25T15:33:54+00:00 Fix a performance hole in the occurrence analyser As #26425 showed, the clever stuff in Note [Occurrence analysis for join points] does a lot of duplication of usage details. This patch improved matters with a little fancy footwork. It is described in the new (W4) of the same Note. Compile-time allocations go down slightly. Here are the changes of +/- 0.5% or more: T13253(normal) 329,369,244 326,395,544 -0.9% T13253-spj(normal) 66,410,496 66,095,864 -0.5% T15630(normal) 129,797,200 128,663,136 -0.9% T15630a(normal) 129,212,408 128,027,560 -0.9% T16577(normal) 6,756,706,896 6,723,028,512 -0.5% T18282(normal) 128,462,070 125,808,584 -2.1% GOOD T18698a(normal) 208,418,305 202,037,336 -3.1% GOOD T18730(optasm) 136,981,756 136,208,136 -0.6% T18923(normal) 58,103,088 57,745,840 -0.6% T19695(normal) 1,386,306,272 1,365,609,416 -1.5% T26425(normal) 3,344,402,957 2,457,811,664 -26.5% GOOD T6048(optasm) 79,763,816 79,212,760 -0.7% T9020(optasm) 225,278,408 223,682,440 -0.7% T9961(normal) 303,810,717 300,729,168 -1.0% GOOD geo. mean -0.5% minimum -26.5% maximum +0.4% Metric Decrease: T18282 T18698a T26425 T9961 - - - - - f1959dfc by Simon Peyton Jones at 2025-11-26T11:58:07+00:00 Remove a quadratic-cost assertion check in mkCoreApp See the new Note [Assertion checking in mkCoreApp] - - - - - 98fa0d36 by Simon Hengel at 2025-11-27T17:54:57-05:00 Fix typo in docs/users_guide/exts/type_families.rst - - - - - 5b97e5ce by Simon Hengel at 2025-11-27T17:55:37-05:00 Fix broken RankNTypes example in user's guide - - - - - fa2aaa00 by Simon Peyton Jones at 2025-11-27T17:56:18-05:00 Switch off specialisation in ExactPrint In !15057 (where we re-introduced -fpolymoprhic-specialisation) we found that ExactPrint's compile time blew up by a factor of 5. It turned out to be caused by bazillions of specialisations of `markAnnotated`. Since ExactPrint isn't perf-critical, it does not seem worth taking the performance hit, so this patch switches off specialisation in this one module. - - - - - 1fd25987 by Simon Peyton Jones at 2025-11-27T17:56:18-05:00 Switch -fpolymorphic-specialisation on by default This patch addresses #23559. Now that !10479 has landed and #26329 is fixed, we can switch on polymorphic specialisation by default, addressing a bunch of other tickets listed in #23559. Metric changes: * CoOpt_Singleton: +4% compiler allocations: we just get more specialisations * info_table_map_perf: -20% decrease in compiler allocations. This is caused by using -fno-specialise in ExactPrint.hs Without that change we get a 4x blow-up in compile time; see !15058 for details Metric Decrease: info_table_map_perf Metric Increase: CoOpt_Singletons - - - - - b7fe7445 by Matthew Pickering at 2025-11-27T17:56:59-05:00 rts: Fix a deadlock with eventlog flush interval and RTS shutdown The ghc_ticker thread attempts to flush at the eventlog tick interval, this requires waiting to take all capabilities. At the same time, the main thread is shutting down, the schedule is stopped and then we wait for the ticker thread to finish. Therefore we are deadlocked. The solution is to use `newBoundTask/exitMyTask`, so that flushing can cooperate with the scheduler shutdown. Fixes #26573 - - - - - 1d4a1229 by sheaf at 2025-11-27T17:58:02-05:00 SimpleOpt: don't subst in pushCoercionIntoLambda It was noticed in #26589 that the change in 15b311be was incorrect: the simple optimiser carries two different substitution-like pieces of information: 'soe_subst' (from InVar to OutExpr) and 'soe_inl' (from InId to InExpr). It is thus incorrect to have 'pushCoercionIntoLambda' apply the substitution from 'soe_subst' while discarding 'soe_inl' entirely, which is what was done in 15b311be. Instead, we change back pushCoercionIntoLambda to take an InScopeSet, and optimise the lambda before calling 'pushCoercionIntoLambda' to avoid mixing InExpr with OutExpr, or mixing two InExpr with different environments. We can then call 'soeZapSubst' without problems. Fixes #26588 #26589 - - - - - 84a087d5 by Sylvain Henry at 2025-11-28T17:35:28-05:00 Fix PIC jump tables on Windows (#24016) Avoid overflows in jump tables by using a base label closer to the jump targets. See added Note [Jump tables] - - - - - 82db7042 by Zubin Duggal at 2025-11-28T17:36:10-05:00 rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache. The original strings are temporary and might be freed at an arbitrary point. Fixes #26613 - - - - - ff3f0d09 by Ben Gamari at 2025-11-29T18:34:28-05:00 gitlab-ci: Run ghcup-metadata jobs on OpenCape runners This significantly reduces our egress traffic and makes the jobs significantly faster. - - - - - ef0dc33b by Matthew Pickering at 2025-11-29T18:35:10-05:00 Use 'OsPath' in getModificationTimeIfExists This part of the compiler is quite hot during recompilation checking in particular since the filepaths will be translated to a string. It is better to use the 'OsPath' native function, which turns out to be easy to do. - - - - - fa3bd0a6 by Georgios Karachalias at 2025-11-29T18:36:05-05:00 Use OsPath in PkgDbRef and UnitDatabase, not FilePath - - - - - 0d7c05ec by Ben Gamari at 2025-12-01T03:13:46-05:00 hadrian: Place user options after package arguments This makes it easier for the user to override the default package arguments with `UserSettings.hs`. Fixes #25821. ------------------------- Metric Decrease: T14697 ------------------------- - - - - - 3b2c4598 by Vladislav Zavialov at 2025-12-01T03:14:29-05:00 Namespace-specified wildcards in import/export lists (#25901) This change adds support for top-level namespace-specified wildcards `type ..` and `data ..` to import and export lists. Examples: import M (type ..) -- imports all type and class constructors from M import M (data ..) -- imports all data constructors and terms from M module M (type .., f) where -- exports all type and class constructors defined in M, -- plus the function 'f' The primary intended usage of this feature is in combination with module aliases, allowing namespace disambiguation: import Data.Proxy as T (type ..) -- T.Proxy is unambiguously the type constructor import Data.Proxy as D (data ..) -- D.Proxy is unambiguously the data constructor The patch accounts for the interactions of wildcards with: * Imports with `hiding` clauses * Import warnings -Wunused-imports, -Wdodgy-imports * Export warnings -Wduplicate-exports, -Wdodgy-exports Summary of the changes: 1. Move the NamespaceSpecifier type from GHC.Hs.Binds to GHC.Hs.Basic, making it possible to use it in more places in the AST. 2. Extend the AST (type: IE) with a representation of `..`, `type ..`, and `data ..` (constructor: IEWholeNamespace). Per the proposal, the plain `..` is always rejected with a dedicated error message. 3. Extend the grammar in Parser.y with productions for `..`, `type ..`, and `data ..` in both import and export lists. 4. Implement wildcard imports by updating the `filterImports` function in GHC.Rename.Names; the logic for IEWholeNamespace is roughly modeled after the Nothing (no explicit import list) case. 5. Implement wildcard exports by updating the `exports_from_avail` function in GHC.Tc.Gen.Export; the logic for IEWholeNamespace is closely modeled after the IEModuleContents case. 6. Refactor and extend diagnostics to report the new warnings and errors. See PsErrPlainWildcardImport, DodgyImportsWildcard, PsErrPlainWildcardExport, DodgyExportsWildcard, TcRnDupeWildcardExport. Note that this patch is specifically about top-level import/export items. Subordinate import/export items are left unchanged. - - - - - c71faa76 by Luite Stegeman at 2025-12-01T03:16:05-05:00 rts: Handle overflow of ELF section header string table If the section header string table is stored in a section greater than or equal to SHN_LORESERVE (0xff00), the 16-bit field e_shstrndx in the ELF header does not contain the section number, but rather an overflow value SHN_XINDEX (0xffff) indicating that we need to look elsewhere. This fixes the linker by not using e_shstrndx directly but calling elf_shstrndx, which correctly handles the SHN_XINDEX value. Fixes #26603 - - - - - ab20eb54 by Mike Pilgrem at 2025-12-01T22:46:55+00:00 Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`). In module `Settings.Warnings`, applies `-Wno-x-partial` to the `filepath`, and `parsec` packages (outside GHC's repository). Also bumps submodules. - - - - - fc1d7f79 by Jade Lovelace at 2025-12-02T11:04:09-05:00 docs: fix StandaloneKindSignatures in DataKinds docs These should be `type` as otherwise GHC reports a duplicate definition error. - - - - - beae879b by Rodrigo Mesquita at 2025-12-03T15:42:37+01:00 task: Substitute some datatypes for newtypes * Substitutes some data type declarations for newtype declarations * Adds comment to `LlvmConfigCache`, which must decidedly not be a newtype. Fixes #23555 - - - - - 3bd7dd44 by mangoiv at 2025-12-04T04:36:45-05:00 Renamer: reinstate the template haskell level check in notFound Out-of-scope names might be caused by a staging error, as is explained by Note [Out of scope might be a staging error] in GHC.Tc.Utils.Env.hs. This logic was assumed to be dead code after 217caad1 and has thus been removed. This commit reintroduces it and thus fixes issue #26099. - - - - - 0318010b by Zubin Duggal at 2025-12-04T04:37:27-05:00 testlib: Optionally include the way name in the expected output file This allows us to have different outputs for different ways. - - - - - 6d945fdd by Zubin Duggal at 2025-12-04T04:37:27-05:00 testsuite: Accept output of tests failing in ext-interp way due to differing compilation requirements Fixes #26552 - - - - - 0ffc5243 by Cheng Shao at 2025-12-04T04:38:09-05:00 devx: minor fixes for compile_flags.txt This patch includes minor fixes for compile_flags.txt to improve developer experience when using clangd as language server to hack on RTS C sources: - Ensure `-fPIC` is passed and `__PIC__` is defined, to be coherent with `-DDYNAMIC` and ensure the `__PIC__` guarded code paths are indexed - Add the missing `-DRtsWay` definition, otherwise a few source files like `RtsUtils.c` and `Trace.c` would produce clangd errors - - - - - e36a5fcb by Matthew Pickering at 2025-12-05T16:25:57-05:00 Add support for building bytecode libraries A bytecode library is a collection of bytecode files (.gbc) and a library which combines together additional object files. A bytecode library is created by invoking GHC with the `-bytecodelib` flag. A library can be created from in-memory `ModuleByteCode` linkables or by passing `.gbc` files as arguments on the command line. Fixes #26298 - - - - - 8f9ae339 by Matthew Pickering at 2025-12-05T16:25:57-05:00 Load bytecode libraries to satisfy package dependencies This commit allows you to use a bytecode library to satisfy a package dependency when using the interpreter. If a user enables `-fprefer-byte-code`, then if a package provides a bytecode library, that will be loaded and used to satisfy the dependency. The main change is to separate the relevant parts of the `LoaderState` into external and home package byte code. Bytecode is loaded into either the home package or external part (similar to HPT/EPS split), HPT bytecode can be unloaded. External bytecode is never unloaded. The unload function has also only been called with an empty list of "stable linkables" for a long time. It has been modified to directly implement a complete unloading of the home package bytecode linkables. At the moment, the bytecode libraries are found in the "library-dirs" field from the package description. In the future when `Cabal` implements support for "bytecode-library-dirs" field, we can read the bytecode libraries from there. No changes to the Cabal submodule are necessary at the moment. Four new tests are added in testsuite/tests/cabal, which generate fake package descriptions and test loading the libraries into GHCi. Fixes #26298 - - - - - 54458ce4 by mangoiv at 2025-12-05T16:26:50-05:00 ExplicitLevelImports: improve documentation of the code - more explicit names for variable names like `flg` or `topLevel` - don't pass the same value twice to functions - some explanations of interesting but undocumented code paths - adjust comment to not mention non-existent error message - - - - - c7061392 by mangoiv at 2025-12-05T16:27:42-05:00 driver: don't expect nodes to exist when checking paths between them In `mgQueryZero`, previously node lookups were expected to never fail, i.e. it was expected that when calculating the path between two nodes in a zero level import graph, both nodes would always exist. This is not the case, e.g. in some situations involving exact names (see the test-case). The fix is to first check whether the node is present in the graph at all, instead of panicking, just to report that there is no path. Closes #26568 - - - - - d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00 NCG/LA64: Simplify genCCall into two parts genCCall is too long, so it's been simplified into two parts: genPrim and genLibCCall. Suggested by Andreas Klebinger - - - - - 9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00 hadrian: Use a response file to invoke GHC for dep gathering. In some cases we construct an argument list too long for GHC to handle directly on windows. This happens when we generate the dependency file because the command line will contain references to a large number of .hs files. To avoid this we now invoke GHC using a response file when generating dependencies to sidestep length limitations. Note that we only pass the actual file names in the dependency file. Why? Because this side-steps #26560 - - - - - 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. - - - - - 0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00 users' guide: don't use f strings in the python script to ensure compatibility with python 3.5 - - - - - 9120a39f by Simon Peyton Jones at 2025-12-07T00:02:46+00:00 Improved fundeps for closed type families The big payload of this commit is to execute the plan suggested in #23162, by improving the way that we generate functional dependencies for closed type families. It is all described in Note [Exploiting closed type families] Most of the changes are in GHC.Tc.Solver.FunDeps Other small changes * GHC.Tc.Solver.bumpReductionDepth. This function brings together the code that * Bumps the depth * Checks for overflow Previously the two were separated, sometimes quite widely. * GHC.Core.Unify.niFixSubst: minor improvement, removing an unnecessary itraetion in the base case. * GHC.Core.Unify: no need to pass an InScopeSet to tcUnifyTysForInjectivity. It can calculate one for itself; and it is never inspected anyway so it's free to do so. * GHC.Tc.Errors.Ppr: slight impovement to the error message for reduction-stack overflow, when a constraint (rather than a type) is involved. * GHC.Tc.Solver.Monad.wrapUnifier: small change to the API - - - - - 319 changed files: - .gitlab-ci.yml - compile_flags.txt - compiler/GHC.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/CmmToAsm/AArch64/RegInfo.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/RegInfo.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CodeOutput.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/LlvmConfigCache.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/Iface/Ext/Ast.hs - + compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Linker/Windows.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Prelude/Basic.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Settings.hs - compiler/GHC/SysTools/Tasks.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Set.hs - compiler/GHC/Types/Var/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Misc.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/exts/data_kinds.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/type_families.rst - docs/users_guide/phases.rst - docs/users_guide/using-optimisation.rst - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/src/Builder.hs - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Warnings.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - + libraries/base/src/Data/List/NubOrdSet.hs - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - libraries/xhtml - linters/lint-codes/LintCodes/Static.hs - rts/eventlog/EventLog.c - rts/linker/Elf.c - rts/linker/LoadArchive.c - rts/linker/PEi386.c - testsuite/config/ghc - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - + testsuite/tests/bytecode/T23973.hs - + testsuite/tests/bytecode/T23973.script - + testsuite/tests/bytecode/T23973.stdout - + testsuite/tests/bytecode/T26565.hs - + testsuite/tests/bytecode/T26565.script - + testsuite/tests/bytecode/T26565.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/cabal/Bytecode.hs - + testsuite/tests/cabal/BytecodeForeign.c - + testsuite/tests/cabal/BytecodeForeign.hs - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/bytecode.pkg - + testsuite/tests/cabal/bytecode.script - + testsuite/tests/cabal/bytecode_foreign.pkg - + testsuite/tests/cabal/bytecode_foreign.script - testsuite/tests/cabal/ghcpkg03.stderr - testsuite/tests/cabal/ghcpkg03.stderr-mingw32 - testsuite/tests/cabal/ghcpkg05.stderr - testsuite/tests/cabal/ghcpkg05.stderr-mingw32 - + testsuite/tests/cabal/pkg_bytecode.stderr - + testsuite/tests/cabal/pkg_bytecode.stdout - + testsuite/tests/cabal/pkg_bytecode_foreign.stderr - + testsuite/tests/cabal/pkg_bytecode_foreign.stdout - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout - + testsuite/tests/cabal/pkg_bytecode_with_o.stderr - + testsuite/tests/cabal/pkg_bytecode_with_o.stdout - + testsuite/tests/codeGen/should_run/T24016.hs - + testsuite/tests/codeGen/should_run/T24016.stdout - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/driver/T20696/T20696.stderr-ext-interp - testsuite/tests/driver/T20696/all.T - + testsuite/tests/driver/T24731.hs - testsuite/tests/driver/all.T - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout - testsuite/tests/driver/fat-iface/all.T - + testsuite/tests/driver/fat-iface/fat012.stderr-ext-interp - + testsuite/tests/driver/fat-iface/fat015.stderr-ext-interp - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs - testsuite/tests/indexed-types/should_fail/T12522a.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/module/T25901_exp_plain_wc.hs - + testsuite/tests/module/T25901_exp_plain_wc.stderr - + testsuite/tests/module/T25901_imp_plain_wc.hs - + testsuite/tests/module/T25901_imp_plain_wc.stderr - testsuite/tests/module/all.T - testsuite/tests/quantified-constraints/T15316A.stderr - testsuite/tests/quantified-constraints/T17267.stderr - testsuite/tests/quantified-constraints/T17267a.stderr - testsuite/tests/quantified-constraints/T17267b.stderr - testsuite/tests/quantified-constraints/T17267c.stderr - testsuite/tests/quantified-constraints/T17267e.stderr - testsuite/tests/quantified-constraints/T17458.stderr - + testsuite/tests/rename/should_compile/T25901_exp_1.hs - + testsuite/tests/rename/should_compile/T25901_exp_1_helper.hs - + testsuite/tests/rename/should_compile/T25901_exp_2.hs - + testsuite/tests/rename/should_compile/T25901_exp_2_helper.hs - + testsuite/tests/rename/should_compile/T25901_imp_hq.hs - + testsuite/tests/rename/should_compile/T25901_imp_hu.hs - + testsuite/tests/rename/should_compile/T25901_imp_sq.hs - + testsuite/tests/rename/should_compile/T25901_imp_su.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_1_helper.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_2_helper.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.hs - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.stderr - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rts/KeepCafsBase.hs - testsuite/tests/rts/all.T - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26588.hs - + testsuite/tests/simplCore/should_compile/T26589.hs - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/splice-imports/SI07.stderr-ext-interp - testsuite/tests/splice-imports/all.T - + testsuite/tests/th/T26099.hs - + testsuite/tests/th/T26099.stderr - + testsuite/tests/th/T26568.hs - + testsuite/tests/th/T26568.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_fail/ContextStack1.stderr - testsuite/tests/typecheck/should_fail/T22924b.stderr - + testsuite/tests/typecheck/should_fail/T23162b.hs - + testsuite/tests/typecheck/should_fail/T23162b.stderr - + testsuite/tests/typecheck/should_fail/T23162c.hs - + testsuite/tests/typecheck/should_fail/T23162d.hs - testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/unboxedsums/UbxSumUnpackedSize.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr - + testsuite/tests/warnings/should_compile/T25901_helper_1.hs - + testsuite/tests/warnings/should_compile/T25901_helper_2.hs - + testsuite/tests/warnings/should_compile/T25901_helper_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/haddock/haddock-test/src/Test/Haddock.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html - utils/hpc - utils/hsc2hs - utils/iserv/iserv.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6edda869870da4fe7d5c726e00f80… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6edda869870da4fe7d5c726e00f80… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: NCG/LA64: Simplify genCCall into two parts
by Marge Bot (＠marge-bot) 07 Dec '25

07 Dec '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00 NCG/LA64: Simplify genCCall into two parts genCCall is too long, so it's been simplified into two parts: genPrim and genLibCCall. Suggested by Andreas Klebinger - - - - - 9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00 hadrian: Use a response file to invoke GHC for dep gathering. In some cases we construct an argument list too long for GHC to handle directly on windows. This happens when we generate the dependency file because the command line will contain references to a large number of .hs files. To avoid this we now invoke GHC using a response file when generating dependencies to sidestep length limitations. Note that we only pass the actual file names in the dependency file. Why? Because this side-steps #26560 - - - - - 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. - - - - - 0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00 users' guide: don't use f strings in the python script to ensure compatibility with python 3.5 - - - - - 82651103 by Matthew Pickering at 2025-12-06T17:47:55-05:00 ci: Try using multi repl in ghc-in-ghci test This should be quite a bit faster than the ./hadrian/ghci command as it doesn't properly build all the dependencies. - - - - - 40ae910e by Rodrigo Mesquita at 2025-12-06T17:47:56-05:00 Stack.Decode: Don't error on bitmap size 0 A RET_BCO may have a bitmap with no payload. In that case, the bitmap = 0. One can observe this by using -ddump-bcos and interpreting ``` main = pure () ``` Observe, for instance, that the BCO for this main function has size 0: ``` ProtoBCO Main.main#0: \u [] break<main:Main,0>() GHC.Internal.Base.pure GHC.Internal.Base.$fApplicativeIO GHC.Internal.Tuple.() bitmap: 0 [] BRK_FUN <breakarray> main:Main 0 <cc> PACK () 0 PUSH_G GHC.Internal.Base.$fApplicativeIO PUSH_APPLY_PP PUSH_G GHC.Internal.Base.pure ENTER ``` Perhaps we never tried to decode a stack in which a BCO like this was present. However, for the debugger, we want to decode stacks of threads stopped at breakpoints, and these kind of BCOs do get on a stack under e.g. `stg_apply_interp_info` frames. See the accompanying test in the next commit for an example to trigger the bug this commit fixes. Fixes #26640 - - - - - 9e337061 by Rodrigo Mesquita at 2025-12-06T17:47:56-05:00 Add test for #26640 - - - - - 35 changed files: - .gitlab-ci.yml - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - docs/users_guide/conf.py - hadrian/src/Builder.hs - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/xhtml - rts/linker/LoadArchive.c - + testsuite/tests/bytecode/T26640.hs - + testsuite/tests/bytecode/T26640.script - + testsuite/tests/bytecode/T26640.stdout - testsuite/tests/bytecode/all.T - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4d1f182befe0807f3a012c0584d6e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4d1f182befe0807f3a012c0584d6e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/no-binary-char-2
by Cheng Shao (＠TerrorJack) 07 Dec '25

07 Dec '25

Cheng Shao pushed new branch wip/no-binary-char-2 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/no-binary-char-2 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-ci-clean] 6 commits: NCG/LA64: Simplify genCCall into two parts
by Cheng Shao (＠TerrorJack) 07 Dec '25

07 Dec '25

Cheng Shao pushed to branch wip/fix-ci-clean at Glasgow Haskell Compiler / GHC Commits: d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00 NCG/LA64: Simplify genCCall into two parts genCCall is too long, so it's been simplified into two parts: genPrim and genLibCCall. Suggested by Andreas Klebinger - - - - - 9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00 hadrian: Use a response file to invoke GHC for dep gathering. In some cases we construct an argument list too long for GHC to handle directly on windows. This happens when we generate the dependency file because the command line will contain references to a large number of .hs files. To avoid this we now invoke GHC using a response file when generating dependencies to sidestep length limitations. Note that we only pass the actual file names in the dependency file. Why? Because this side-steps #26560 - - - - - 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. - - - - - 0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00 users' guide: don't use f strings in the python script to ensure compatibility with python 3.5 - - - - - 72eab1d5 by Cheng Shao at 2025-12-06T19:44:01+01:00 ci: fix "ci.sh clean" to address frequent out of space error on windows runners This patch fixes the `ci.sh clean` logic to address frequent out of space error on windows runners; previously it didn't clean up the inplace mingw blobs, which is the largest source of space leak on windows runners. See added comment for detailed explanation. - - - - - 30 changed files: - .gitlab/ci.sh - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - docs/users_guide/conf.py - hadrian/src/Builder.hs - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - libraries/xhtml - rts/linker/LoadArchive.c - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html Changes: ===================================== .gitlab/ci.sh ===================================== @@ -275,7 +275,7 @@ function setup() { function fetch_ghc() { local should_fetch=false - + if [ ! -e "$GHC" ]; then if [ -z "${FETCH_GHC_VERSION:-}" ]; then fail "GHC not found at '$GHC' and FETCH_GHC_VERSION is not set" @@ -292,7 +292,7 @@ function fetch_ghc() { fi fi fi - + if [ "$should_fetch" = true ]; then local v="$FETCH_GHC_VERSION" @@ -887,8 +887,24 @@ function save_cache () { } function clean() { - rm -R tmp - run rm -Rf _build + # When CI_DISPOSABLE_ENVIRONMENT is not true (e.g. using shell + # executor on windows/macos), the project directory is not removed + # by gitlab runner automatically after each job. To mitigate the + # space leak, other than periodic cleaning on the runner host, we + # also must aggressively cleanup build products, otherwise we run + # into out of space errors too frequently. + # + # When CI_DISPOSABLE_ENVIRONMENT is true (using docker executor on + # linux), the runner will do proper cleanup, so no need to do + # anything here. + if [[ "${CI_DISPOSABLE_ENVIRONMENT:-}" != true ]]; then + git submodule foreach --recursive git clean -xdf + git clean -xdf \ + --exclude=ci_timings.txt \ + --exclude=ghc-*.tar.xz \ + --exclude=junit.xml \ + --exclude=unexpected-test-output.tar.gz + fi } function run_hadrian() { ===================================== compiler/GHC/CmmToAsm/LA64/CodeGen.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} module GHC.CmmToAsm.LA64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr @@ -268,8 +269,10 @@ stmtToInstrs stmt = do config <- getConfig platform <- getPlatform case stmt of - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + CmmUnsafeForeignCall target result_regs args -> + case target of + PrimTarget primOp -> genPrim primOp result_regs args + ForeignTarget addr conv -> genCCall addr conv result_regs args CmmComment s -> return (unitOL (COMMENT (ftext s))) CmmTick {} -> return nilOL @@ -1631,6 +1634,319 @@ genCondBranch true false expr = do b2 <- genBranch false return (b1 `appOL` b2) +genPrim + :: CallishMachOp -- MachOp + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +genPrim MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src +genPrim MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src +genPrim MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src +genPrim MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src +genPrim (MO_Clz width) [dst] [src] = genClz width dst src +genPrim (MO_Ctz width) [dst] [src] = genCtz width dst src +genPrim (MO_BSwap width) [dst] [src] = genByteSwap width dst src +genPrim (MO_BRev width) [dst] [src] = genBitRev width dst src +genPrim MO_AcquireFence [] [] = return $ unitOL (DBAR HintAcquire) +genPrim MO_ReleaseFence [] [] = return $ unitOL (DBAR HintRelease) +genPrim MO_SeqCstFence [] [] = return $ unitOL (DBAR HintSeqcst) +genPrim MO_Touch [] [_] = return nilOL +genPrim (MO_Prefetch_Data _n) [] [_] = return nilOL +genPrim (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr +genPrim (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val + +genPrim mop@(MO_S_Mul2 _w) _ _ = unsupported mop +genPrim mop@(MO_S_QuotRem _w) _ _ = unsupported mop +genPrim mop@(MO_U_QuotRem _w) _ _ = unsupported mop +genPrim mop@(MO_U_QuotRem2 _w) _ _ = unsupported mop +genPrim mop@(MO_Add2 _w) _ _ = unsupported mop +genPrim mop@(MO_AddWordC _w) _ _ = unsupported mop +genPrim mop@(MO_SubWordC _w) _ _ = unsupported mop +genPrim mop@(MO_AddIntC _w) _ _ = unsupported mop +genPrim mop@(MO_SubIntC _w) _ _ = unsupported mop +genPrim mop@(MO_U_Mul2 _w) _ _ = unsupported mop +genPrim mop@MO_I64X2_Min _ _ = unsupported mop +genPrim mop@MO_I64X2_Max _ _ = unsupported mop +genPrim mop@MO_W64X2_Min _ _ = unsupported mop +genPrim mop@MO_W64X2_Max _ _ = unsupported mop +genPrim mop@MO_VS_Quot {} _ _ = unsupported mop +genPrim mop@MO_VS_Rem {} _ _ = unsupported mop +genPrim mop@MO_VU_Quot {} _ _ = unsupported mop +genPrim mop@MO_VU_Rem {} _ _ = unsupported mop + +genPrim (MO_PopCnt width) [dst] [src] = genLibCCall (popCntLabel width) [dst] [src] +genPrim (MO_Pdep width) [dst] [src,mask] = genLibCCall (pdepLabel width) [dst] [src,mask] +genPrim (MO_Pext width) [dst] [src,mask] = genLibCCall (pextLabel width) [dst] [src,mask] +genPrim (MO_UF_Conv width) [dst] [src] = genLibCCall (word2FloatLabel width) [dst] [src] +genPrim (MO_AtomicRMW width amop) [dst] [addr,n] = genLibCCall (atomicRMWLabel width amop) [dst] [addr,n] +genPrim (MO_Cmpxchg width) [dst] [addr,old,new] = genLibCCall (cmpxchgLabel width) [dst] [addr,old,new] +genPrim (MO_Xchg width) [dst] [addr,val] = genLibCCall (xchgLabel width) [dst] [addr,val] +genPrim (MO_Memcpy _align) [] [dst,src,n] = genLibCCall (fsLit "memcpy") [] [dst,src,n] +genPrim (MO_Memmove _align) [] [dst,src,n] = genLibCCall (fsLit "memmove") [] [dst,src,n] +genPrim (MO_Memcmp _align) [rst] [dst,src,n] = genLibCCall (fsLit "memcmp") [rst] [dst,src,n] +genPrim (MO_Memset _align) [] [dst,cnt,n] = genLibCCall (fsLit "memset") [] [dst,cnt,n] +genPrim MO_F32_Sin [dst] [src] = genLibCCall (fsLit "sinf") [dst] [src] +genPrim MO_F32_Cos [dst] [src] = genLibCCall (fsLit "cosf") [dst] [src] +genPrim MO_F32_Tan [dst] [src] = genLibCCall (fsLit "tanf") [dst] [src] +genPrim MO_F32_Exp [dst] [src] = genLibCCall (fsLit "expf") [dst] [src] +genPrim MO_F32_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1f") [dst] [src] +genPrim MO_F32_Log [dst] [src] = genLibCCall (fsLit "logf") [dst] [src] +genPrim MO_F32_Log1P [dst] [src] = genLibCCall (fsLit "log1pf") [dst] [src] +genPrim MO_F32_Asin [dst] [src] = genLibCCall (fsLit "asinf") [dst] [src] +genPrim MO_F32_Acos [dst] [src] = genLibCCall (fsLit "acosf") [dst] [src] +genPrim MO_F32_Atan [dst] [src] = genLibCCall (fsLit "atanf") [dst] [src] +genPrim MO_F32_Sinh [dst] [src] = genLibCCall (fsLit "sinhf") [dst] [src] +genPrim MO_F32_Cosh [dst] [src] = genLibCCall (fsLit "coshf") [dst] [src] +genPrim MO_F32_Tanh [dst] [src] = genLibCCall (fsLit "tanhf") [dst] [src] +genPrim MO_F32_Pwr [dst] [x,y] = genLibCCall (fsLit "powf") [dst] [x,y] +genPrim MO_F32_Asinh [dst] [src] = genLibCCall (fsLit "asinhf") [dst] [src] +genPrim MO_F32_Acosh [dst] [src] = genLibCCall (fsLit "acoshf") [dst] [src] +genPrim MO_F32_Atanh [dst] [src] = genLibCCall (fsLit "atanhf") [dst] [src] +genPrim MO_F64_Sin [dst] [src] = genLibCCall (fsLit "sin") [dst] [src] +genPrim MO_F64_Cos [dst] [src] = genLibCCall (fsLit "cos") [dst] [src] +genPrim MO_F64_Tan [dst] [src] = genLibCCall (fsLit "tan") [dst] [src] +genPrim MO_F64_Exp [dst] [src] = genLibCCall (fsLit "exp") [dst] [src] +genPrim MO_F64_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1") [dst] [src] +genPrim MO_F64_Log [dst] [src] = genLibCCall (fsLit "log") [dst] [src] +genPrim MO_F64_Log1P [dst] [src] = genLibCCall (fsLit "log1p") [dst] [src] +genPrim MO_F64_Asin [dst] [src] = genLibCCall (fsLit "asin") [dst] [src] +genPrim MO_F64_Acos [dst] [src] = genLibCCall (fsLit "acos") [dst] [src] +genPrim MO_F64_Atan [dst] [src] = genLibCCall (fsLit "atan") [dst] [src] +genPrim MO_F64_Sinh [dst] [src] = genLibCCall (fsLit "sinh") [dst] [src] +genPrim MO_F64_Cosh [dst] [src] = genLibCCall (fsLit "cosh") [dst] [src] +genPrim MO_F64_Tanh [dst] [src] = genLibCCall (fsLit "tanh") [dst] [src] +genPrim MO_F64_Pwr [dst] [x,y] = genLibCCall (fsLit "pow") [dst] [x,y] +genPrim MO_F64_Asinh [dst] [src] = genLibCCall (fsLit "asinh") [dst] [src] +genPrim MO_F64_Acosh [dst] [src] = genLibCCall (fsLit "acosh") [dst] [src] +genPrim MO_F64_Atanh [dst] [src] = genLibCCall (fsLit "atanh") [dst] [src] +genPrim MO_SuspendThread [tok] [rs,i] = genLibCCall (fsLit "suspendThread") [tok] [rs,i] +genPrim MO_ResumeThread [rs] [tok] = genLibCCall (fsLit "resumeThread") [rs] [tok] +genPrim MO_I64_ToI [dst] [src] = genLibCCall (fsLit "hs_int64ToInt") [dst] [src] +genPrim MO_I64_FromI [dst] [src] = genLibCCall (fsLit "hs_intToInt64") [dst] [src] +genPrim MO_W64_ToW [dst] [src] = genLibCCall (fsLit "hs_word64ToWord") [dst] [src] +genPrim MO_W64_FromW [dst] [src] = genLibCCall (fsLit "hs_wordToWord64") [dst] [src] +genPrim MO_x64_Neg [dst] [src] = genLibCCall (fsLit "hs_neg64") [dst] [src] +genPrim MO_x64_Add [dst] [src] = genLibCCall (fsLit "hs_add64") [dst] [src] +genPrim MO_x64_Sub [dst] [src] = genLibCCall (fsLit "hs_sub64") [dst] [src] +genPrim MO_x64_Mul [dst] [src] = genLibCCall (fsLit "hs_mul64") [dst] [src] +genPrim MO_I64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotInt64") [dst] [src] +genPrim MO_I64_Rem [dst] [src] = genLibCCall (fsLit "hs_remInt64") [dst] [src] +genPrim MO_W64_Quot [dst] [src] = genLibCCall (fsLit "hs_quotWord64") [dst] [src] +genPrim MO_W64_Rem [dst] [src] = genLibCCall (fsLit "hs_remWord64") [dst] [src] +genPrim MO_x64_And [dst] [src] = genLibCCall (fsLit "hs_and64") [dst] [src] +genPrim MO_x64_Or [dst] [src] = genLibCCall (fsLit "hs_or64") [dst] [src] +genPrim MO_x64_Xor [dst] [src] = genLibCCall (fsLit "hs_xor64") [dst] [src] +genPrim MO_x64_Not [dst] [src] = genLibCCall (fsLit "hs_not64") [dst] [src] +genPrim MO_x64_Shl [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftL64") [dst] [src] +genPrim MO_I64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedIShiftRA64") [dst] [src] +genPrim MO_W64_Shr [dst] [src] = genLibCCall (fsLit "hs_uncheckedShiftRL64") [dst] [src] +genPrim MO_x64_Eq [dst] [src] = genLibCCall (fsLit "hs_eq64") [dst] [src] +genPrim MO_x64_Ne [dst] [src] = genLibCCall (fsLit "hs_ne64") [dst] [src] +genPrim MO_I64_Ge [dst] [src] = genLibCCall (fsLit "hs_geInt64") [dst] [src] +genPrim MO_I64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtInt64") [dst] [src] +genPrim MO_I64_Le [dst] [src] = genLibCCall (fsLit "hs_leInt64") [dst] [src] +genPrim MO_I64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltInt64") [dst] [src] +genPrim MO_W64_Ge [dst] [src] = genLibCCall (fsLit "hs_geWord64") [dst] [src] +genPrim MO_W64_Gt [dst] [src] = genLibCCall (fsLit "hs_gtWord64") [dst] [src] +genPrim MO_W64_Le [dst] [src] = genLibCCall (fsLit "hs_leWord64") [dst] [src] +genPrim MO_W64_Lt [dst] [src] = genLibCCall (fsLit "hs_ltWord64") [dst] [src] +genPrim op dst args = do + platform <- ncgPlatform <$> getConfig + pprPanic "genPrim: unknown primOp" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args)) + + +genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genFloatAbs w dst src = do + platform <- getPlatform + (reg_fx, _, code_fx) <- getFloatReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return (code_fx `appOL` toOL + [ + FABS (OpReg w dst_reg) (OpReg w reg_fx) + ] + ) + +genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock +genFloatSqrt f dst src = do + platform <- getPlatform + (reg_fx, _, code_fx) <- getFloatReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return (code_fx `appOL` toOL + [ + FSQRT (OpReg w dst_reg) (OpReg w reg_fx) + ] + ) + where + w = case f of + FF32 -> W32 + _ -> W64 + +genClz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genClz w dst src = do + platform <- getPlatform + (reg_x, _, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + if w `elem` [W32, W64] then do + return (code_x `snocOL` CLZ (OpReg w dst_reg) (OpReg w reg_x)) + else if w `elem` [W8, W16] then do + return (code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))), + SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg) + ] + ) + else do + pprPanic "genClz: invalid width: " (ppr w) + where + shift = widthToInt w + +genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genCtz w dst src = do + platform <- getPlatform + (reg_x, _, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + if w `elem` [W32, W64] then do + return (code_x `snocOL` CTZ (OpReg w dst_reg) (OpReg w reg_x)) + else if w `elem` [W8, W16] then do + return (code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)), + BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg) + ] + ) + else do + pprPanic "genCtz: invalid width: " (ppr w) + where + shift = (widthToInt w) + +genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genByteSwap w dst src = do + platform <- getPlatform + (reg_x, _, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + case w of + W64 -> + return (code_x `appOL` toOL + [ + REVBD (OpReg w dst_reg) (OpReg w reg_x) + ] + ) + W32 -> + return (code_x `appOL` toOL + [ + REVB2W (OpReg w dst_reg) (OpReg w reg_x) + ] + ) + W16 -> + return (code_x `appOL` toOL + [ + REVB2H (OpReg w dst_reg) (OpReg w reg_x) + ] + ) + _ -> pprPanic "genBSwap: invalid width: " (ppr w) + +genBitRev :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genBitRev w dst src = do + platform <- getPlatform + (reg_x, _, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + case w of + W8 -> + return (code_x `appOL` toOL + [ + BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x), + AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255)) + ] + ) + W16 -> + return (code_x `appOL` toOL + [ + BITREV (OpReg W64 reg_x) (OpReg W64 reg_x), + SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48)) + ] + ) + _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x)) + +-- Generate C call to the given function in libc +genLibCCall :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock +genLibCCall name dsts args = do + config <- getConfig + target <- + cmmMakeDynamicReference config CallReference + $ mkForeignLabel name ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall target cconv dsts args + +unsupported :: Show a => a -> b +unsupported mop = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + +-- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0. +-- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So, +-- implement with DBAR +genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock +genAtomicRead w mo dst arg = do + (addr_p, _, code_p) <- getSomeReg arg + platform <- getPlatform + let d = getRegisterReg platform (CmmLocal dst) + case mo of + MemOrderRelaxed -> + return (code_p `appOL` toOL + [ + LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p) + ] + ) + + MemOrderAcquire -> + return (code_p `appOL` toOL + [ + LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p), + DBAR HintAcquire + ] + ) + MemOrderSeqCst -> + return (code_p `appOL` toOL + [ + LD (intFormat w) (OpReg w d) (OpAddr $ AddrReg addr_p), + DBAR HintSeqcst + ] + ) + _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo + +genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock +genAtomicWrite w mo addr val = do + (addr_p, _, code_p) <- getSomeReg addr + (val_reg, fmt_val, code_val) <- getSomeReg val + case mo of + MemOrderRelaxed -> + return (code_p `appOL`code_val `appOL` toOL + [ + ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p) + ] + ) + MemOrderRelease -> + return (code_p `appOL`code_val `appOL` toOL + [ + DBAR HintRelease, + ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p) + ] + ) + MemOrderSeqCst -> + return (code_p `appOL`code_val `appOL` toOL + [ + DBAR HintSeqcst, + ST fmt_val (OpReg w val_reg) (OpAddr $ AddrReg addr_p) + ] + ) + _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo + -- ----------------------------------------------------------------------------- {- Generating C calls @@ -1664,393 +1980,68 @@ wider than FRLEN may be passed in a GAR. -} genCCall - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - --- TODO: Specialize where we can. --- Generic impl -genCCall target dest_regs arg_regs = do - case target of - -- The target :: ForeignTarget call can either - -- be a foreign procedure with an address expr - -- and a calling convention. - ForeignTarget expr _cconv -> do - (call_target, call_target_code) <- case expr of - -- if this is a label, let's just directly to it. - (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) - -- if it's not a label, let's compute the expression into a - -- register and jump to that. - _ -> do - (reg, _format, reg_code) <- getSomeReg expr - pure (TReg reg, reg_code) - -- compute the code and register logic for all arg_regs. - -- this will give us the format information to match on. - arg_regs' <- mapM getSomeReg arg_regs - - -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes - -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in - -- STG; this thenn breaks packing of stack arguments, if we need to pack - -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type - -- in Cmm proper. Option two, which we choose here is to use extended Hint - -- information to contain the size information and use that when packing - -- arguments, spilled onto the stack. - let (_res_hints, arg_hints) = foreignTargetHints target - arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints - - (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL - - readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL - - let moveStackDown 0 = toOL [ PUSH_STACK_FRAME - , DELTA (-16) - ] - moveStackDown i | odd i = moveStackDown (i + 1) - moveStackDown i = toOL [ PUSH_STACK_FRAME - , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) - , DELTA (-8 * i - 16) - ] - moveStackUp 0 = toOL [ POP_STACK_FRAME - , DELTA 0 - ] - moveStackUp i | odd i = moveStackUp (i + 1) - moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) - , POP_STACK_FRAME - , DELTA 0 - ] - - let code = - call_target_code -- compute the label (possibly into a register) - `appOL` moveStackDown (stackSpaceWords) - `appOL` passArgumentsCode -- put the arguments into x0, ... - `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return) - `appOL` readResultsCode -- parse the results into registers - `appOL` moveStackUp (stackSpaceWords) - return code - - PrimTarget MO_F32_Fabs - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg - | otherwise -> panic "mal-formed MO_F32_Fabs" - PrimTarget MO_F64_Fabs - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg - | otherwise -> panic "mal-formed MO_F64_Fabs" - - PrimTarget MO_F32_Sqrt - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg - | otherwise -> panic "mal-formed MO_F32_Sqrt" - PrimTarget MO_F64_Sqrt - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg - | otherwise -> panic "mal-formed MO_F64_Sqrt" - - PrimTarget (MO_Clz w) - | w `elem` [W32, W64], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _format_x, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - return ( code_x `snocOL` - CLZ (OpReg w dst_reg) (OpReg w reg_x) - ) - | w `elem` [W8, W16], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _format_x, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - return ( code_x `appOL` toOL - [ - MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), - SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))), - SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))), - OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), - CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg) - ] - ) - | otherwise -> unsupported (MO_Clz w) - where - shift = widthToInt w - - PrimTarget (MO_Ctz w) - | w `elem` [W32, W64], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _format_x, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - return ( code_x `snocOL` - CTZ (OpReg w dst_reg) (OpReg w reg_x) - ) - | w `elem` [W8, W16], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _format_x, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - return ( code_x `appOL` toOL - [ - MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), - SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)), - BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)), - OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), - CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg) - ] - ) - | otherwise -> unsupported (MO_Ctz w) - where - shift = (widthToInt w) + :: CmmExpr -- address of func call + -> ForeignConvention -- calling convention + -> [CmmFormal] -- results + -> [CmmActual] -- arguments + -> NatM InstrBlock + + +genCCall expr _conv@(ForeignConvention _ argHints _resHints _) dest_regs arg_regs = do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- if it's not a label, let's compute the expression into a + -- register and jump to that. + _ -> do + (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let + arg_hints = take (length arg_regs) (argHints ++ repeat NoHint) + arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints + + (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = toOL [ PUSH_STACK_FRAME + , DELTA (-16) + ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = toOL [ PUSH_STACK_FRAME + , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , DELTA (-8 * i - 16) + ] + moveStackUp 0 = toOL [ POP_STACK_FRAME + , DELTA 0 + ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 + ] - PrimTarget (MO_BSwap w) - | w `elem` [W16, W32, W64], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - case w of - W64 -> return ( code_x `appOL` toOL - [ - REVBD (OpReg w dst_reg) (OpReg w reg_x) - ]) - W32 -> return ( code_x `appOL` toOL - [ - REVB2W (OpReg w dst_reg) (OpReg w reg_x) - ]) - _ -> return ( code_x `appOL` toOL - [ - REVB2H (OpReg w dst_reg) (OpReg w reg_x) - ]) - | otherwise -> unsupported (MO_BSwap w) - - PrimTarget (MO_BRev w) - | w `elem` [W8, W16, W32, W64], - [arg_reg] <- arg_regs, - [dest_reg] <- dest_regs -> do - platform <- getPlatform - (reg_x, _, code_x) <- getSomeReg arg_reg - let dst_reg = getRegisterReg platform (CmmLocal dest_reg) - case w of - W8 -> return ( code_x `appOL` toOL - [ - BITREV4B (OpReg W32 reg_x) (OpReg W32 reg_x), - AND (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 255)) - ]) - W16 -> return ( code_x `appOL` toOL - [ - BITREV (OpReg W64 reg_x) (OpReg W64 reg_x), - SRL (OpReg W64 dst_reg) (OpReg W64 reg_x) (OpImm (ImmInt 48)) - ]) - _ -> return ( code_x `snocOL` BITREV (OpReg w dst_reg) (OpReg w reg_x)) - | otherwise -> unsupported (MO_BRev w) - - -- mop :: CallishMachOp (see GHC.Cmm.MachOp) - PrimTarget mop -> do - -- We'll need config to construct forien targets - case mop of - -- 64 bit float ops - MO_F64_Pwr -> mkCCall "pow" - - MO_F64_Sin -> mkCCall "sin" - MO_F64_Cos -> mkCCall "cos" - MO_F64_Tan -> mkCCall "tan" - - MO_F64_Sinh -> mkCCall "sinh" - MO_F64_Cosh -> mkCCall "cosh" - MO_F64_Tanh -> mkCCall "tanh" - - MO_F64_Asin -> mkCCall "asin" - MO_F64_Acos -> mkCCall "acos" - MO_F64_Atan -> mkCCall "atan" - - MO_F64_Asinh -> mkCCall "asinh" - MO_F64_Acosh -> mkCCall "acosh" - MO_F64_Atanh -> mkCCall "atanh" - - MO_F64_Log -> mkCCall "log" - MO_F64_Log1P -> mkCCall "log1p" - MO_F64_Exp -> mkCCall "exp" - MO_F64_ExpM1 -> mkCCall "expm1" - - -- 32 bit float ops - MO_F32_Pwr -> mkCCall "powf" - - MO_F32_Sin -> mkCCall "sinf" - MO_F32_Cos -> mkCCall "cosf" - MO_F32_Tan -> mkCCall "tanf" - MO_F32_Sinh -> mkCCall "sinhf" - MO_F32_Cosh -> mkCCall "coshf" - MO_F32_Tanh -> mkCCall "tanhf" - MO_F32_Asin -> mkCCall "asinf" - MO_F32_Acos -> mkCCall "acosf" - MO_F32_Atan -> mkCCall "atanf" - MO_F32_Asinh -> mkCCall "asinhf" - MO_F32_Acosh -> mkCCall "acoshf" - MO_F32_Atanh -> mkCCall "atanhf" - MO_F32_Log -> mkCCall "logf" - MO_F32_Log1P -> mkCCall "log1pf" - MO_F32_Exp -> mkCCall "expf" - MO_F32_ExpM1 -> mkCCall "expm1f" - - -- 64-bit primops - MO_I64_ToI -> mkCCall "hs_int64ToInt" - MO_I64_FromI -> mkCCall "hs_intToInt64" - MO_W64_ToW -> mkCCall "hs_word64ToWord" - MO_W64_FromW -> mkCCall "hs_wordToWord64" - MO_x64_Neg -> mkCCall "hs_neg64" - MO_x64_Add -> mkCCall "hs_add64" - MO_x64_Sub -> mkCCall "hs_sub64" - MO_x64_Mul -> mkCCall "hs_mul64" - MO_I64_Quot -> mkCCall "hs_quotInt64" - MO_I64_Rem -> mkCCall "hs_remInt64" - MO_W64_Quot -> mkCCall "hs_quotWord64" - MO_W64_Rem -> mkCCall "hs_remWord64" - MO_x64_And -> mkCCall "hs_and64" - MO_x64_Or -> mkCCall "hs_or64" - MO_x64_Xor -> mkCCall "hs_xor64" - MO_x64_Not -> mkCCall "hs_not64" - MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" - MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" - MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" - MO_x64_Eq -> mkCCall "hs_eq64" - MO_x64_Ne -> mkCCall "hs_ne64" - MO_I64_Ge -> mkCCall "hs_geInt64" - MO_I64_Gt -> mkCCall "hs_gtInt64" - MO_I64_Le -> mkCCall "hs_leInt64" - MO_I64_Lt -> mkCCall "hs_ltInt64" - MO_W64_Ge -> mkCCall "hs_geWord64" - MO_W64_Gt -> mkCCall "hs_gtWord64" - MO_W64_Le -> mkCCall "hs_leWord64" - MO_W64_Lt -> mkCCall "hs_ltWord64" - - -- Conversion - MO_UF_Conv w -> mkCCall (word2FloatLabel w) - - -- Optional MachOps - -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config - MO_S_Mul2 _w -> unsupported mop - MO_S_QuotRem _w -> unsupported mop - MO_U_QuotRem _w -> unsupported mop - MO_U_QuotRem2 _w -> unsupported mop - MO_Add2 _w -> unsupported mop - MO_AddWordC _w -> unsupported mop - MO_SubWordC _w -> unsupported mop - MO_AddIntC _w -> unsupported mop - MO_SubIntC _w -> unsupported mop - MO_U_Mul2 _w -> unsupported mop - - MO_VS_Quot {} -> unsupported mop - MO_VS_Rem {} -> unsupported mop - MO_VU_Quot {} -> unsupported mop - MO_VU_Rem {} -> unsupported mop - MO_I64X2_Min -> unsupported mop - MO_I64X2_Max -> unsupported mop - MO_W64X2_Min -> unsupported mop - MO_W64X2_Max -> unsupported mop - - -- Memory Ordering - -- Support finer-grained DBAR hints for LA664 and newer uarchs. - -- These are treated as DBAR 0 on older uarchs, so we can start - -- to unconditionally emit the new hints right away. - MO_AcquireFence -> pure (unitOL (DBAR HintAcquire)) - MO_ReleaseFence -> pure (unitOL (DBAR HintRelease)) - MO_SeqCstFence -> pure (unitOL (DBAR HintSeqcst)) - - MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers) - -- Prefetch - MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint. - - -- Memory copy/set/move/cmp, with alignment for optimization - - -- TODO Optimize and use e.g. quad registers to move memory around instead - -- of offloading this to memcpy. For small memcpys we can utilize - -- the 128bit quad registers in NEON to move block of bytes around. - -- Might also make sense of small memsets? Use xzr? What's the function - -- call overhead? - MO_Memcpy _align -> mkCCall "memcpy" - MO_Memset _align -> mkCCall "memset" - MO_Memmove _align -> mkCCall "memmove" - MO_Memcmp _align -> mkCCall "memcmp" - - MO_SuspendThread -> mkCCall "suspendThread" - MO_ResumeThread -> mkCCall "resumeThread" - - MO_PopCnt w -> mkCCall (popCntLabel w) - MO_Pdep w -> mkCCall (pdepLabel w) - MO_Pext w -> mkCCall (pextLabel w) - - -- or a possibly side-effecting machine operation - mo@(MO_AtomicRead w ord) - | [p_reg] <- arg_regs - , [dst_reg] <- dest_regs -> do - (p, _fmt_p, code_p) <- getSomeReg p_reg - platform <- getPlatform - let instrs = case ord of - MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)) - - MemOrderAcquire -> toOL [ - ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)), - DBAR HintAcquire - ] - MemOrderSeqCst -> toOL [ - ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)), - DBAR HintSeqcst - ] - _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo - dst = getRegisterReg platform (CmmLocal dst_reg) - moDescr = (text . show) mo - code = code_p `appOL` instrs - pure code - | otherwise -> panic "mal-formed AtomicRead" - - mo@(MO_AtomicWrite w ord) - | [p_reg, val_reg] <- arg_regs -> do - (p, _fmt_p, code_p) <- getSomeReg p_reg - (val, fmt_val, code_val) <- getSomeReg val_reg - let instrs = case ord of - MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)) - -- AMSWAP_DB* insns implentment a fully functional synchronization barrier, like DBAR 0x0. - -- This is terrible. And AMSWAPDB only supports ISA version greater than LA64V1_0. So, - -- implement with DBAR - MemOrderRelease -> toOL [ - ann moDescr (DBAR HintRelease), - ST fmt_val (OpReg w val) (OpAddr $ AddrReg p) - ] - MemOrderSeqCst -> toOL [ - ann moDescr (DBAR HintSeqcst), - ST fmt_val (OpReg w val) (OpAddr $ AddrReg p) - ] - _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo - moDescr = (text . show) mo - code = - code_p `appOL` - code_val `appOL` - instrs - pure code - | otherwise -> panic "mal-formed AtomicWrite" - - MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) - MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) - MO_Xchg w -> mkCCall (xchgLabel w) + let code = + call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown (stackSpaceWords) + `appOL` passArgumentsCode -- put the arguments into x0, ... + `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return) + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpaceWords) + return code where - unsupported :: Show a => a -> b - unsupported mop = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - - mkCCall :: FastString -> NatM InstrBlock - mkCCall name = do - config <- getConfig - target <- - cmmMakeDynamicReference config CallReference - $ mkForeignLabel name ForeignLabelInThisPackage IsFunction - let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn - genCCall (ForeignTarget target cconv) dest_regs arg_regs - -- Implementiation of the LoongArch ABI calling convention. -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-ar… passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) @@ -2129,10 +2120,10 @@ genCCall target dest_regs arg_regs = do readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do platform <- getPlatform - pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform expr) readResults _ [] _ _ _ = do platform <- getPlatform - pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform expr) readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do -- gp/fp reg -> dst platform <- getPlatform @@ -2150,13 +2141,6 @@ genCCall target dest_regs arg_regs = do -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations truncateReg W64 w r_dst - unaryFloatOp w op arg_reg dest_reg = do - platform <- getPlatform - (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg - let dst = getRegisterReg platform (CmmLocal dest_reg) - let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx) - pure code - data BlockInRange = InRange | NotInRange BlockId genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock ===================================== docs/users_guide/conf.py ===================================== @@ -45,7 +45,7 @@ rst_prolog = """ # General information about the project. project = u'Glasgow Haskell Compiler' -copyright = f"{datetime.now(timezone.utc).year}, GHC Team" +copyright = "{}, GHC Team".format(datetime.now(timezone.utc).year) # N.B. version comes from ghc_config release = version # The full version, including alpha/beta/rc tags. ===================================== hadrian/src/Builder.hs ===================================== @@ -361,6 +361,12 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs + Ghc FindHsDependencies _ -> do + -- Use a response file for ghc -M invocations, to + -- avoid issues with command line size limit on + -- Windows (#26637) + runGhcWithResponse path buildArgs buildInputs + HsCpp -> captureStdout Make dir -> cmd' buildOptions path ["-C", dir] buildArgs @@ -403,6 +409,17 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) +runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () +runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do + + writeFile' tmp $ escapeArgs fileInputs + + -- We can't put the flags in a response file, because some flags + -- require empty arguments (such as the -dep-suffix flag), but + -- that isn't supported yet due to #26560. + cmd [ghcPath] flagArgs ('@' : tmp) + + -- TODO: Some builders are required only on certain platforms. For example, -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform -- specific optional builders as soon as we can reliably test this feature. ===================================== hadrian/src/Rules/ToolArgs.hs ===================================== @@ -172,6 +172,7 @@ toolTargets = [ cabalSyntax , time , semaphoreCompat , unlit -- # executable + , xhtml ] ++ if windowsHost then [ win32 ] else [ unix ] -- | Create a mapping from files to which component it belongs to. ===================================== hadrian/src/Settings/Builders/Ghc.hs ===================================== @@ -182,7 +182,7 @@ findHsDependencies = builder (Ghc FindHsDependencies) ? do , arg "-include-pkg-deps" , arg "-dep-makefile", arg =<< getOutput , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- Set.toList ways ] - , getInputs ] + ] haddockGhcArgs :: Args haddockGhcArgs = mconcat [ commonGhcArgs ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -109,6 +109,7 @@ stage0Packages = do , thLift -- new library not yet present for boot compilers , thQuasiquoter -- new library not yet present for boot compilers , unlit + , xhtml -- new version is not backwards compat with latest , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version -- bundled with GHC 9.6 is too old for `semaphore-compat`. ===================================== libraries/xhtml ===================================== @@ -1 +1 @@ -Subproject commit 68353ccd1a2e776d6c2b11619265d8140bb7dc07 +Subproject commit cc203b9cc0a60c53a3bcbf2f38eb72cb7cf6098d ===================================== rts/linker/LoadArchive.c ===================================== @@ -592,6 +592,9 @@ HsInt loadArchive_ (pathchar *path) if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } + // Unlike for regular archives for thin archives we can only identify the object format + // after having read the file pointed to. + object_fmt = identifyObjectFile_(image, memberSize); } else { ===================================== utils/haddock/cabal.project ===================================== @@ -12,4 +12,4 @@ package haddock-api tests: False -- Pinning the index-state helps to make reasonably CI deterministic -index-state: 2024-06-18T11:54:44Z +index-state: 2025-11-17T03:30:46Z ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -51,6 +51,7 @@ common extensions StrictData TypeApplications TypeOperators + OverloadedStrings default-language: Haskell2010 @@ -81,7 +82,7 @@ library build-depends: base >= 4.16 && < 4.23 , ghc ^>= 9.15 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , parsec ^>= 3.1.13.0 -- Versions for the dependencies below are transitively pinned by @@ -97,6 +98,7 @@ library , ghc-boot , mtl , transformers + , text hs-source-dirs: src @@ -212,7 +214,7 @@ test-suite spec build-depends: ghc ^>= 9.7 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , hspec ^>= 2.9 , parsec ^>= 3.1.13.0 , QuickCheck >= 2.11 && ^>= 2.14 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -134,7 +134,7 @@ out :: Outputable a => SDocContext -> a -> String out sDocContext = outWith $ Outputable.renderWithContext sDocContext operator :: String -> String -operator (x : xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x : xs ++ ")" +operator (x : xs) | not (isAlphaNum x) && x `notElem` ("_' ([{" :: String) = '(' : x : xs ++ ")" operator x = x commaSeparate :: Outputable a => SDocContext -> [a] -> String ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -28,10 +28,11 @@ import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Utils (renderToString) +import Haddock.Backends.Xhtml.Utils (renderToBuilder) import Haddock.InterfaceFile import Haddock.Types -import Haddock.Utils (Verbosity, out, verbose, writeUtf8File) +import Haddock.Utils (Verbosity, out, verbose) +import qualified Data.ByteString.Builder as Builder -- | Generate hyperlinked source for given interfaces. -- @@ -117,7 +118,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens + Builder.writeFile path . renderToBuilder pretty . render' thisModule fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -24,7 +24,9 @@ import qualified Text.XHtml as Html import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -type StyleClass = String +import qualified Data.Text.Lazy as LText + +type StyleClass = LText.Text -- | Produce the HTML corresponding to a hyperlinked Haskell source render @@ -50,7 +52,7 @@ body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml -header mcss mjs = Html.header $ css mcss <> js mjs +header mcss mjs = Html.header $ css (LText.pack <$> mcss) <> js (LText.pack <$> mjs) where css Nothing = Html.noHtml css (Just cssFile) = @@ -225,7 +227,7 @@ tokenStyle TkPragma = ["hs-pragma"] tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . unwords +multiclass = Html.theclass . LText.unwords externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html externalAnchor (Right name) contexts content @@ -250,11 +252,11 @@ internalAnchor (Right name) contexts content Html.thespan content ! [Html.identifier $ internalAnchorIdent name] internalAnchor _ _ content = content -externalAnchorIdent :: Name -> String -externalAnchorIdent = hypSrcNameUrl +externalAnchorIdent :: Name -> LText.Text +externalAnchorIdent name = LText.pack (hypSrcNameUrl name) -internalAnchorIdent :: Name -> String -internalAnchorIdent = ("l-" ++) . showUnique . nameUnique +internalAnchorIdent :: Name -> LText.Text +internalAnchorIdent = LText.pack . ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html @@ -269,16 +271,16 @@ hyperlink thisModule (srcs, srcs') ident = case ident of makeHyperlinkUrl url = ".." </> url internalHyperlink name content = - Html.anchor content ! [Html.href $ "#" ++ internalAnchorIdent name] + Html.anchor content ! [Html.href $ "#" <> internalAnchorIdent name] externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] + ! [Html.href $ LText.pack (hypSrcModuleNameUrl' thisModule mdl name)] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] Nothing -> content where mdl = nameModule name @@ -287,11 +289,11 @@ hyperlink thisModule (srcs, srcs') ident = case ident of case Map.lookup moduleName srcs' of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleUrl' moduleName] + ! [Html.href $ LText.pack $ hypSrcModuleUrl' moduleName] Just (SrcExternal path) -> let hyperlinkUrl = makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] Nothing -> content renderSpace :: Int -> String -> Html @@ -307,4 +309,4 @@ renderSpace line space = in Html.toHtml hspace <> renderSpace line rest lineAnchor :: Int -> Html -lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ hypSrcLineUrl line] +lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ LText.pack $ hypSrcLineUrl line] ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -51,6 +51,10 @@ import qualified System.IO as IO import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml import Prelude hiding (div) +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy as LBS import Haddock.Backends.Xhtml.Decl import Haddock.Backends.Xhtml.DocMarkup @@ -221,7 +225,7 @@ copyHtmlBits odir libdir themes withQuickjump = do headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html headHtml docTitle themes mathjax_url base_url = header - ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) base_url) + ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) (LText.pack <$> base_url)) << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle @@ -229,18 +233,18 @@ headHtml docTitle themes mathjax_url base_url = , thelink ! [ rel "stylesheet" , thetype "text/css" - , href (withBaseURL base_url quickJumpCssFile) + , href (LText.pack $ withBaseURL base_url quickJumpCssFile) ] << noHtml , thelink ! [rel "stylesheet", thetype "text/css", href fontUrl] << noHtml , script - ! [ src (withBaseURL base_url haddockJsFile) + ! [ src (LText.pack $ withBaseURL base_url haddockJsFile) , emptyAttr "async" , thetype "text/javascript" ] << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf - , script ! [src mjUrl, thetype "text/javascript"] << noHtml + , script ! [src (LText.pack mjUrl), thetype "text/javascript"] << noHtml ] where fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" @@ -257,31 +261,31 @@ headHtml docTitle themes mathjax_url base_url = srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = - Just (anchor ! [href src_base_url] << "Source") + Just (anchor ! [href (LText.pack src_base_url)] << ("Source" :: LText)) srcButton (_, Just src_module_url, _, _) (Just iface) = let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url - in Just (anchor ! [href url] << "Source") + in Just (anchor ! [href (LText.pack url)] << ("Source" :: LText)) srcButton _ _ = Nothing wikiButton :: WikiURLs -> Maybe Module -> Maybe Html wikiButton (Just wiki_base_url, _, _) Nothing = - Just (anchor ! [href wiki_base_url] << "User Comments") + Just (anchor ! [href (LText.pack wiki_base_url)] << ("User Comments" :: LText)) wikiButton (_, Just wiki_module_url, _) (Just mdl) = let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url - in Just (anchor ! [href url] << "User Comments") + in Just (anchor ! [href (LText.pack url)] << ("User Comments" :: LText)) wikiButton _ _ = Nothing contentsButton :: Maybe String -> Maybe Html contentsButton maybe_contents_url = - Just (anchor ! [href url] << "Contents") + Just (anchor ! [href (LText.pack url)] << ("Contents" :: LText)) where url = fromMaybe contentsHtmlFile maybe_contents_url indexButton :: Maybe String -> Maybe Html indexButton maybe_index_url = - Just (anchor ! [href url] << "Index") + Just (anchor ! [href (LText.pack url)] << ("Index" :: LText)) where url = fromMaybe indexHtmlFile maybe_index_url @@ -318,8 +322,8 @@ bodyHtml , divContent << pageContent , divFooter << paragraph - << ( "Produced by " - +++ (anchor ! [href projectUrl] << toHtml projectName) + << ( ("Produced by " :: LText) + +++ (anchor ! [href (LText.pack projectUrl)] << toHtml projectName) +++ (" version " ++ projectVersion) ) ] @@ -368,7 +372,7 @@ moduleInfo iface = xs -> extField $ unordList xs ! [theclass "extension-list"] | otherwise = [] where - extField x = return $ th << "Extensions" <-> td << x + extField x = return $ th << ("Extensions" :: LText) <-> td << x dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x in case entries of @@ -454,7 +458,7 @@ ppHtmlContents , ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, contentsHtmlFile]) (renderToBuilder debug html) where -- Extract a module's short description. toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) @@ -472,11 +476,11 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppSignatureTrees _ _ tss | all (null . snd) tss = mempty ppSignatureTrees pkg qual [(info, ts)] = - divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) + divPackageList << (sectionName << ("Signatures" :: LText) +++ ppSignatureTree pkg qual "n" info ts) ppSignatureTrees pkg qual tss = divModuleList << ( sectionName - << "Signatures" + << ("Signatures" :: LText) +++ concatHtml [ ppSignatureTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -491,11 +495,11 @@ ppSignatureTree pkg qual p info ts = ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppModuleTrees _ _ tss | all (null . snd) tss = mempty ppModuleTrees pkg qual [(info, ts)] = - divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts) + divModuleList << (sectionName << ("Modules" :: LText) +++ ppModuleTree pkg qual "n" info ts) ppModuleTrees pkg qual tss = divPackageList << ( sectionName - << "Packages" + << ("Packages" :: LText) +++ concatHtml [ ppModuleTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -519,11 +523,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_ : _, Nothing) -> collapseControl p "module" + (_ : _, Nothing) -> collapseControl (LText.pack p) "module" (_, _) -> [theclass "module"] cBtn = case (ts, leaf) of - (_ : _, Just _) -> thespan ! collapseControl p "" << spaceHtml + (_ : _, Just _) -> thespan ! collapseControl (LText.pack p) "" << spaceHtml ([], Just _) -> thespan ! [theclass "noexpander"] << spaceHtml (_, _) -> noHtml -- We only need an explicit collapser button when the module name @@ -547,11 +551,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = then noHtml else collapseDetails - p + (LText.pack p) DetailsOpen ( thesummary ! [theclass "hide-when-js-enabled"] - << "Submodules" + << ("Submodules" :: LText) +++ mkNodeList pkg qual (s : ss) p ts ) @@ -650,10 +654,10 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins | Just item_html <- processExport True links_info unicode pkg qual item = Just JsonIndexEntry - { jieHtmlFragment = showHtmlFragment item_html + { jieHtmlFragment = Text.unpack (Text.decodeUtf8Lenient (LBS.toStrict (Builder.toLazyByteString (showHtmlFragment item_html)))) , jieName = unwords (map getOccString names) , jieModule = moduleString mdl - , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + , jieLink = LText.unpack $ fromMaybe "" (listToMaybe (map (nameLink mdl) names)) } | otherwise = Nothing where @@ -668,7 +672,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins exportName ExportNoDecl{expItemName} = [expItemName] exportName _ = [] - nameLink :: NamedThing name => Module -> name -> String + nameLink :: NamedThing name => Module -> name -> LText nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName links_info = (maybe_source_url, maybe_wiki_url) @@ -720,9 +724,9 @@ ppHtmlIndex mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + Builder.writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToBuilder debug mergedhtml) - writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, indexHtmlFile]) (renderToBuilder debug html) where indexPage showLetters ch items = headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing @@ -754,7 +758,7 @@ ppHtmlIndex indexInitialLetterLinks = divAlphabet << unordList - ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + ( map (\str -> anchor ! [href (LText.pack $ subIndexHtmlFile str)] << str) $ [ [c] | c <- initialChars, any (indexStartsWith c) index ] ++ [merged_name] @@ -773,7 +777,7 @@ ppHtmlIndex do_sub_index this_ix c = unless (null index_part) $ - writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + Builder.writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToBuilder debug html) where html = indexPage True (Just c) index_part index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] @@ -844,9 +848,9 @@ ppHtmlIndex <-> indexLinks nm entries ppAnnot n - | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" + | not (isValOcc n) = toHtml ("Type/Class" :: LText) + | isDataOcc n = toHtml ("Data Constructor" :: LText) + | otherwise = toHtml ("Function" :: LText) indexLinks nm entries = td @@ -909,10 +913,10 @@ ppHtmlModule mdl_str_linked | ifaceIsSig iface = mdl_str - +++ " (signature" + +++ (" (signature" :: LText) +++ sup - << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]") - +++ ")" + << (("[" :: LText) +++ anchor ! [href (LText.pack signatureDocURL)] << ("?" :: LText) +++ ("]" :: LText)) + +++ (")" :: LText) | otherwise = toHtml mdl_str real_qual = makeModuleQual qual mdl @@ -930,7 +934,7 @@ ppHtmlModule ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + Builder.writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToBuilder debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" @@ -965,7 +969,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = description | isNoHtml doc = doc - | otherwise = divDescription $ sectionName << "Description" +++ doc + | otherwise = divDescription $ sectionName << ("Description" :: LText) +++ doc where doc = docSection Nothing pkg qual (ifaceRnDoc iface) @@ -978,7 +982,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = "syn" DetailsClosed ( thesummary - << "Synopsis" + << ("Synopsis" :: LText) +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode pkg qual) exports ) @@ -991,7 +995,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = case exports of [] -> noHtml ExportGroup{} : _ -> noHtml - _ -> h1 << "Documentation" + _ -> h1 << ("Documentation" :: LText) bdy = foldr (+++) noHtml $ @@ -1017,7 +1021,7 @@ ppModuleContents pkg qual exports orphan contentsDiv = divTableOfContents << ( divContentsList - << ( (sectionName << "Contents") + << ( (sectionName << ("Contents" :: LText)) ! [strAttr "onclick" "window.scrollTo(0,0)"] +++ unordList (sections ++ orphanSection) ) @@ -1025,7 +1029,7 @@ ppModuleContents pkg qual exports orphan (sections, _leftovers {-should be []-}) = process 0 exports orphanSection - | orphan = [linkedAnchor "section.orphans" << "Orphan instances"] + | orphan = [linkedAnchor "section.orphans" << ("Orphan instances" :: LText)] | otherwise = [] process :: Int -> [ExportItem DocNameI] -> ([Html], [ExportItem DocNameI]) @@ -1035,7 +1039,7 @@ ppModuleContents pkg qual exports orphan | otherwise = (html : secs, rest2) where html = - linkedAnchor (groupId id0) + linkedAnchor (groupId (LText.pack id0)) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest @@ -1103,7 +1107,7 @@ processExport ) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = - nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) + nothingIf summary $ groupHeading lev (LText.pack id0) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ _ qual (ExportNoDecl y subs) = @@ -1113,7 +1117,7 @@ processExport summary _ _ _ qual (ExportNoDecl y subs) = processExport summary _ _ pkg qual (ExportDoc doc) = nothingIf summary $ docSection_ Nothing pkg qual doc processExport summary _ _ _ _ (ExportModule mdl) = - processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + processDeclOneLiner summary $ toHtml ("module" :: LText) <+> ppModule mdl nothingIf :: Bool -> a -> Maybe a nothingIf True _ = Nothing @@ -1132,7 +1136,7 @@ processDeclOneLiner :: Bool -> Html -> Maybe Html processDeclOneLiner True = Just processDeclOneLiner False = Just . divTopDecl . declElem -groupHeading :: Int -> String -> Html -> Html +groupHeading :: Int -> LText -> Html -> Html groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] where grpId = groupId id0 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -45,6 +45,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.Doc (combineDocumentation) import Haddock.GhcUtils import Haddock.Types +import qualified Data.Text.Lazy as LText -- | Pretty print a declaration ppDecl @@ -352,9 +353,9 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," - gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" - gadtOpen = toHtml "{" + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("," :: LText) + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("}" :: LText) + gadtOpen = toHtml ("{" :: LText) ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml @@ -365,7 +366,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge ! [theclass "fixity"] << (toHtml d <+> toHtml (show p) <+> ppNames ns) - ppDir InfixR = "infixr" + ppDir InfixR = ("infixr" :: LText) ppDir InfixL = "infixl" ppDir InfixN = "infix" @@ -730,7 +731,7 @@ ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmp ppContextNoLocsMaybe [] _ _ emptyCtxts = case emptyCtxts of HideEmptyContexts -> Nothing - ShowEmptyToplevelContexts -> Just (toHtml "()") + ShowEmptyToplevelContexts -> Just (toHtml ("()" :: LText)) ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html @@ -1006,13 +1007,13 @@ ppClassDecl == [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml "Nothing" + And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) m : _ -> subMinimal $ ppMinimal False m _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a +++ ", " +++ b) $ map (ppMinimal True . unLoc) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ " | " +++ b) $ map (ppMinimal False . unLoc) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) @@ -1115,7 +1116,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead{..}) md pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual DataInst {} -> error "ppInstHead" where - mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl + mname = maybe noHtml (\m -> toHtml ("Defined in" :: LText) <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual @@ -1163,9 +1164,9 @@ ppInstanceSigs links splice unicode qual sigs = do lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> LText instanceId origin no orphan ihd = - concat $ + LText.pack $ concat $ ["o:" | orphan] ++ [ qual origin , ":" ++ getOccString origin @@ -1529,7 +1530,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode - +++ toHtml " " + +++ toHtml (" " :: LText) -- | Pretty-print a record field ppSideBySideField @@ -1564,7 +1565,7 @@ ppSideBySideField subdocs unicode qual (HsConDeclRecField _ names ltype) = ppRecFieldMultAnn :: Unicode -> Qualification -> HsConDeclField DocNameI -> Html ppRecFieldMultAnn unicode qual (CDF { cdf_multiplicity = ann }) = case ann of HsUnannotated _ -> noHtml - HsLinearAnn _ -> toHtml "%1" + HsLinearAnn _ -> toHtml ("%1" :: LText) HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts ppShortField :: Bool -> Unicode -> Qualification -> HsConDeclRecField DocNameI -> Html @@ -1668,8 +1669,8 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- ppBang :: HsSrcBang -> Html -ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" -ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml ("!" :: LText) +ppBang (HsSrcBang _ _ SrcLazy) = toHtml ("~" :: LText) ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -1707,7 +1708,7 @@ ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) un ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg _ ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign <> ppLParendType unicode qual emptyCtxts ki -ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ("" :: LText) class RenderableBndrFlag flag where ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html @@ -1814,12 +1815,12 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ - | getOccString (getName name) == "(->)" = toHtml "(→)" + | getOccString (getName name) == "(->)" = toHtml ("(→)" :: LText) ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | isPromoted prom = promoQuote (ppDocName q Prefix True name) | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = - toHtml (if u || isUni then "★" else "*") + toHtml (if u || isUni then "★" else "*" :: LText) ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts @@ -1842,7 +1843,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v ppr_mono_ty (XHsType (HsBangTy b ty)) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}" +ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml ("{..}" :: LText) -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs ===================================== @@ -39,6 +39,7 @@ import Haddock.Doc ) import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText parHtmlMarkup :: Qualification @@ -60,7 +61,7 @@ parHtmlMarkup qual insertAnchors ppId = mdl' = case reverse mdl of '\\' : _ -> init mdl _ -> mdl - in ppModuleRef lbl (mkModuleName mdl') ref + in ppModuleRef lbl (mkModuleName mdl') (LText.pack ref) , markupWarning = thediv ! [theclass "warning"] , markupEmphasis = emphasize , markupBold = strong @@ -73,14 +74,14 @@ parHtmlMarkup qual insertAnchors ppId = if insertAnchors then anchor - ! [href url] + ! [href (LText.pack url)] << fromMaybe (toHtml url) mLabel else fromMaybe (toHtml url) mLabel , markupAName = \aname -> if insertAnchors - then namedAnchor aname << "" + then namedAnchor (LText.pack aname) << ("" :: LText.Text) else noHtml - , markupPic = $Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)) + , markupPic = \(Picture uri t) -> image ! ([src (LText.pack uri)] ++ fromMaybe [] (return . title <$> (LText.pack <$> t))) , markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\$") , markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]") , markupProperty = pre . toHtml @@ -121,7 +122,7 @@ parHtmlMarkup qual insertAnchors ppId = exampleToHtml (Example expression result) = htmlExample where htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) - htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlPrompt = (thecode . toHtml $ (">>> " :: LText.Text)) ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] makeOrdList :: HTML a => [(Int, a)] -> Html @@ -204,9 +205,9 @@ hackMarkup fmt' currPkg h' = hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> - let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n + let id_ = makeAnchorId $ "ch:" <> fromMaybe "noid:" (LText.pack <$> nm) <> LText.pack (show n) col' = collapseControl id_ "subheading" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Expand" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Expand" :: LText.Text) instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 ..] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs ===================================== @@ -63,6 +63,7 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -73,7 +74,7 @@ import Haddock.Utils (makeAnchorId, nameAnchorId) miniBody :: Html -> Html miniBody = body ! [identifier "mini"] -sectionDiv :: String -> Html -> Html +sectionDiv :: LText -> Html -> Html sectionDiv i = thediv ! [identifier i] sectionName :: Html -> Html @@ -138,11 +139,11 @@ divTopDecl = thediv ! [theclass "top"] type SubDecl = (Html, Maybe (MDoc DocName), [Html]) -divSubDecls :: HTML a => String -> a -> Maybe Html -> Html +divSubDecls :: LText -> LText -> Maybe Html -> Html divSubDecls cssClass captionName = maybe noHtml wrap where wrap = (subSection <<) . (subCaption +++) - subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subSection = thediv ! [theclass $ LText.unwords ["subs", cssClass]] subCaption = paragraph ! [theclass "caption"] << captionName subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html @@ -232,9 +233,9 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - hdr = h4 ! collapseControl id_ "instances" << "Instances" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instances details" - id_ = makeAnchorId $ "i:" ++ nm + hdr = h4 ! collapseControl id_ "instances" << ("Instances" :: LText) + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instances details" :: LText) + id_ = makeAnchorId $ "i:" <> (LText.pack nm) subOrphanInstances :: Maybe Package @@ -245,12 +246,12 @@ subOrphanInstances -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where - wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! [identifier ("section." ++ id_)] <<) . subTableSrc pkg qual lnks splice + wrap = ((h1 << ("Orphan instances" :: LText)) +++) + instTable = fmap (thediv ! [identifier ("section." <> id_)] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId "orphans" subInstHead - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) @@ -261,7 +262,7 @@ subInstHead iid hdr = expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents @@ -274,7 +275,7 @@ subInstDetails iid ats mets mdl = subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance @@ -285,16 +286,16 @@ subFamInstDetails iid fi mdl = subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -> Html subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) where - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instance details" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instance details" :: LText) -instAnchorId :: String -> String -instAnchorId iid = makeAnchorId $ "i:" ++ iid +instAnchorId :: LText -> LText +instAnchorId iid = makeAnchorId $ "i:" <> iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -321,7 +322,7 @@ topDeclElem lnks loc splice name html = -- Name must be documented, otherwise we wouldn't get here. links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = - srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") + srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << ("#" :: LText)) where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -335,15 +336,15 @@ links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docNa in case mUrl of Nothing -> noHtml Just url -> - let url' = spliceURL (Just origMod) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Source" + let url' = LText.pack $ spliceURL (Just origMod) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Source" :: LText) wikiLink = case maybe_wiki_url of Nothing -> noHtml Just url -> - let url' = spliceURL (Just mdl) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Comments" + let url' = LText.pack $ spliceURL (Just mdl) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Comments" :: LText) -- For source links, we want to point to the original module, -- because only that will have the source. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs ===================================== @@ -41,6 +41,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText -- | Indicator of how to render a 'DocName' into 'Html' data Notation @@ -171,7 +172,7 @@ linkIdOcc mdl mbName insertAnchors = then anchor ! [href url, title ttl] else id where - ttl = moduleNameString (moduleName mdl) + ttl = LText.pack (moduleNameString (moduleName mdl)) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name @@ -179,9 +180,9 @@ linkIdOcc mdl mbName insertAnchors = linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where - ttl = moduleNameString mdl + ttl = LText.pack (moduleNameString mdl) url = case mbName of - Nothing -> moduleHtmlFile' mdl + Nothing -> LText.pack (moduleHtmlFile' mdl) Just name -> moduleNameUrl' mdl name ppModule :: Module -> Html @@ -190,14 +191,14 @@ ppModule mdl = ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef :: Maybe Html -> ModuleName -> LText -> Html ppModuleRef Nothing mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << toHtml (moduleNameString mdl) ppModuleRef (Just lbl) mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << lbl -- NB: The ref parameter already includes the '#'. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs ===================================== @@ -27,6 +27,7 @@ import System.Directory import System.FilePath import Text.XHtml hiding (name, p, quote, title, (</>)) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Backends.Xhtml.Types (BaseURL, withBaseURL) import Haddock.Options @@ -185,10 +186,10 @@ styleSheet base_url ts = toHtml $ zipWith mkLink rels ts rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (withBaseURL base_url (themeHref t)) + ! [ href (LText.pack (withBaseURL base_url (themeHref t))) , rel aRel , thetype "text/css" - , XHtml.title (themeName t) + , XHtml.title (LText.pack (themeName t)) ] << noHtml ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -13,7 +13,7 @@ -- Stability : experimental -- Portability : portable module Haddock.Backends.Xhtml.Utils - ( renderToString + ( renderToBuilder , namedAnchor , linkedAnchor , spliceURL @@ -58,6 +58,7 @@ import GHC.Types.Name (getOccString, isValOcc, nameOccName) import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString) import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Utils @@ -118,8 +119,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run run ('%' : '{' : 'L' : 'I' : 'N' : 'E' : '}' : rest) = line ++ run rest run (c : rest) = c : run rest -renderToString :: Bool -> Html -> String -renderToString debug html +renderToBuilder :: Bool -> Html -> Builder +renderToBuilder debug html | debug = renderHtml html | otherwise = showHtml html @@ -136,7 +137,7 @@ infixr 8 <+> (<+>) :: Html -> Html -> Html a <+> b = a +++ sep +++ b where - sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml (" " :: LText) -- | Join two 'Html' values together with a linebreak in between. -- Has 'noHtml' as left identity. @@ -167,7 +168,7 @@ promoQuote h = char '\'' +++ h parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +pabrackets h = toHtml ("[:" :: LText) +++ h +++ toHtml (":]" :: LText) braces h = char '{' +++ h +++ char '}' punctuate :: Html -> [Html] -> [Html] @@ -188,37 +189,37 @@ ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma ubxSumList :: [Html] -> Html -ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") +ubxSumList = ubxparens . hsep . punctuate (toHtml (" | " :: LText)) ubxparens :: Html -> Html -ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" +ubxparens h = toHtml ("(#" :: LText) <+> h <+> toHtml ("#)" :: LText) dcolon, arrow, lollipop, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" +dcolon unicode = toHtml (if unicode then "∷" :: LText else "::") +arrow unicode = toHtml (if unicode then "→" :: LText else "->") +lollipop unicode = toHtml (if unicode then "⊸" :: LText else "%1 ->") +darrow unicode = toHtml (if unicode then "⇒" :: LText else "=>") +forallSymbol unicode = if unicode then toHtml ("∀" :: LText) else keyword "forall" atSign :: Html -atSign = toHtml "@" +atSign = toHtml ("@" :: LText) multAnnotation :: Html -multAnnotation = toHtml "%" +multAnnotation = toHtml ("%" :: LText) dot :: Html -dot = toHtml "." +dot = toHtml ("." :: LText) -- | Generate a named anchor -namedAnchor :: String -> Html -> Html +namedAnchor :: LText -> Html -> Html namedAnchor n = anchor ! [XHtml.identifier n] -linkedAnchor :: String -> Html -> Html -linkedAnchor n = anchor ! [href ('#' : n)] +linkedAnchor :: LText -> Html -> Html +linkedAnchor n = anchor ! [href ("#" <> n)] -- | generate an anchor identifier for a group -groupId :: String -> String -groupId g = makeAnchorId ("g:" ++ g) +groupId :: LText -> LText +groupId g = makeAnchorId ("g:" <> g) -- -- A section of HTML which is collapsible. @@ -226,7 +227,7 @@ groupId g = makeAnchorId ("g:" ++ g) data DetailsState = DetailsOpen | DetailsClosed -collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails :: LText -> DetailsState -> Html -> Html collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) where openAttrs = case state of DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] @@ -235,14 +236,14 @@ thesummary :: Html -> Html thesummary = tag "summary" -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle :: LText -> LText -> [HtmlAttr] collapseToggle id_ classes = [theclass cs, strAttr "data-details-id" id_] where - cs = unwords (words classes ++ ["details-toggle"]) + cs = LText.unwords (LText.words classes <> ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> String -> [HtmlAttr] +collapseControl :: LText -> LText -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs where - cs = unwords (words classes ++ ["details-toggle-control"]) + cs = LText.unwords (LText.words classes <> ["details-toggle-control"]) ===================================== utils/haddock/haddock-api/src/Haddock/Doc.hs ===================================== @@ -32,7 +32,7 @@ combineDocumentation (Documentation mDoc mWarning) = -- docCodeBlock :: DocH mod id -> DocH mod id docCodeBlock (DocString s) = - DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) + DocString (reverse $ dropWhile (`elem` (" \t" :: String)) $ reverse s) docCodeBlock (DocAppend l r) = DocAppend l (docCodeBlock r) docCodeBlock d = d ===================================== utils/haddock/haddock-api/src/Haddock/Utils.hs ===================================== @@ -83,6 +83,8 @@ import System.IO.Unsafe (unsafePerformIO) import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -184,35 +186,43 @@ subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" -- before being matched with IDs in the target document. ------------------------------------------------------------------------------- -moduleUrl :: Module -> String -moduleUrl = moduleHtmlFile +moduleUrl :: Module -> Text +moduleUrl module_ = LText.pack (moduleHtmlFile module_) -moduleNameUrl :: Module -> OccName -> String -moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n +moduleNameUrl :: Module -> OccName -> Text +moduleNameUrl mdl n = moduleUrl mdl <> "#" <> nameAnchorId n -moduleNameUrl' :: ModuleName -> OccName -> String -moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n +moduleNameUrl' :: ModuleName -> OccName -> Text +moduleNameUrl' mdl n = LText.pack (moduleHtmlFile' mdl) <> "#" <> nameAnchorId n -nameAnchorId :: OccName -> String -nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) +nameAnchorId :: OccName -> Text +nameAnchorId name = makeAnchorId (prefix <> ":" <> LText.pack (occNameString name)) where prefix - | isValOcc name = 'v' - | otherwise = 't' + | isValOcc name = "v" + | otherwise = "t" -- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is -- identity preserving. -makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r +makeAnchorId :: Text -> Text +makeAnchorId input = + case LText.uncons input of + Nothing -> LText.empty + Just (f, rest) -> + escape isAlpha f <> LText.concatMap (escape isLegal) rest where + escape :: (Char -> Bool) -> Char -> Text escape p c - | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" + | p c = LText.singleton c + | otherwise = + -- "-" <> show (ord c) <> "-" + LText.cons '-' (LText.pack (show (ord c) <> "-")) + + isLegal :: Char -> Bool isLegal ':' = True isLegal '_' = True isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c + isLegal c = isAscii c && isAlphaNum c -- NB: '-' is legal in IDs, but we use it as the escape char @@ -272,7 +282,7 @@ escapeURIString :: (Char -> Bool) -> String -> String escapeURIString = concatMap . escapeURIChar isUnreserved :: Char -> Bool -isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") +isUnreserved c = isAlphaNumChar c || (c `elem` ("-_.~" :: String)) isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') ===================================== utils/haddock/html-test/ref/Bug26.html ===================================== @@ -53,7 +53,7 @@ >Description</p ><div class="doc" ><p - >This module tests the ‘@since …’ annotation.</p + >This module tests the ‘@since …’ annotation.</p ><p ><em >Since: 1.2.3</em ===================================== utils/haddock/html-test/ref/Bug298.html ===================================== @@ -67,7 +67,7 @@ > :: a -> a -> a</li ><li class="src short" ><a href="#" - >(⋆^)</a + >(⋆^)</a > :: a -> a -> a</li ><li class="src short" ><a href="#" @@ -106,7 +106,7 @@ ><div class="top" ><p class="src" ><a id="v:-8902--94-" class="def" - >(⋆^)</a + >(⋆^)</a > :: a -> a -> a <a href="#" class="selflink" >#</a ></p @@ -134,7 +134,7 @@ ></code > and <code ><a href="#" title="Bug298" - >⋆^</a + >⋆^</a ></code >.</p ></div ===================================== utils/haddock/html-test/ref/Bug458.html ===================================== @@ -55,7 +55,7 @@ ><ul class="details-toggle" data-details-id="syn" ><li class="src short" ><a href="#" - >(⊆)</a + >(⊆)</a > :: () -> () -> ()</li ></ul ></details @@ -66,7 +66,7 @@ ><div class="top" ><p class="src" ><a id="v:-8838-" class="def" - >(⊆)</a + >(⊆)</a > :: () -> () -> () <a href="#" class="selflink" >#</a ></p @@ -75,7 +75,7 @@ >See the defn of <code class="inline-code" ><code ><a href="#" title="Bug458" - >⊆</a + >⊆</a ></code ></code >.</p ===================================== utils/haddock/html-test/ref/Nesting.html ===================================== @@ -317,7 +317,7 @@ with more of the indented list content.</p ><h3 >Level 3 header</h3 ><p - >with some content…</p + >with some content…</p ><ul ><li >and even more lists inside</li ===================================== utils/haddock/html-test/ref/TitledPicture.html ===================================== @@ -105,7 +105,7 @@ ><a href="#" title="TitledPicture" >bar</a ></code - > with title <img src="un∣∁∘" title="δ∈" + > with title <img src="un∣∁∘" title="δ∈" /></p ></div ></div ===================================== utils/haddock/html-test/ref/Unicode.html ===================================== @@ -76,7 +76,7 @@ ></p ><div class="doc" ><p - >γλώσσα</p + >γλώσσα</p ></div ></div ></div ===================================== utils/haddock/html-test/ref/Unicode2.html ===================================== @@ -55,7 +55,7 @@ ><ul class="details-toggle" data-details-id="syn" ><li class="src short" ><a href="#" - >ü</a + >ü</a > :: ()</li ></ul ></details @@ -66,36 +66,36 @@ ><div class="top" ><p class="src" ><a id="v:-252-" class="def" - >ü</a + >ü</a > :: () <a href="#" class="selflink" >#</a ></p ><div class="doc" ><p - >All of the following work with a unicode character ü:</p + >All of the following work with a unicode character ü:</p ><ul ><li >an italicized <em - >ü</em + >ü</em ></li ><li >inline code <code class="inline-code" - >ü</code + >ü</code ></li ><li >a code block:</li ></ul ><pre - >ü</pre + >ü</pre ><ul ><li >a url <a href="#" - >https://www.google.com/search?q=ü</a + >https://www.google.com/search?q=ü</a ></li ><li >a link to <code ><a href="#" title="Unicode2" - >ü</a + >ü</a ></code ></li ></ul View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b3b6e967332d21c7f0530c8c9e656… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b3b6e967332d21c7f0530c8c9e656… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] users' guide: don't use f strings in the python script to ensure compatibility with python 3.5
by Marge Bot (＠marge-bot) 06 Dec '25

06 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00 users' guide: don't use f strings in the python script to ensure compatibility with python 3.5 - - - - - 1 changed file: - docs/users_guide/conf.py Changes: ===================================== docs/users_guide/conf.py ===================================== @@ -45,7 +45,7 @@ rst_prolog = """ # General information about the project. project = u'Glasgow Haskell Compiler' -copyright = f"{datetime.now(timezone.utc).year}, GHC Team" +copyright = "{}, GHC Team".format(datetime.now(timezone.utc).year) # N.B. version comes from ghc_config release = version # The full version, including alpha/beta/rc tags. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f297f6e06f218bf88884f140f53df4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f297f6e06f218bf88884f140f53df4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: Fix object file format detection in loadArchive
by Marge Bot (＠marge-bot) 06 Dec '25

06 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -592,6 +592,9 @@ HsInt loadArchive_ (pathchar *path) if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } + // Unlike for regular archives for thin archives we can only identify the object format + // after having read the file pointed to. + object_fmt = identifyObjectFile_(image, memberSize); } else { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc958fc9eb6f6f4db473cdda23c381d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc958fc9eb6f6f4db473cdda23c381d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] update xhtml to 3000.4.0.0
by Marge Bot (＠marge-bot) 06 Dec '25

06 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - 24 changed files: - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Default.hs - libraries/xhtml - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html Changes: ===================================== hadrian/src/Rules/ToolArgs.hs ===================================== @@ -172,6 +172,7 @@ toolTargets = [ cabalSyntax , time , semaphoreCompat , unlit -- # executable + , xhtml ] ++ if windowsHost then [ win32 ] else [ unix ] -- | Create a mapping from files to which component it belongs to. ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -109,6 +109,7 @@ stage0Packages = do , thLift -- new library not yet present for boot compilers , thQuasiquoter -- new library not yet present for boot compilers , unlit + , xhtml -- new version is not backwards compat with latest , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version -- bundled with GHC 9.6 is too old for `semaphore-compat`. ===================================== libraries/xhtml ===================================== @@ -1 +1 @@ -Subproject commit 68353ccd1a2e776d6c2b11619265d8140bb7dc07 +Subproject commit cc203b9cc0a60c53a3bcbf2f38eb72cb7cf6098d ===================================== utils/haddock/cabal.project ===================================== @@ -12,4 +12,4 @@ package haddock-api tests: False -- Pinning the index-state helps to make reasonably CI deterministic -index-state: 2024-06-18T11:54:44Z +index-state: 2025-11-17T03:30:46Z ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -51,6 +51,7 @@ common extensions StrictData TypeApplications TypeOperators + OverloadedStrings default-language: Haskell2010 @@ -81,7 +82,7 @@ library build-depends: base >= 4.16 && < 4.23 , ghc ^>= 9.15 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , parsec ^>= 3.1.13.0 -- Versions for the dependencies below are transitively pinned by @@ -97,6 +98,7 @@ library , ghc-boot , mtl , transformers + , text hs-source-dirs: src @@ -212,7 +214,7 @@ test-suite spec build-depends: ghc ^>= 9.7 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.11 - , xhtml ^>= 3000.2.2 + , xhtml ^>= 3000.4.0.0 , hspec ^>= 2.9 , parsec ^>= 3.1.13.0 , QuickCheck >= 2.11 && ^>= 2.14 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -134,7 +134,7 @@ out :: Outputable a => SDocContext -> a -> String out sDocContext = outWith $ Outputable.renderWithContext sDocContext operator :: String -> String -operator (x : xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x : xs ++ ")" +operator (x : xs) | not (isAlphaNum x) && x `notElem` ("_' ([{" :: String) = '(' : x : xs ++ ")" operator x = x commaSeparate :: Outputable a => SDocContext -> [a] -> String ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -28,10 +28,11 @@ import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Utils (renderToString) +import Haddock.Backends.Xhtml.Utils (renderToBuilder) import Haddock.InterfaceFile import Haddock.Types -import Haddock.Utils (Verbosity, out, verbose, writeUtf8File) +import Haddock.Utils (Verbosity, out, verbose) +import qualified Data.ByteString.Builder as Builder -- | Generate hyperlinked source for given interfaces. -- @@ -117,7 +118,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens + Builder.writeFile path . renderToBuilder pretty . render' thisModule fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -24,7 +24,9 @@ import qualified Text.XHtml as Html import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -type StyleClass = String +import qualified Data.Text.Lazy as LText + +type StyleClass = LText.Text -- | Produce the HTML corresponding to a hyperlinked Haskell source render @@ -50,7 +52,7 @@ body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml -header mcss mjs = Html.header $ css mcss <> js mjs +header mcss mjs = Html.header $ css (LText.pack <$> mcss) <> js (LText.pack <$> mjs) where css Nothing = Html.noHtml css (Just cssFile) = @@ -225,7 +227,7 @@ tokenStyle TkPragma = ["hs-pragma"] tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . unwords +multiclass = Html.theclass . LText.unwords externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html externalAnchor (Right name) contexts content @@ -250,11 +252,11 @@ internalAnchor (Right name) contexts content Html.thespan content ! [Html.identifier $ internalAnchorIdent name] internalAnchor _ _ content = content -externalAnchorIdent :: Name -> String -externalAnchorIdent = hypSrcNameUrl +externalAnchorIdent :: Name -> LText.Text +externalAnchorIdent name = LText.pack (hypSrcNameUrl name) -internalAnchorIdent :: Name -> String -internalAnchorIdent = ("l-" ++) . showUnique . nameUnique +internalAnchorIdent :: Name -> LText.Text +internalAnchorIdent = LText.pack . ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html @@ -269,16 +271,16 @@ hyperlink thisModule (srcs, srcs') ident = case ident of makeHyperlinkUrl url = ".." </> url internalHyperlink name content = - Html.anchor content ! [Html.href $ "#" ++ internalAnchorIdent name] + Html.anchor content ! [Html.href $ "#" <> internalAnchorIdent name] externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] + ! [Html.href $ LText.pack (hypSrcModuleNameUrl' thisModule mdl name)] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl] Nothing -> content where mdl = nameModule name @@ -287,11 +289,11 @@ hyperlink thisModule (srcs, srcs') ident = case ident of case Map.lookup moduleName srcs' of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleUrl' moduleName] + ! [Html.href $ LText.pack $ hypSrcModuleUrl' moduleName] Just (SrcExternal path) -> let hyperlinkUrl = makeHyperlinkUrl path in Html.anchor content - ! [Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] + ! [Html.href $ LText.pack $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl] Nothing -> content renderSpace :: Int -> String -> Html @@ -307,4 +309,4 @@ renderSpace line space = in Html.toHtml hspace <> renderSpace line rest lineAnchor :: Int -> Html -lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ hypSrcLineUrl line] +lineAnchor line = Html.thespan Html.noHtml ! [Html.identifier $ LText.pack $ hypSrcLineUrl line] ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -51,6 +51,10 @@ import qualified System.IO as IO import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml import Prelude hiding (div) +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy as LBS import Haddock.Backends.Xhtml.Decl import Haddock.Backends.Xhtml.DocMarkup @@ -221,7 +225,7 @@ copyHtmlBits odir libdir themes withQuickjump = do headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html headHtml docTitle themes mathjax_url base_url = header - ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) base_url) + ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) (LText.pack <$> base_url)) << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle @@ -229,18 +233,18 @@ headHtml docTitle themes mathjax_url base_url = , thelink ! [ rel "stylesheet" , thetype "text/css" - , href (withBaseURL base_url quickJumpCssFile) + , href (LText.pack $ withBaseURL base_url quickJumpCssFile) ] << noHtml , thelink ! [rel "stylesheet", thetype "text/css", href fontUrl] << noHtml , script - ! [ src (withBaseURL base_url haddockJsFile) + ! [ src (LText.pack $ withBaseURL base_url haddockJsFile) , emptyAttr "async" , thetype "text/javascript" ] << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf - , script ! [src mjUrl, thetype "text/javascript"] << noHtml + , script ! [src (LText.pack mjUrl), thetype "text/javascript"] << noHtml ] where fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" @@ -257,31 +261,31 @@ headHtml docTitle themes mathjax_url base_url = srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = - Just (anchor ! [href src_base_url] << "Source") + Just (anchor ! [href (LText.pack src_base_url)] << ("Source" :: LText)) srcButton (_, Just src_module_url, _, _) (Just iface) = let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url - in Just (anchor ! [href url] << "Source") + in Just (anchor ! [href (LText.pack url)] << ("Source" :: LText)) srcButton _ _ = Nothing wikiButton :: WikiURLs -> Maybe Module -> Maybe Html wikiButton (Just wiki_base_url, _, _) Nothing = - Just (anchor ! [href wiki_base_url] << "User Comments") + Just (anchor ! [href (LText.pack wiki_base_url)] << ("User Comments" :: LText)) wikiButton (_, Just wiki_module_url, _) (Just mdl) = let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url - in Just (anchor ! [href url] << "User Comments") + in Just (anchor ! [href (LText.pack url)] << ("User Comments" :: LText)) wikiButton _ _ = Nothing contentsButton :: Maybe String -> Maybe Html contentsButton maybe_contents_url = - Just (anchor ! [href url] << "Contents") + Just (anchor ! [href (LText.pack url)] << ("Contents" :: LText)) where url = fromMaybe contentsHtmlFile maybe_contents_url indexButton :: Maybe String -> Maybe Html indexButton maybe_index_url = - Just (anchor ! [href url] << "Index") + Just (anchor ! [href (LText.pack url)] << ("Index" :: LText)) where url = fromMaybe indexHtmlFile maybe_index_url @@ -318,8 +322,8 @@ bodyHtml , divContent << pageContent , divFooter << paragraph - << ( "Produced by " - +++ (anchor ! [href projectUrl] << toHtml projectName) + << ( ("Produced by " :: LText) + +++ (anchor ! [href (LText.pack projectUrl)] << toHtml projectName) +++ (" version " ++ projectVersion) ) ] @@ -368,7 +372,7 @@ moduleInfo iface = xs -> extField $ unordList xs ! [theclass "extension-list"] | otherwise = [] where - extField x = return $ th << "Extensions" <-> td << x + extField x = return $ th << ("Extensions" :: LText) <-> td << x dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x in case entries of @@ -454,7 +458,7 @@ ppHtmlContents , ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, contentsHtmlFile]) (renderToBuilder debug html) where -- Extract a module's short description. toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) @@ -472,11 +476,11 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppSignatureTrees _ _ tss | all (null . snd) tss = mempty ppSignatureTrees pkg qual [(info, ts)] = - divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) + divPackageList << (sectionName << ("Signatures" :: LText) +++ ppSignatureTree pkg qual "n" info ts) ppSignatureTrees pkg qual tss = divModuleList << ( sectionName - << "Signatures" + << ("Signatures" :: LText) +++ concatHtml [ ppSignatureTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -491,11 +495,11 @@ ppSignatureTree pkg qual p info ts = ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppModuleTrees _ _ tss | all (null . snd) tss = mempty ppModuleTrees pkg qual [(info, ts)] = - divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts) + divModuleList << (sectionName << ("Modules" :: LText) +++ ppModuleTree pkg qual "n" info ts) ppModuleTrees pkg qual tss = divPackageList << ( sectionName - << "Packages" + << ("Packages" :: LText) +++ concatHtml [ ppModuleTree pkg qual ("n." ++ show i ++ ".") info ts | (i, (info, ts)) <- zip [(1 :: Int) ..] tss @@ -519,11 +523,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_ : _, Nothing) -> collapseControl p "module" + (_ : _, Nothing) -> collapseControl (LText.pack p) "module" (_, _) -> [theclass "module"] cBtn = case (ts, leaf) of - (_ : _, Just _) -> thespan ! collapseControl p "" << spaceHtml + (_ : _, Just _) -> thespan ! collapseControl (LText.pack p) "" << spaceHtml ([], Just _) -> thespan ! [theclass "noexpander"] << spaceHtml (_, _) -> noHtml -- We only need an explicit collapser button when the module name @@ -547,11 +551,11 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = then noHtml else collapseDetails - p + (LText.pack p) DetailsOpen ( thesummary ! [theclass "hide-when-js-enabled"] - << "Submodules" + << ("Submodules" :: LText) +++ mkNodeList pkg qual (s : ss) p ts ) @@ -650,10 +654,10 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins | Just item_html <- processExport True links_info unicode pkg qual item = Just JsonIndexEntry - { jieHtmlFragment = showHtmlFragment item_html + { jieHtmlFragment = Text.unpack (Text.decodeUtf8Lenient (LBS.toStrict (Builder.toLazyByteString (showHtmlFragment item_html)))) , jieName = unwords (map getOccString names) , jieModule = moduleString mdl - , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + , jieLink = LText.unpack $ fromMaybe "" (listToMaybe (map (nameLink mdl) names)) } | otherwise = Nothing where @@ -668,7 +672,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins exportName ExportNoDecl{expItemName} = [expItemName] exportName _ = [] - nameLink :: NamedThing name => Module -> name -> String + nameLink :: NamedThing name => Module -> name -> LText nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName links_info = (maybe_source_url, maybe_wiki_url) @@ -720,9 +724,9 @@ ppHtmlIndex mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + Builder.writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToBuilder debug mergedhtml) - writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) + Builder.writeFile (joinPath [odir, indexHtmlFile]) (renderToBuilder debug html) where indexPage showLetters ch items = headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing @@ -754,7 +758,7 @@ ppHtmlIndex indexInitialLetterLinks = divAlphabet << unordList - ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + ( map (\str -> anchor ! [href (LText.pack $ subIndexHtmlFile str)] << str) $ [ [c] | c <- initialChars, any (indexStartsWith c) index ] ++ [merged_name] @@ -773,7 +777,7 @@ ppHtmlIndex do_sub_index this_ix c = unless (null index_part) $ - writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + Builder.writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToBuilder debug html) where html = indexPage True (Just c) index_part index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] @@ -844,9 +848,9 @@ ppHtmlIndex <-> indexLinks nm entries ppAnnot n - | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" + | not (isValOcc n) = toHtml ("Type/Class" :: LText) + | isDataOcc n = toHtml ("Data Constructor" :: LText) + | otherwise = toHtml ("Function" :: LText) indexLinks nm entries = td @@ -909,10 +913,10 @@ ppHtmlModule mdl_str_linked | ifaceIsSig iface = mdl_str - +++ " (signature" + +++ (" (signature" :: LText) +++ sup - << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]") - +++ ")" + << (("[" :: LText) +++ anchor ! [href (LText.pack signatureDocURL)] << ("?" :: LText) +++ ("]" :: LText)) + +++ (")" :: LText) | otherwise = toHtml mdl_str real_qual = makeModuleQual qual mdl @@ -930,7 +934,7 @@ ppHtmlModule ] createDirectoryIfMissing True odir - writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + Builder.writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToBuilder debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" @@ -965,7 +969,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = description | isNoHtml doc = doc - | otherwise = divDescription $ sectionName << "Description" +++ doc + | otherwise = divDescription $ sectionName << ("Description" :: LText) +++ doc where doc = docSection Nothing pkg qual (ifaceRnDoc iface) @@ -978,7 +982,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = "syn" DetailsClosed ( thesummary - << "Synopsis" + << ("Synopsis" :: LText) +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode pkg qual) exports ) @@ -991,7 +995,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual = case exports of [] -> noHtml ExportGroup{} : _ -> noHtml - _ -> h1 << "Documentation" + _ -> h1 << ("Documentation" :: LText) bdy = foldr (+++) noHtml $ @@ -1017,7 +1021,7 @@ ppModuleContents pkg qual exports orphan contentsDiv = divTableOfContents << ( divContentsList - << ( (sectionName << "Contents") + << ( (sectionName << ("Contents" :: LText)) ! [strAttr "onclick" "window.scrollTo(0,0)"] +++ unordList (sections ++ orphanSection) ) @@ -1025,7 +1029,7 @@ ppModuleContents pkg qual exports orphan (sections, _leftovers {-should be []-}) = process 0 exports orphanSection - | orphan = [linkedAnchor "section.orphans" << "Orphan instances"] + | orphan = [linkedAnchor "section.orphans" << ("Orphan instances" :: LText)] | otherwise = [] process :: Int -> [ExportItem DocNameI] -> ([Html], [ExportItem DocNameI]) @@ -1035,7 +1039,7 @@ ppModuleContents pkg qual exports orphan | otherwise = (html : secs, rest2) where html = - linkedAnchor (groupId id0) + linkedAnchor (groupId (LText.pack id0)) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest @@ -1103,7 +1107,7 @@ processExport ) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = - nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) + nothingIf summary $ groupHeading lev (LText.pack id0) << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ _ qual (ExportNoDecl y subs) = @@ -1113,7 +1117,7 @@ processExport summary _ _ _ qual (ExportNoDecl y subs) = processExport summary _ _ pkg qual (ExportDoc doc) = nothingIf summary $ docSection_ Nothing pkg qual doc processExport summary _ _ _ _ (ExportModule mdl) = - processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + processDeclOneLiner summary $ toHtml ("module" :: LText) <+> ppModule mdl nothingIf :: Bool -> a -> Maybe a nothingIf True _ = Nothing @@ -1132,7 +1136,7 @@ processDeclOneLiner :: Bool -> Html -> Maybe Html processDeclOneLiner True = Just processDeclOneLiner False = Just . divTopDecl . declElem -groupHeading :: Int -> String -> Html -> Html +groupHeading :: Int -> LText -> Html -> Html groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] where grpId = groupId id0 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -45,6 +45,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.Doc (combineDocumentation) import Haddock.GhcUtils import Haddock.Types +import qualified Data.Text.Lazy as LText -- | Pretty print a declaration ppDecl @@ -352,9 +353,9 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," - gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" - gadtOpen = toHtml "{" + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("," :: LText) + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ("}" :: LText) + gadtOpen = toHtml ("{" :: LText) ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml @@ -365,7 +366,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge ! [theclass "fixity"] << (toHtml d <+> toHtml (show p) <+> ppNames ns) - ppDir InfixR = "infixr" + ppDir InfixR = ("infixr" :: LText) ppDir InfixL = "infixl" ppDir InfixN = "infix" @@ -730,7 +731,7 @@ ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmp ppContextNoLocsMaybe [] _ _ emptyCtxts = case emptyCtxts of HideEmptyContexts -> Nothing - ShowEmptyToplevelContexts -> Just (toHtml "()") + ShowEmptyToplevelContexts -> Just (toHtml ("()" :: LText)) ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html @@ -1006,13 +1007,13 @@ ppClassDecl == [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml "Nothing" + And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) m : _ -> subMinimal $ ppMinimal False m _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a +++ ", " +++ b) $ map (ppMinimal True . unLoc) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ " | " +++ b) $ map (ppMinimal False . unLoc) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) @@ -1115,7 +1116,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead{..}) md pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual DataInst {} -> error "ppInstHead" where - mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl + mname = maybe noHtml (\m -> toHtml ("Defined in" :: LText) <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual @@ -1163,9 +1164,9 @@ ppInstanceSigs links splice unicode qual sigs = do lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> LText instanceId origin no orphan ihd = - concat $ + LText.pack $ concat $ ["o:" | orphan] ++ [ qual origin , ":" ++ getOccString origin @@ -1529,7 +1530,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode - +++ toHtml " " + +++ toHtml (" " :: LText) -- | Pretty-print a record field ppSideBySideField @@ -1564,7 +1565,7 @@ ppSideBySideField subdocs unicode qual (HsConDeclRecField _ names ltype) = ppRecFieldMultAnn :: Unicode -> Qualification -> HsConDeclField DocNameI -> Html ppRecFieldMultAnn unicode qual (CDF { cdf_multiplicity = ann }) = case ann of HsUnannotated _ -> noHtml - HsLinearAnn _ -> toHtml "%1" + HsLinearAnn _ -> toHtml ("%1" :: LText) HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts ppShortField :: Bool -> Unicode -> Qualification -> HsConDeclRecField DocNameI -> Html @@ -1668,8 +1669,8 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- ppBang :: HsSrcBang -> Html -ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" -ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml ("!" :: LText) +ppBang (HsSrcBang _ _ SrcLazy) = toHtml ("~" :: LText) ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -1707,7 +1708,7 @@ ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) un ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg _ ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign <> ppLParendType unicode qual emptyCtxts ki -ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ("" :: LText) class RenderableBndrFlag flag where ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html @@ -1814,12 +1815,12 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ - | getOccString (getName name) == "(->)" = toHtml "(→)" + | getOccString (getName name) == "(->)" = toHtml ("(→)" :: LText) ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | isPromoted prom = promoQuote (ppDocName q Prefix True name) | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = - toHtml (if u || isUni then "★" else "*") + toHtml (if u || isUni then "★" else "*" :: LText) ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts @@ -1842,7 +1843,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v ppr_mono_ty (XHsType (HsBangTy b ty)) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}" +ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml ("{..}" :: LText) -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs ===================================== @@ -39,6 +39,7 @@ import Haddock.Doc ) import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText parHtmlMarkup :: Qualification @@ -60,7 +61,7 @@ parHtmlMarkup qual insertAnchors ppId = mdl' = case reverse mdl of '\\' : _ -> init mdl _ -> mdl - in ppModuleRef lbl (mkModuleName mdl') ref + in ppModuleRef lbl (mkModuleName mdl') (LText.pack ref) , markupWarning = thediv ! [theclass "warning"] , markupEmphasis = emphasize , markupBold = strong @@ -73,14 +74,14 @@ parHtmlMarkup qual insertAnchors ppId = if insertAnchors then anchor - ! [href url] + ! [href (LText.pack url)] << fromMaybe (toHtml url) mLabel else fromMaybe (toHtml url) mLabel , markupAName = \aname -> if insertAnchors - then namedAnchor aname << "" + then namedAnchor (LText.pack aname) << ("" :: LText.Text) else noHtml - , markupPic = $Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)) + , markupPic = \(Picture uri t) -> image ! ([src (LText.pack uri)] ++ fromMaybe [] (return . title <$> (LText.pack <$> t))) , markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\$") , markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]") , markupProperty = pre . toHtml @@ -121,7 +122,7 @@ parHtmlMarkup qual insertAnchors ppId = exampleToHtml (Example expression result) = htmlExample where htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) - htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlPrompt = (thecode . toHtml $ (">>> " :: LText.Text)) ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] makeOrdList :: HTML a => [(Int, a)] -> Html @@ -204,9 +205,9 @@ hackMarkup fmt' currPkg h' = hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> - let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n + let id_ = makeAnchorId $ "ch:" <> fromMaybe "noid:" (LText.pack <$> nm) <> LText.pack (show n) col' = collapseControl id_ "subheading" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Expand" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Expand" :: LText.Text) instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 ..] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs ===================================== @@ -63,6 +63,7 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -73,7 +74,7 @@ import Haddock.Utils (makeAnchorId, nameAnchorId) miniBody :: Html -> Html miniBody = body ! [identifier "mini"] -sectionDiv :: String -> Html -> Html +sectionDiv :: LText -> Html -> Html sectionDiv i = thediv ! [identifier i] sectionName :: Html -> Html @@ -138,11 +139,11 @@ divTopDecl = thediv ! [theclass "top"] type SubDecl = (Html, Maybe (MDoc DocName), [Html]) -divSubDecls :: HTML a => String -> a -> Maybe Html -> Html +divSubDecls :: LText -> LText -> Maybe Html -> Html divSubDecls cssClass captionName = maybe noHtml wrap where wrap = (subSection <<) . (subCaption +++) - subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subSection = thediv ! [theclass $ LText.unwords ["subs", cssClass]] subCaption = paragraph ! [theclass "caption"] << captionName subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html @@ -232,9 +233,9 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - hdr = h4 ! collapseControl id_ "instances" << "Instances" - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instances details" - id_ = makeAnchorId $ "i:" ++ nm + hdr = h4 ! collapseControl id_ "instances" << ("Instances" :: LText) + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instances details" :: LText) + id_ = makeAnchorId $ "i:" <> (LText.pack nm) subOrphanInstances :: Maybe Package @@ -245,12 +246,12 @@ subOrphanInstances -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where - wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! [identifier ("section." ++ id_)] <<) . subTableSrc pkg qual lnks splice + wrap = ((h1 << ("Orphan instances" :: LText)) +++) + instTable = fmap (thediv ! [identifier ("section." <> id_)] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId "orphans" subInstHead - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) @@ -261,7 +262,7 @@ subInstHead iid hdr = expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents @@ -274,7 +275,7 @@ subInstDetails iid ats mets mdl = subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance @@ -285,16 +286,16 @@ subFamInstDetails iid fi mdl = subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection - :: String + :: LText -- ^ Instance unique id (for anchor generation) -> Html -> Html subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) where - summary = thesummary ! [theclass "hide-when-js-enabled"] << "Instance details" + summary = thesummary ! [theclass "hide-when-js-enabled"] << ("Instance details" :: LText) -instAnchorId :: String -> String -instAnchorId iid = makeAnchorId $ "i:" ++ iid +instAnchorId :: LText -> LText +instAnchorId iid = makeAnchorId $ "i:" <> iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -321,7 +322,7 @@ topDeclElem lnks loc splice name html = -- Name must be documented, otherwise we wouldn't get here. links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = - srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") + srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << ("#" :: LText)) where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -335,15 +336,15 @@ links ((_, _, sourceMap, lineMap), (_, _, maybe_wiki_url)) loc splice mdl' docNa in case mUrl of Nothing -> noHtml Just url -> - let url' = spliceURL (Just origMod) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Source" + let url' = LText.pack $ spliceURL (Just origMod) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Source" :: LText) wikiLink = case maybe_wiki_url of Nothing -> noHtml Just url -> - let url' = spliceURL (Just mdl) (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Comments" + let url' = LText.pack $ spliceURL (Just mdl) (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << ("Comments" :: LText) -- For source links, we want to point to the original module, -- because only that will have the source. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs ===================================== @@ -41,6 +41,7 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Utils +import qualified Data.Text.Lazy as LText -- | Indicator of how to render a 'DocName' into 'Html' data Notation @@ -171,7 +172,7 @@ linkIdOcc mdl mbName insertAnchors = then anchor ! [href url, title ttl] else id where - ttl = moduleNameString (moduleName mdl) + ttl = LText.pack (moduleNameString (moduleName mdl)) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name @@ -179,9 +180,9 @@ linkIdOcc mdl mbName insertAnchors = linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where - ttl = moduleNameString mdl + ttl = LText.pack (moduleNameString mdl) url = case mbName of - Nothing -> moduleHtmlFile' mdl + Nothing -> LText.pack (moduleHtmlFile' mdl) Just name -> moduleNameUrl' mdl name ppModule :: Module -> Html @@ -190,14 +191,14 @@ ppModule mdl = ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef :: Maybe Html -> ModuleName -> LText -> Html ppModuleRef Nothing mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << toHtml (moduleNameString mdl) ppModuleRef (Just lbl) mdl ref = anchor - ! [href (moduleHtmlFile' mdl ++ ref)] + ! [href (LText.pack (moduleHtmlFile' mdl) <> ref)] << lbl -- NB: The ref parameter already includes the '#'. ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs ===================================== @@ -27,6 +27,7 @@ import System.Directory import System.FilePath import Text.XHtml hiding (name, p, quote, title, (</>)) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Backends.Xhtml.Types (BaseURL, withBaseURL) import Haddock.Options @@ -185,10 +186,10 @@ styleSheet base_url ts = toHtml $ zipWith mkLink rels ts rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (withBaseURL base_url (themeHref t)) + ! [ href (LText.pack (withBaseURL base_url (themeHref t))) , rel aRel , thetype "text/css" - , XHtml.title (themeName t) + , XHtml.title (LText.pack (themeName t)) ] << noHtml ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -13,7 +13,7 @@ -- Stability : experimental -- Portability : portable module Haddock.Backends.Xhtml.Utils - ( renderToString + ( renderToBuilder , namedAnchor , linkedAnchor , spliceURL @@ -58,6 +58,7 @@ import GHC.Types.Name (getOccString, isValOcc, nameOccName) import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString) import Text.XHtml hiding (name, p, quote, title) import qualified Text.XHtml as XHtml +import qualified Data.Text.Lazy as LText import Haddock.Utils @@ -118,8 +119,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run run ('%' : '{' : 'L' : 'I' : 'N' : 'E' : '}' : rest) = line ++ run rest run (c : rest) = c : run rest -renderToString :: Bool -> Html -> String -renderToString debug html +renderToBuilder :: Bool -> Html -> Builder +renderToBuilder debug html | debug = renderHtml html | otherwise = showHtml html @@ -136,7 +137,7 @@ infixr 8 <+> (<+>) :: Html -> Html -> Html a <+> b = a +++ sep +++ b where - sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml (" " :: LText) -- | Join two 'Html' values together with a linebreak in between. -- Has 'noHtml' as left identity. @@ -167,7 +168,7 @@ promoQuote h = char '\'' +++ h parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +pabrackets h = toHtml ("[:" :: LText) +++ h +++ toHtml (":]" :: LText) braces h = char '{' +++ h +++ char '}' punctuate :: Html -> [Html] -> [Html] @@ -188,37 +189,37 @@ ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma ubxSumList :: [Html] -> Html -ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") +ubxSumList = ubxparens . hsep . punctuate (toHtml (" | " :: LText)) ubxparens :: Html -> Html -ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" +ubxparens h = toHtml ("(#" :: LText) <+> h <+> toHtml ("#)" :: LText) dcolon, arrow, lollipop, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" +dcolon unicode = toHtml (if unicode then "∷" :: LText else "::") +arrow unicode = toHtml (if unicode then "→" :: LText else "->") +lollipop unicode = toHtml (if unicode then "⊸" :: LText else "%1 ->") +darrow unicode = toHtml (if unicode then "⇒" :: LText else "=>") +forallSymbol unicode = if unicode then toHtml ("∀" :: LText) else keyword "forall" atSign :: Html -atSign = toHtml "@" +atSign = toHtml ("@" :: LText) multAnnotation :: Html -multAnnotation = toHtml "%" +multAnnotation = toHtml ("%" :: LText) dot :: Html -dot = toHtml "." +dot = toHtml ("." :: LText) -- | Generate a named anchor -namedAnchor :: String -> Html -> Html +namedAnchor :: LText -> Html -> Html namedAnchor n = anchor ! [XHtml.identifier n] -linkedAnchor :: String -> Html -> Html -linkedAnchor n = anchor ! [href ('#' : n)] +linkedAnchor :: LText -> Html -> Html +linkedAnchor n = anchor ! [href ("#" <> n)] -- | generate an anchor identifier for a group -groupId :: String -> String -groupId g = makeAnchorId ("g:" ++ g) +groupId :: LText -> LText +groupId g = makeAnchorId ("g:" <> g) -- -- A section of HTML which is collapsible. @@ -226,7 +227,7 @@ groupId g = makeAnchorId ("g:" ++ g) data DetailsState = DetailsOpen | DetailsClosed -collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails :: LText -> DetailsState -> Html -> Html collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) where openAttrs = case state of DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] @@ -235,14 +236,14 @@ thesummary :: Html -> Html thesummary = tag "summary" -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle :: LText -> LText -> [HtmlAttr] collapseToggle id_ classes = [theclass cs, strAttr "data-details-id" id_] where - cs = unwords (words classes ++ ["details-toggle"]) + cs = LText.unwords (LText.words classes <> ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> String -> [HtmlAttr] +collapseControl :: LText -> LText -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs where - cs = unwords (words classes ++ ["details-toggle-control"]) + cs = LText.unwords (LText.words classes <> ["details-toggle-control"]) ===================================== utils/haddock/haddock-api/src/Haddock/Doc.hs ===================================== @@ -32,7 +32,7 @@ combineDocumentation (Documentation mDoc mWarning) = -- docCodeBlock :: DocH mod id -> DocH mod id docCodeBlock (DocString s) = - DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) + DocString (reverse $ dropWhile (`elem` (" \t" :: String)) $ reverse s) docCodeBlock (DocAppend l r) = DocAppend l (docCodeBlock r) docCodeBlock d = d ===================================== utils/haddock/haddock-api/src/Haddock/Utils.hs ===================================== @@ -83,6 +83,8 @@ import System.IO.Unsafe (unsafePerformIO) import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as LText -------------------------------------------------------------------------------- @@ -184,35 +186,43 @@ subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" -- before being matched with IDs in the target document. ------------------------------------------------------------------------------- -moduleUrl :: Module -> String -moduleUrl = moduleHtmlFile +moduleUrl :: Module -> Text +moduleUrl module_ = LText.pack (moduleHtmlFile module_) -moduleNameUrl :: Module -> OccName -> String -moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n +moduleNameUrl :: Module -> OccName -> Text +moduleNameUrl mdl n = moduleUrl mdl <> "#" <> nameAnchorId n -moduleNameUrl' :: ModuleName -> OccName -> String -moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n +moduleNameUrl' :: ModuleName -> OccName -> Text +moduleNameUrl' mdl n = LText.pack (moduleHtmlFile' mdl) <> "#" <> nameAnchorId n -nameAnchorId :: OccName -> String -nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) +nameAnchorId :: OccName -> Text +nameAnchorId name = makeAnchorId (prefix <> ":" <> LText.pack (occNameString name)) where prefix - | isValOcc name = 'v' - | otherwise = 't' + | isValOcc name = "v" + | otherwise = "t" -- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is -- identity preserving. -makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r +makeAnchorId :: Text -> Text +makeAnchorId input = + case LText.uncons input of + Nothing -> LText.empty + Just (f, rest) -> + escape isAlpha f <> LText.concatMap (escape isLegal) rest where + escape :: (Char -> Bool) -> Char -> Text escape p c - | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" + | p c = LText.singleton c + | otherwise = + -- "-" <> show (ord c) <> "-" + LText.cons '-' (LText.pack (show (ord c) <> "-")) + + isLegal :: Char -> Bool isLegal ':' = True isLegal '_' = True isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c + isLegal c = isAscii c && isAlphaNum c -- NB: '-' is legal in IDs, but we use it as the escape char @@ -272,7 +282,7 @@ escapeURIString :: (Char -> Bool) -> String -> String escapeURIString = concatMap . escapeURIChar isUnreserved :: Char -> Bool -isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") +isUnreserved c = isAlphaNumChar c || (c `elem` ("-_.~" :: String)) isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') ===================================== utils/haddock/html-test/ref/Bug26.html ===================================== @@ -53,7 +53,7 @@ >Description</p ><div class="doc" ><p - >This module tests the ‘@since …’ annotation.</p + >This module tests the ‘@since …’ annotation.</p ><p ><em >Since: 1.2.3</em ===================================== utils/haddock/html-test/ref/Bug298.html ===================================== @@ -67,7 +67,7 @@ > :: a -> a -> a</li ><li class="src short" ><a href="#" - >(⋆^)</a + >(⋆^)</a > :: a -> a -> a</li ><li class="src short" ><a href="#" @@ -106,7 +106,7 @@ ><div class="top" ><p class="src" ><a id="v:-8902--94-" class="def" - >(⋆^)</a + >(⋆^)</a > :: a -> a -> a <a href="#" class="selflink" >#</a ></p @@ -134,7 +134,7 @@ ></code > and <code ><a href="#" title="Bug298" - >⋆^</a + >⋆^</a ></code >.</p ></div ===================================== utils/haddock/html-test/ref/Bug458.html ===================================== @@ -55,7 +55,7 @@ ><ul class="details-toggle" data-details-id="syn" ><li class="src short" ><a href="#" - >(⊆)</a + >(⊆)</a > :: () -> () -> ()</li ></ul ></details @@ -66,7 +66,7 @@ ><div class="top" ><p class="src" ><a id="v:-8838-" class="def" - >(⊆)</a + >(⊆)</a > :: () -> () -> () <a href="#" class="selflink" >#</a ></p @@ -75,7 +75,7 @@ >See the defn of <code class="inline-code" ><code ><a href="#" title="Bug458" - >⊆</a + >⊆</a ></code ></code >.</p ===================================== utils/haddock/html-test/ref/Nesting.html ===================================== @@ -317,7 +317,7 @@ with more of the indented list content.</p ><h3 >Level 3 header</h3 ><p - >with some content…</p + >with some content…</p ><ul ><li >and even more lists inside</li ===================================== utils/haddock/html-test/ref/TitledPicture.html ===================================== @@ -105,7 +105,7 @@ ><a href="#" title="TitledPicture" >bar</a ></code - > with title <img src="un∣∁∘" title="δ∈" + > with title <img src="un∣∁∘" title="δ∈" /></p ></div ></div ===================================== utils/haddock/html-test/ref/Unicode.html ===================================== @@ -76,7 +76,7 @@ ></p ><div class="doc" ><p - >γλώσσα</p + >γλώσσα</p ></div ></div ></div ===================================== utils/haddock/html-test/ref/Unicode2.html ===================================== @@ -55,7 +55,7 @@ ><ul class="details-toggle" data-details-id="syn" ><li class="src short" ><a href="#" - >ü</a + >ü</a > :: ()</li ></ul ></details @@ -66,36 +66,36 @@ ><div class="top" ><p class="src" ><a id="v:-252-" class="def" - >ü</a + >ü</a > :: () <a href="#" class="selflink" >#</a ></p ><div class="doc" ><p - >All of the following work with a unicode character ü:</p + >All of the following work with a unicode character ü:</p ><ul ><li >an italicized <em - >ü</em + >ü</em ></li ><li >inline code <code class="inline-code" - >ü</code + >ü</code ></li ><li >a code block:</li ></ul ><pre - >ü</pre + >ü</pre ><ul ><li >a url <a href="#" - >https://www.google.com/search?q=ü</a + >https://www.google.com/search?q=ü</a ></li ><li >a link to <code ><a href="#" title="Unicode2" - >ü</a + >ü</a ></code ></li ></ul View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0043bfb0294273d8440db82a59ba501… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0043bfb0294273d8440db82a59ba501… You're receiving this email because of your account on gitlab.haskell.org.

1 0