- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/romes/ast-ohne-faststring] ttg: Using Text over FastString in the AST
by Rodrigo Mesquita (＠alt-romes) 01 Jul '26

01 Jul '26

Rodrigo Mesquita pushed to branch wip/romes/ast-ohne-faststring at Glasgow Haskell Compiler / GHC Commits: 789bdc71 by Rodrigo Mesquita at 2026-07-01T10:24:46+01:00 ttg: Using Text over FastString in the AST To make the AST independent of GHC, this commit replaces usages of `FastString` with `HText` in the AST, killing the last edge from Language.Haskell.* to GHC.* modules. Even though we /do/ want to use FastStrings in general -- critically in Names or Ids -- there is no particular reason for the FastStrings that occur in the AST proper to be FastStrings. Strings in the AST are typically unique and don't benefit particularly from being interned FastStrings with Uniques for fast comparison. `HText` is a newtype string wrapper around `Text` which uses GHC's Modified UTF-8 encoding exclusively. It is an opaque type, to ensure it is only modified and converted in ways which preserve the Modified UTF-8 encoding in a way that roundtrips (as opposed to losing information, which would happen if using bare `Text`). Modified UTF-8 must be used to represent the Haskell AST because the Haskell Report allows surrogate code points. `Text` operations use UTF-8 proper and replaces surrogates with a placeholder value, thus is unsuitable for the AST directly. See the `Language.Haskell.Syntax.Text` module header for more details. Final progress towards #21592 - - - - - 97 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Data/FastString.hs - compiler/GHC/Data/StringBuffer.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/FieldLabel.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Types/PkgQual.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - + compiler/Language/Haskell/Syntax/Text.hs - compiler/Language/Haskell/Syntax/Type.hs - compiler/ghc.cabal.in - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - + testsuite/tests/parser/should_run/StringStartsWithNull.hs - + testsuite/tests/parser/should_run/StringStartsWithNull.stdout - testsuite/tests/parser/should_run/all.T - testsuite/tests/perf/compiler/hard_hole_fits.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/check-exact.cabal - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/789bdc71ea884f174d85d9ce3846472… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/789bdc71ea884f174d85d9ce3846472… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/windows-dlls] rts/include: annotate all public symbols with RTS_EXPORT
by David Eichmann (＠DavidEichmann) 01 Jul '26

01 Jul '26

David Eichmann pushed to branch wip/davide/windows-dlls at Glasgow Haskell Compiler / GHC Commits: e6bc007e by David Eichmann at 2026-07-01T09:35:53+01:00 rts/include: annotate all public symbols with RTS_EXPORT Add RTS_EXPORT macro (expands to __attribute__((dllexport)) on mingw32, empty elsewhere) to all public function and global data declarations across every header under rts/include/. The macro is defined in Stg.h. Each header that uses it also carries a fallback #ifndef RTS_EXPORT guard so it can be analysed in isolation. Declarations inside #if IN_STG_CODE blocks (raw StgWord/W_ types for Cmm/STG code), INLINE_HEADER/EXTERN_INLINE inline definitions, and RTS_PRIVATE symbols are intentionally left unannotated. AI-generated by Claude Sonnet 4.6 per prompt: "annotate all global data/functions under rts/include with __attribute__((dllexport)) unless explicitly marked as private" Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 51 changed files: - rts/include/HsFFI.h - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - rts/include/rts/Adjustor.h - rts/include/rts/BlockSignals.h - rts/include/rts/EventLogWriter.h - rts/include/rts/ExecPage.h - rts/include/rts/FileLock.h - rts/include/rts/Flags.h - rts/include/rts/ForeignExports.h - rts/include/rts/GetTime.h - rts/include/rts/Globals.h - rts/include/rts/Hpc.h - rts/include/rts/IOInterface.h - rts/include/rts/IPE.h - rts/include/rts/Libdw.h - rts/include/rts/LibdwPool.h - rts/include/rts/Linker.h - rts/include/rts/Messages.h - rts/include/rts/NonMoving.h - rts/include/rts/OSThreads.h - rts/include/rts/Parallel.h - rts/include/rts/PrimFloat.h - rts/include/rts/Profiling.h - rts/include/rts/RtsToHsIface.h - rts/include/rts/SpinLock.h - rts/include/rts/StableName.h - rts/include/rts/StablePtr.h - rts/include/rts/StaticPtrTable.h - rts/include/rts/TSANUtils.h - rts/include/rts/TTY.h - rts/include/rts/Threads.h - rts/include/rts/Ticky.h - rts/include/rts/Time.h - rts/include/rts/Timer.h - rts/include/rts/Utils.h - rts/include/rts/prof/CCS.h - rts/include/rts/prof/Heap.h - rts/include/rts/storage/Block.h - rts/include/rts/storage/ClosureMacros.h - rts/include/rts/storage/GC.h - rts/include/rts/storage/Heap.h - rts/include/rts/storage/HeapAlloc.h - rts/include/rts/storage/InfoTables.h - rts/include/rts/storage/MBlock.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/include/stg/Prim.h - rts/include/stg/SMP.h - rts/include/stg/Ticky.h The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6bc007eb624a7b029a4aaa0172f2d3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6bc007eb624a7b029a4aaa0172f2d3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/no-code-output-constr] Add failing test for `-finfo-table-map` and bytecode backend
by Hannes Siebenhandl (＠fendor) 01 Jul '26

01 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/no-code-output-constr at Glasgow Haskell Compiler / GHC Commits: be6a65cb by fendor at 2026-07-01T09:14:31+02:00 Add failing test for `-finfo-table-map` and bytecode backend If you compile a module using the bytecode backend, with -finfo-table-map, then the info table map doesn't get populated for the module. This is because the -finfo-table-map code path is implemented mostly in the StgToCmm phase which isn't run when creating bytecode. Ticket #27039 - - - - - 5 changed files: - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/bytecodeIPE.hs - + testsuite/tests/ghci/scripts/bytecodeIPE.script - + testsuite/tests/ghci/scripts/bytecodeIPE.stderr - + testsuite/tests/ghci/scripts/bytecodeIPE.stdout Changes: ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -385,6 +385,14 @@ test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script']) test('ListTuplePunsPprNoAbbrevTuple', [limit_stdout_lines(14)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script']) test('T24459', normal, ghci_script, ['T24459.script']) test('T24632', normal, ghci_script, ['T24632.script']) +# bytecode backend doesn't support '-finfo-table-map' (#27039) +test('bytecodeIPE', + [ extra_hc_opts('-finfo-table-map') + , extra_files(['bytecodeIPE.hs']) + , req_rts_linker + , when(arch('wasm32') or arch('javascript'), skip) + ], + ghci_script, ['bytecodeIPE.script']) # Test package renaming in GHCi session test('GhciPackageRename', ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.hs ===================================== @@ -0,0 +1,12 @@ +module BytecodeIPE where + +import Data.Maybe (isJust) +import GHC.InfoProv (whereFrom) + +marker :: String +marker = id "bytecode-stub-init" +{-# NOINLINE marker #-} + +-- `whereFrom` only succeeds if the module's IPE initializer ran. +probe :: IO Bool +probe = isJust <$> whereFrom marker ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.script ===================================== @@ -0,0 +1,2 @@ +:load bytecodeIPE.hs +probe ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.stderr ===================================== @@ -0,0 +1,2 @@ +when making flags consistent: warning: [GHC-74335] [-Winconsistent-flags (in -Wdefault)] + -finfo-table-map is incompatible with -fbyte-code and is disabled ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.stdout ===================================== @@ -0,0 +1 @@ +False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be6a65cbad150c3138b20969ef255f0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be6a65cbad150c3138b20969ef255f0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler: fix missing handling of CmmUnsafeForeignCall node in LayoutStack
by Marge Bot (＠marge-bot) 01 Jul '26

01 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3f00f234 by Cheng Shao at 2026-06-30T21:40:32-04:00 compiler: fix missing handling of CmmUnsafeForeignCall node in LayoutStack This patch fixes missing handling of `CmmUnsafeForeignCall` middle node in the `LayoutStack` pass. Before proc-points splitting, this pass computes liveliness of local registers, and spills those alive across a Cmm native call onto the stack. It need to traverse all middle nodes in each block and check whether a local register is an assignee, if so then the previous mapping in `sm_regs` is invalidated and needs to be dropped. However, it didn't handle `CmmUnsafeForeignCall` node which may also assign to a local register. When proc-points splitting is enabled, this can produce an invalid basic block that doesn't properly backup the updated local register to the stack before doing a Cmm call, resulting in completely invalid runtime behavior. The patch also adds a `T27447` regression test. With no-TNTC or with LLVM backend, without the fix the test case would output a stale 0x1111111111111111 value, instead of the expected 0x2222222222222222 output. Fixes #27447. Co-authored-by: Codex <codex(a)openai.com> - - - - - 6 changed files: - + changelog.d/fix-layout-stack-fcall - compiler/GHC/Cmm/LayoutStack.hs - + testsuite/tests/cmm/should_run/T27447.hs - + testsuite/tests/cmm/should_run/T27447.stdout - + testsuite/tests/cmm/should_run/T27447_cmm.cmm - testsuite/tests/cmm/should_run/all.T Changes: ===================================== changelog.d/fix-layout-stack-fcall ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Fix invalid cmm basic block output when proc-point splitting is enabled (wasm/llvm/unregisterised) +issues: #27447 +mrs: !16271 ===================================== compiler/GHC/Cmm/LayoutStack.hs ===================================== @@ -408,6 +408,8 @@ procMiddle stackmaps node sm where loc = getStackLoc area off stackmaps CmmAssign (CmmLocal r) _other -> sm { sm_regs = delFromUFM (sm_regs sm) r } + CmmUnsafeForeignCall _ results _ + -> sm { sm_regs = delListFromUFM (sm_regs sm) results } _other -> sm ===================================== testsuite/tests/cmm/should_run/T27447.hs ===================================== @@ -0,0 +1,40 @@ +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +import Foreign +import GHC.Exts +import GHC.IO +import GHC.Word +import Text.Printf + +foreign import prim "t27447_repro" + t27447_repro# :: Addr# -> State# RealWorld -> (# State# RealWorld, Word64# #) + +expected :: Word64 +expected = 0x2222222222222222 + +stale :: Word64 +stale = 0x1111111111111111 + +runCmm :: Ptr a -> IO Word64 +runCmm (Ptr p#) = IO $ \s -> + case t27447_repro# p# s of + (# s', w# #) -> (# s', W64# w# #) + +main :: IO () +main = allocaBytesAligned 48 8 $ \raw -> do + let node0 = raw + node1 = raw `plusPtr` 24 + + pokeByteOff node0 0 (1 :: Word64) + pokeByteOff node0 8 node1 + pokeByteOff node0 16 stale + + pokeByteOff node1 0 (0 :: Word64) + pokeByteOff node1 8 node1 + pokeByteOff node1 16 expected + + got <- runCmm node0 + printf "0x%016x\n" got ===================================== testsuite/tests/cmm/should_run/T27447.stdout ===================================== @@ -0,0 +1 @@ +0x2222222222222222 ===================================== testsuite/tests/cmm/should_run/T27447_cmm.cmm ===================================== @@ -0,0 +1,24 @@ +#include "Cmm.h" + +t27447_repro (W_ x) { + I64 ty; + W_ old; + +again: + ty = I64[x]; + switch [0 .. 2] (ty) { + case 0: { + return (I64[x + 16]); + } + case 1: { + old = x; + x = %acquire W_[x + 8]; + I64[old] = 0; + goto again; + } + case 2: { + STK_CHK_GEN(); + goto again; + } + } +} ===================================== testsuite/tests/cmm/should_run/all.T ===================================== @@ -33,7 +33,7 @@ test('T22871', test('JumpTableNoStackDealloc', [ extra_run_opts('"' + config.libdir + '"') - , req_cmm + , req_cmm , when(arch('wasm32'), skip) # wasm32 doesn't support the printf() calls , when(arch('i386'), skip) # i386 doesn't support `MO_U_Rem W64` (`_c1::I64 % 10 :: W64`) ], @@ -52,3 +52,11 @@ test('T25601', [req_cmm], multi_compile_and_run, ['T25601', [('T25601a.cmm', '')], '']) + +test('T27447', + [ req_cmm + , extra_ways(['optasm']) + , when(have_llvm(), extra_ways(['optasm', 'optllvm'])) + ], + multi_compile_and_run, + ['T27447', [('T27447_cmm.cmm', '')], '']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f00f234d0d5b3b3b2a23a5dc70ce37… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f00f234d0d5b3b3b2a23a5dc70ce37… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian/rts: fix unregisterised build for gcc 15+
by Marge Bot (＠marge-bot) 01 Jul '26

01 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e22ad997 by Cheng Shao at 2026-06-30T21:39:43-04:00 hadrian/rts: fix unregisterised build for gcc 15+ This patch fixes unregisterised build for gcc 15+: - Pass -optc-Wno-error in hadrian when +werror enables -optc-Werror, see added comment for details. - For RTS functions that the codegen would emit calls, ensure their real prototype is hidden when the header is included in .hc fies (IN_STG_CODE), and the dummy prototype is provided to match the EFF_ convention. In the future we should get rid of EFF_ (#14647) and remove these hacks, but for now this patch makes unregisterised work again on newer toolchains. Fixes #27404. Co-authored-by: Codex <codex(a)openai.com> - - - - - 4 changed files: - + changelog.d/fix-unreg - hadrian/src/Flavour.hs - rts/include/rts/NonMoving.h - rts/include/stg/MiscClosures.h Changes: ===================================== changelog.d/fix-unreg ===================================== @@ -0,0 +1,4 @@ +section: packaging +synopsis: Fix unregisterised build for gcc 15+ +issues: #27404 +mrs: !16264 ===================================== hadrian/src/Flavour.hs ===================================== @@ -35,7 +35,9 @@ import Data.Either import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as Set +import GHC.Toolchain.Target import Oracles.Flag +import Oracles.Setting import Packages import Flavour.Type import Settings.Parser @@ -140,8 +142,9 @@ addArgs args' fl = fl { extraArgs = extraArgs fl <> args' } -- in unix and/or hsc2hs to make cross-compiling unix completely free -- from warnings. werror :: Flavour -> Flavour -werror = - addArgs $ mconcat +werror = addArgs $ do + stage <- getStage + mconcat [ builder Ghc ? notStage0 ? mconcat @@ -159,6 +162,15 @@ werror = , arg "-optc-Wno-error=unknown-pragmas" -- rejected inlinings are highly dependent upon toolchain and way , arg "-optc-Wno-error=inline" + -- when building unregisterised, gcc 15+ complains "error: + -- function called through a non-compatible type" with + -- -Werror (#27404). no corresponding -Wno-foo for it so + -- -Wno-error is needed. + -- + -- TODO: get rid of EFF_ altogether (#14647) and make sure + -- unregisterised backend emits clean C without needing + -- these hacks. + , queryTargetTarget stage tgtUnregisterised ? arg "-optc-Wno-error" ] -- N.B. We currently don't build the boot libraries' C sources with -Werror -- as this tends to be a portability nightmare. ===================================== rts/include/rts/NonMoving.h ===================================== @@ -18,6 +18,14 @@ struct StgClosure_; struct StgThunk_; struct Capability_; +#if IN_STG_CODE + +EFF_(updateRemembSetPushClosure_); + +EFF_(updateRemembSetPushThunk_); + +#else + /* This is called by the code generator */ extern void updateRemembSetPushClosure_(StgRegTable *reg, struct StgClosure_ *p); @@ -25,6 +33,8 @@ void updateRemembSetPushClosure_(StgRegTable *reg, struct StgClosure_ *p); extern void updateRemembSetPushThunk_(StgRegTable *reg, struct StgThunk_ *p); +#endif + // Forward declaration for unregisterised backend. EF_(stg_copyArray_barrier); ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -617,7 +617,11 @@ extern StgWord CCS_SYSTEM[]; // 'GHC.StgToCmm.Prof' // as opposed to real prototype declared in // 'rts/include/rts/prof/CCS.h' +#if IN_STG_CODE +EFF_(enterFunCCS); +#else void enterFunCCS (void *reg, void *ccsfn); +#endif void * pushCostCentre (void *ccs, void *cc); // Capability.c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e22ad9972091e29ae56ed77686d3c8f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e22ad9972091e29ae56ed77686d3c8f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] generically defines mconcat in terms of internal type's Semigroup instance
by Marge Bot (＠marge-bot) 01 Jul '26

01 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4262af36 by L0neGamer at 2026-06-30T21:38:56-04:00 generically defines mconcat in terms of internal type's Semigroup instance add changelog entry use simpler definition for mconcat `nonEmpty` isn't available yet; inline branches in case add test case fixup generically defines mconcat in terms of internal type's Semigroup instance add comment on Generically and deriving mishaps swap mconcat to foldr version add some strictness testing for mconcat add to `base` changelog entry - - - - - 9 changed files: - + changelog.d/generically-mconcat - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Generics.hs - + testsuite/tests/generics/T27245.hs - + testsuite/tests/generics/T27245.stdout - testsuite/tests/generics/all.T - 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 Changes: ===================================== changelog.d/generically-mconcat ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Add definition for Generically's `mconcat` in terms of the type variable's Semigroup instance instead of using the generically derived version. +issues: #27245 +mrs: !16011 ===================================== libraries/base/changelog.md ===================================== @@ -6,6 +6,7 @@ * Add `Data.List.NonEmpty.{zip{3..7},zipWith{3..7},unzip{3..7}}` ([CLC proposal #409)(https://github.com/haskell/core-libraries-committee/issues/409)) * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378)) + * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Generics.hs ===================================== @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-} - {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} @@ -744,7 +742,7 @@ import GHC.Internal.Types hiding (Any) -- clashes with the Semigroup import GHC.Internal.Ix ( Ix ) import GHC.Internal.Base ( Alternative(..), Applicative(..), Functor(..) , Monad(..), MonadPlus(..), NonEmpty(..), String - , Semigroup(..), Void ) + , Semigroup(..), Void) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Classes ( Eq(..), Ord(..) ) import GHC.Internal.Enum ( Bounded, Enum ) @@ -1437,6 +1435,10 @@ class Generic1 (f :: k -> Type) where -- type/ like 'Generically' decouples the instance from the type -- class. -- +-- Note that if you don't generate parent and child instances using the same +-- method, the result may be incongruous; for example, in previous versions +-- `mconcat` didn't use the correct `(<>)`, instead preferring a Generic version. +-- -- @since base-4.17.0.0 newtype Generically a = Generically a @@ -1446,12 +1448,14 @@ instance (Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where Generically a <> Generically b = Generically (to (from a <> from b :: Rep a ())) -- | @since base-4.17.0.0 -instance (Generic a, Monoid (Rep a ())) => Monoid (Generically a) where +instance (Generic a, Semigroup a, Monoid (Rep a ())) => Monoid (Generically a) where mempty :: Generically a mempty = Generically (to (mempty :: Rep a ())) - mappend :: Generically a -> Generically a -> Generically a - mappend = (<>) + -- https://github.com/haskell/core-libraries-committee/issues/324 + mconcat :: [Generically a] -> Generically a + mconcat = foldr (coerce @(a -> a -> a) (<>)) mempty + {-# INLINE mconcat #-} -- | A type whose instances are defined generically, using the -- 'Generic1' representation. 'Generically1' is a higher-kinded ===================================== testsuite/tests/generics/T27245.hs ===================================== @@ -0,0 +1,87 @@ + +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import GHC.Generics +import Data.Coerce +import Data.Semigroup +import Data.List.NonEmpty qualified as NE +import Control.Exception + +main :: IO () +main = do + let l1 = L [1] + l2 = L [2] + -- check append functions; this is a regression test for later down the line + print ("sappend", l1 <> l2) + print ("mappend", l1 `mappend` l2) + print ("gappend", l1 `gappend` l2) + -- when `mappend` is removed from `Monoid`, `mappend`'s definition will be + -- `mappend = (<>)` at the top level, removing the above `mappend = gappend` issue + + -- check concat functions + -- We have the defined method functions, the generic variants, and the + -- default implementations written out again + let ls = [l1, l2] + lsNE = l1 NE.:| [l2] + print ("sconcat", sconcat lsNE) + print ("mconcat", mconcat ls) + print ("gsconcat", gsconcat lsNE) + print ("gmconcat", gmconcat ls) + print ("dsconcat", dsconcat lsNE) + print ("dmconcatMappend", dmconcatMappend ls) -- uses `mappend` which is incorrect, see above + print ("dmconcatSappend", dmconcatSappend ls) + print ("dmconcatUsingSconcat", dmconcatUsingSconcat ls) + + let undefinedList = l1 : undefined + fOn s f = print ("strictness " <> s, f undefinedList) + (fOn "mconcat" mconcat `finally` -- derived instance is fine, shows + fOn "gmconcat" gmconcat `finally` -- this is too strict - using mappend on lists needs all lists + fOn "dmconcatMappend" dmconcatMappend `finally` -- also too strict for the above + fOn "dmconcatSappend" dmconcatSappend `finally` -- correct strictness, shows + fOn "dmconcatUsingSconcat" dmconcatUsingSconcat -- sconcat is too strict as well + ) `catch` \(_ :: SomeException) -> pure () + +newtype L a = L [a] + deriving (Generic, Show, Eq) + deriving Monoid via (Generically (L a)) + +-- semigroup instance not derived with Generically, so it could be mis-aligned +-- with generic monoid definition +instance Semigroup (L a) where + L [] <> l = l + l <> _ = l + +-- generic (<>) +gappend :: forall a . (Generic a, Semigroup (Rep a ())) => a -> a -> a +gappend a b = to (from a <> from b :: Rep a ()) + +-- generic sconcat +gsconcat :: forall a . (Generic a, Semigroup (Rep a ())) => NE.NonEmpty a -> a +gsconcat = to . sconcat @(Rep a ()) . fmap from + +-- generic mconcat +gmconcat :: forall a . (Generic a, Monoid (Rep a ())) => [a] -> a +gmconcat = to . mconcat @(Rep a ()) . fmap from + +-- default sconcat +dsconcat :: forall a . Semigroup a => NE.NonEmpty a -> a +dsconcat (a NE.:| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + +-- default mconcat using mappend +dmconcatMappend :: Monoid a => [a] -> a +dmconcatMappend = foldr mappend mempty + +-- default mconcat using (<>), also the new generically impl +dmconcatSappend :: Monoid a => [a] -> a +dmconcatSappend = foldr (<>) mempty + +-- incorrect impl, too strict in the spine +dmconcatUsingSconcat :: Monoid a => [a] -> a +dmconcatUsingSconcat as = case as of + [] -> mempty + x : xs -> sconcat (x NE.:| xs) ===================================== testsuite/tests/generics/T27245.stdout ===================================== @@ -0,0 +1,13 @@ +("sappend",L [1]) +("mappend",L [1,2]) +("gappend",L [1,2]) +("sconcat",L [1]) +("mconcat",L [1]) +("gsconcat",L [1,2]) +("gmconcat",L [1,2]) +("dsconcat",L [1]) +("dmconcatMappend",L [1,2]) +("dmconcatSappend",L [1]) +("dmconcatUsingSconcat",L [1]) +("strictness mconcat",L [1]) +("strictness dmconcatSappend",L [1]) ===================================== testsuite/tests/generics/all.T ===================================== @@ -50,3 +50,4 @@ test('T19819', normal, compile_and_run, ['']) test('T21185', normal, compile, ['']) test('T25148a', normal, compile, ['']) test('T25148b', normal, compile, ['']) +test('T27245', normal, compile_and_run, ['']) ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11056,7 +11056,7 @@ instance GHC.Internal.Base.Monoid ghc-internal-10.100.0:GHC.Internal.Event.Inter instance GHC.Internal.Base.Monoid ghc-internal-10.100.0:GHC.Internal.Event.Internal.Types.Lifetime -- Defined in ‘ghc-internal-10.100.0:GHC.Internal.Event.Internal.Types’ instance forall k (f :: k -> *) (p :: k) (g :: k -> *). (GHC.Internal.Base.Monoid (f p), GHC.Internal.Base.Monoid (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Base.Monoid (f (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ -instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ +instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Semigroup a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ instance forall k c i (p :: k). GHC.Internal.Base.Monoid c => GHC.Internal.Base.Monoid (GHC.Internal.Generics.K1 i c p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (p :: k) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Base.Monoid (f p) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.M1 i c f p) -- Defined in ‘GHC.Internal.Generics’ instance forall p. GHC.Internal.Base.Monoid p => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Par1 p) -- Defined in ‘GHC.Internal.Generics’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -11091,7 +11091,7 @@ instance forall m. GHC.Internal.Base.Monoid m => GHC.Internal.Base.Monoid (Data. instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Base.Monoid (GHC.Internal.STM.STM a) -- Defined in ‘GHC.Internal.STM’ instance forall k (f :: k -> *) (p :: k) (g :: k -> *). (GHC.Internal.Base.Monoid (f p), GHC.Internal.Base.Monoid (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Base.Monoid (f (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ -instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ +instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Semigroup a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ instance forall k c i (p :: k). GHC.Internal.Base.Monoid c => GHC.Internal.Base.Monoid (GHC.Internal.Generics.K1 i c p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (p :: k) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Base.Monoid (f p) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.M1 i c f p) -- Defined in ‘GHC.Internal.Generics’ instance forall p. GHC.Internal.Base.Monoid p => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Par1 p) -- Defined in ‘GHC.Internal.Generics’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11316,7 +11316,7 @@ instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Base.Monoid (GHC.I instance GHC.Internal.Base.Monoid GHC.Internal.Event.Windows.EventData -- Defined in ‘GHC.Internal.Event.Windows’ instance forall k (f :: k -> *) (p :: k) (g :: k -> *). (GHC.Internal.Base.Monoid (f p), GHC.Internal.Base.Monoid (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Base.Monoid (f (g p)) => GHC.Internal.Base.Monoid ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ -instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ +instance forall a. (GHC.Internal.Generics.Generic a, GHC.Internal.Base.Semigroup a, GHC.Internal.Base.Monoid (GHC.Internal.Generics.Rep a ())) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Generically a) -- Defined in ‘GHC.Internal.Generics’ instance forall k c i (p :: k). GHC.Internal.Base.Monoid c => GHC.Internal.Base.Monoid (GHC.Internal.Generics.K1 i c p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (p :: k) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Base.Monoid (f p) => GHC.Internal.Base.Monoid (GHC.Internal.Generics.M1 i c f p) -- Defined in ‘GHC.Internal.Generics’ instance forall p. GHC.Internal.Base.Monoid p => GHC.Internal.Base.Monoid (GHC.Internal.Generics.Par1 p) -- Defined in ‘GHC.Internal.Generics’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4262af3664e29b681753276203dc447… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4262af3664e29b681753276203dc447… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Make Q abstract
by Marge Bot (＠marge-bot) 01 Jul '26

01 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7bf9e3c5 by Teo Camarasu at 2026-06-30T21:38:03-04:00 Make Q abstract This patch aims to clearly demarcate the internal and external interfaces of Q. In the past the `Quasi` typeclass was both part of the external, public-facing interface, and was used to give the implementation of `Q`. Now we separate out these two distinct roles. `Quasi` continues to exist in the public interface, but we introduce a new `MetaHandlers` type, which is equivalent to `Dict Quasi`. `Q a` is now defined to be `MetaHandlers -> IO a`, and, crucially, the constructor and the new `MetaHandlers` type are not exposed from the public interface. This gives us the ability to vary the interface on the GHC side without forcing a breaking change on the `template-haskell` side. Similarly `template-haskell` has more freedom to change the `Quasi` typeclass without needing any changes in `lib:ghc`. Implements https://github.com/ghc-proposals/ghc-proposals/pull/700 Resolves #27341 - - - - - 9 changed files: - + changelog.d/AbstractQ - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs-boot - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== changelog.d/AbstractQ ===================================== @@ -0,0 +1,9 @@ +section: template-haskell +synopsis: Hide the implementation of Q +description: The constructor of Q is now hidden. + This is done to improve the stability of ``template-haskell``. + To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``. + The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API. + See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details. +mrs: !15696 +issues: #27341 ===================================== compiler/GHC/Data/IOEnv.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Data.IOEnv ( IOEnvFailure(..), -- Getting at the environment - getEnv, setEnv, updEnv, updEnvIO, + getEnv, setEnv, updEnv, updEnvIO, withRunInIO, runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, tryM, tryAllM, tryMostM, fixM, @@ -258,3 +258,12 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnvIO #-} updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) + +-- | 'withRunInIO' specialised to `IOEnv`. +-- See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unl… for an explanation. +withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b +withRunInIO k = IOEnv $ \env -> + let + unlift :: forall a. IOEnv env a -> IO a + unlift (IOEnv m) = m env + in k unlift ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket, runAnnotation, getUntypedSpliceBody, - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, finishTH, runTopSplice @@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt -- THSyntax gives access to internal functions and data types import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH +import GHC.Boot.TH.Monad (MetaHandlers(..)) import qualified GHC.Boot.TH.Ppr as TH #if defined(HAVE_INTERNAL_INTERPRETER) @@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do ************************************************************************ -} -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act +runQinTcM :: TH.Q a -> TcM a +runQinTcM (TH.Q act) = withRunInIO $ \runInIO -> act (metaHandlersTcM runInIO) runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs + runQinTcM $ sequence_ qs #endif ExternalInterp ext -> withExtInterp ext $ \inst -> do @@ -1466,70 +1467,14 @@ when showing an error message. To call runQ in the Tc monad, we need to make TcM an instance of Quasi: -} -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } +-- 'msg' is forced to ensure exceptions don't escape, +-- see Note [Exceptions in TH] +report :: Bool -> [Char] -> TcM () +report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - - qLocation :: TcM TH.Loc - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - RealSrcSpan s _ -> return s - GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" - (pprGeneratedSrcSpanDetails) - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitString (moduleUnit m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qGetPackageRoot = do - dflags <- getDynFlags - return $ fromMaybe "." (workingDirectory dflags) - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddDependentDirectory dp = do - ref <- fmap tcg_dependent_dirs getGblEnv - dep_dirs <- readTcRef ref - writeTcRef ref (dp:dep_dirs) - - qAddTempFile suffix = do - dflags <- getDynFlags - logger <- getLogger - tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - - qAddTopDecls thds = do +addTopDecls :: [TH.Dec] -> TcM () +addTopDecls thds = do exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin @@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where bindName :: RdrName -> TcM () bindName (Exact n) = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnTHError $ AddInvalidCorePlugin plugin - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - - qPutDoc doc_loc s = do +putDoc :: TH.DocLoc -> String -> TcM () +putDoc doc_loc s = do th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc @@ -1624,15 +1530,131 @@ instance TH.Quasi TcM where checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n checkLocalName ModuleDoc = pure True - - qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc - qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc - qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i - qGetDoc TH.ModuleDoc = do +getDoc :: TH.DocLoc -> TcM (Maybe String) +getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc +getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc +getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i +getDoc TH.ModuleDoc = do df <- getDynFlags docs <- getGblEnv >>= extractDocs df return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) +getQ :: forall a. Typeable a => TcM (Maybe a) +getQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + +location :: TcM TH.Loc +location = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" + (pprGeneratedSrcSpanDetails) + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + +metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers +metaHandlersTcM runInIO = TH.MetaHandlers { + mLiftIO = id + -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error. + , mFail = \s -> runInIO $ fail @TcM s + , mNewName = \s -> runInIO $ do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + , mReport = fmap runInIO . report + + , mLocation = runInIO location + + , mLookupName = fmap runInIO . lookupName + , mReify = runInIO . reify + , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity + , mReifyType = runInIO . reifyTypeOfThing + , mReifyInstances = fmap runInIO . reifyInstances + , mReifyRoles = runInIO . reifyRoles + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = runInIO . reifyModule + , mReifyConStrictness = \nm -> runInIO $ do + { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main) + + , mGetPackageRoot = runInIO $ do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + , mAddDependentFile = \fp -> runInIO $ do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + , mAddDependentDirectory = \dp -> runInIO $ do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + + , mAddTempFile = \suffix -> runInIO $ do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + , mAddTopDecls = runInIO . addTopDecls + + , mAddForeignFilePath = \lang fp -> runInIO $ do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + , mAddModFinalizer = \fin -> runInIO $ do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + , mAddCorePlugin = \plugin -> runInIO $ do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnTHError $ AddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + , mGetQ = runInIO getQ + + , mPutQ = \x -> runInIO $ do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + , mIsExtEnabled = runInIO . xoptM + + , mExtsEnabled = runInIO $ + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + , mPutDoc = fmap runInIO . putDoc + + , mGetDoc = runInIO . getDoc + } + -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) @@ -1788,7 +1810,7 @@ runTH ty fhv = do InternalInterp -> do -- Run it in the local TcM hv <- liftIO $ wormhole interp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) + r <- runQinTcM (unsafeCoerce hv :: TH.Q a) return r #endif @@ -1797,7 +1819,7 @@ runTH ty fhv = do -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. rstate <- getTHState inst - loc <- TH.qLocation + loc <- location -- run a remote TH request r <- liftIO $ withForeignRef rstate $ \state_hv -> @@ -1913,32 +1935,32 @@ wrapTHResult tcm = do handleTHMessage :: THMessage a -> TcM a handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + NewName a -> wrapTHResult $ runQinTcM $ TH.newName a + Report b str -> wrapTHResult $ runQinTcM $ TH.report b str + LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str + Reify n -> wrapTHResult $ runQinTcM $ TH.reify n + ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n + ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n + ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts + ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n ReifyAnnotations lookup tyrep -> wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m + ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm + GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot + AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f + AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d + AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s AddModFinalizer r -> do interp <- hscInterp <$> getTopEnv wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - PutDoc l s -> wrapTHResult $ TH.qPutDoc l s - GetDoc l -> wrapTHResult $ TH.qGetDoc l + AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str + AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext + ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled + PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s + GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) ===================================== compiler/GHC/Tc/Gen/Splice.hs-boot ===================================== @@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs) runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a +runQinTcM :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec withDecDoc doc dec = do dec' <- dec case doc_loc dec' of - Just loc -> qAddModFinalizer $ qPutDoc loc doc + Just loc -> addModFinalizer $ putDoc loc doc Nothing -> pure () pure dec' where @@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause] -> [Maybe String] -- ^ Documentation to attach to arguments -> Q Dec funD_doc nm cs mfun_doc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs] let dec = funD nm cs case mfun_doc of @@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the newtype declaration -> Q Dec newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeD ctxt tc tvs ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec typeDataD_doc tc tvs ksig cons_with_docs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) maybe dec (flip withDecDoc dec) mdoc @@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind) -- ^ Documentation to attach to the instance declaration -> Q Dec dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -- ^ Documentation to attach to the instance declaration -> Q Dec newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> [Maybe String] -- ^ Documentation to attach to the pattern arguments -> Q Dec patSynD_doc name args dir pat mdoc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs] let dec = patSynD name args dir pat maybe dec (flip withDecDoc dec) mdoc ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO (FilePath, hPutStrLn, stderr) +import System.IO (hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String, - flip, id, (.), (++), + flip, id, (.), (++), ($), ) import GHC.Internal.Classes (not) import GHC.Internal.Data.Data hiding (Fixity(..)) @@ -59,145 +59,150 @@ import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions import GHC.Internal.TH.Syntax ------------------------------------------------------ --- --- The Quasi class --- ------------------------------------------------------ - -class (MonadIO m, MonadFail m) => Quasi m where - -- | Fresh names. See 'newName'. - qNewName :: String -> m Name - - ------- Error reporting and recovery ------- - -- | Report an error (True) or warning (False) - -- ...but carry on; use 'fail' to stop. See 'report'. - qReport :: Bool -> String -> m () - - -- | See 'recover'. - qRecover :: m a -- ^ the error handler - -> m a -- ^ action which may fail - -> m a -- ^ Recover from the monadic 'fail' - - ------- Inspect the type-checker's environment ------- - -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. - qLookupName :: Bool -> String -> m (Maybe Name) - -- | See 'reify'. - qReify :: Name -> m Info - -- | See 'reifyFixity'. - qReifyFixity :: Name -> m (Maybe Fixity) - -- | See 'reifyType'. - qReifyType :: Name -> m Type - -- | Is (n tys) an instance? Returns list of matching instance Decs (with - -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. - qReifyInstances :: Name -> [Type] -> m [Dec] - -- | See 'reifyRoles'. - qReifyRoles :: Name -> m [Role] - -- | See 'reifyAnnotations'. - qReifyAnnotations :: Data a => AnnLookup -> m [a] - -- | See 'reifyModule'. - qReifyModule :: Module -> m ModuleInfo - -- | See 'reifyConStrictness'. - qReifyConStrictness :: Name -> m [DecidedStrictness] - - -- | See 'location'. - qLocation :: m Loc - - -- | Input/output (dangerous). See 'runIO'. - qRunIO :: IO a -> m a - qRunIO = liftIO - -- | See 'getPackageRoot'. - qGetPackageRoot :: m FilePath - - -- | See 'addDependentFile'. - qAddDependentFile :: FilePath -> m () - - -- | See 'addDependentDirectory'. - qAddDependentDirectory :: FilePath -> m () - - -- | See 'addTempFile'. - qAddTempFile :: String -> m FilePath - - -- | See 'addTopDecls'. - qAddTopDecls :: [Dec] -> m () - - -- | See 'addForeignFilePath'. - qAddForeignFilePath :: ForeignSrcLang -> String -> m () - - -- | See 'addModFinalizer'. - qAddModFinalizer :: Q () -> m () - - -- | See 'addCorePlugin'. - qAddCorePlugin :: String -> m () - - -- | See 'getQ'. - qGetQ :: Typeable a => m (Maybe a) - - -- | See 'putQ'. - qPutQ :: Typeable a => a -> m () - - -- | See 'isExtEnabled'. - qIsExtEnabled :: Extension -> m Bool - -- | See 'extsEnabled'. - qExtsEnabled :: m [Extension] - - -- | See 'putDoc'. - qPutDoc :: DocLoc -> String -> m () - -- | See 'getDoc'. - qGetDoc :: DocLoc -> m (Maybe String) +-- | 'MetaHandlers' defines the interface between GHC and TH splices. +-- This is an internal interface between two parts of the compiler, +-- and should never be directly exposed to users. +-- +-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH. +-- With time the two interfaces may drift apart. +-- +-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid +-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion. +-- +-- For more information about the historical design of this interface, +-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700 +data MetaHandlers = MetaHandlers { + -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO' + mLiftIO :: forall a. IO a -> IO a + , mFail :: forall a. String -> IO a + -- | Fresh names. See 'newName'. + , mNewName :: String -> IO Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + , mReport :: Bool -> String -> IO () + + -- | See 'recover'. + , mRecover :: forall a. Q a -- ^ the error handler + -> Q a -- ^ action which may fail + -> IO a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + , mLookupName :: Bool -> String -> IO (Maybe Name) + -- | See 'reify'. + , mReify :: Name -> IO Info + -- | See 'reifyFixity'. + , mReifyFixity :: Name -> IO (Maybe Fixity) + -- | See 'reifyType'. + , mReifyType :: Name -> IO Type + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + , mReifyInstances :: Name -> [Type] -> IO [Dec] + -- | See 'reifyRoles'. + , mReifyRoles :: Name -> IO [Role] + -- | See 'reifyAnnotations'. + , mReifyAnnotations :: forall a. Data a => AnnLookup -> IO [a] + -- | See 'reifyModule'. + , mReifyModule :: Module -> IO ModuleInfo + -- | See 'reifyConStrictness'. + , mReifyConStrictness :: Name -> IO [DecidedStrictness] + + -- | See 'location'. + , mLocation :: IO Loc + + -- | See 'getPackageRoot'. + , mGetPackageRoot :: IO FilePath + + -- | See 'addDependentFile'. + , mAddDependentFile :: FilePath -> IO () + + -- | See 'addDependentDirectory'. + , mAddDependentDirectory :: FilePath -> IO () + + -- | See 'addTempFile'. + , mAddTempFile :: String -> IO FilePath + + -- | See 'addTopDecls'. + , mAddTopDecls :: [Dec] -> IO () + + -- | See 'addForeignFilePath'. + , mAddForeignFilePath :: ForeignSrcLang -> String -> IO () + + -- | See 'addModFinalizer'. + , mAddModFinalizer :: Q () -> IO () + + -- | See 'addCorePlugin'. + , mAddCorePlugin :: String -> IO () + + -- | See 'getQ'. + , mGetQ :: forall a. Typeable a => IO (Maybe a) + + -- | See 'putQ'. + , mPutQ :: forall a. Typeable a => a -> IO () + + -- | See 'isExtEnabled'. + , mIsExtEnabled :: Extension -> IO Bool + -- | See 'extsEnabled'. + , mExtsEnabled :: IO [Extension] + + -- | See 'putDoc'. + , mPutDoc :: DocLoc -> String -> IO () + -- | See 'getDoc'. + , mGetDoc :: DocLoc -> IO (Maybe String) + } ------------------------------------------------------ --- The IO instance of Quasi ------------------------------------------------------ +badIO :: String -> IO a +badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad") + ; fail "Template Haskell failure" } --- | This instance is used only when running a Q --- computation in the IO monad, usually just to --- print the result. There is no interesting --- type environment, so reification isn't going to --- work. -instance Quasi IO where - qNewName = newNameIO - - qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyType _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qReifyConStrictness _ = badIO "reifyConStrictness" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qGetPackageRoot = badIO "getProjectRoot" - qAddDependentFile _ = badIO "addDependentFile" - qAddTempFile _ = badIO "addTempFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFilePath _ _ = badIO "addForeignFilePath" - qAddModFinalizer _ = badIO "addModFinalizer" - qAddCorePlugin _ = badIO "addCorePlugin" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" - qPutDoc _ _ = badIO "putDoc" - qGetDoc _ = badIO "getDoc" - qAddDependentDirectory _ = badIO "AddDependentDirectory" +metaHandlersIO :: MetaHandlers +metaHandlersIO = MetaHandlers { + mLiftIO = id + , mFail = fail + , mNewName = newNameIO + , mReport = \b msg -> + if b then + hPutStrLn stderr ("Template Haskell error: " ++ msg) + else + hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above? + , mLookupName = \ _ _ -> badIO "lookupName" + , mReify = \_ -> badIO "reify" + , mReifyFixity = \_ -> badIO "reifyFixity" + , mReifyType = \_ -> badIO "reifyFixity" + , mReifyInstances = \_ _ -> badIO "reifyInstances" + , mReifyRoles = \_ -> badIO "reifyRoles" + , mReifyAnnotations = \_ -> badIO "reifyAnnotations" + , mReifyModule = \_ -> badIO "reifyModule" + , mReifyConStrictness = \_ -> badIO "reifyConStrictness" + , mLocation = badIO "currentLocation" + , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this? + , mGetPackageRoot = badIO "getProjectRoot" + , mAddDependentFile = \_ -> badIO "addDependentFile" + , mAddTempFile = \_ -> badIO "addTempFile" + , mAddTopDecls = \_ -> badIO "addTopDecls" + , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath" + , mAddModFinalizer = \_ -> badIO "addModFinalizer" + , mAddCorePlugin = \_ -> badIO "addCorePlugin" + , mGetQ = badIO "getQ" + , mPutQ = \_ -> badIO "putQ" + , mIsExtEnabled = \_ -> badIO "isExtEnabled" + , mExtsEnabled = badIO "extsEnabled" + , mPutDoc = \_ _ -> badIO "putDoc" + , mGetDoc = \_ -> badIO "getDoc" + , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory" + } instance Quote IO where newName = newNameIO + + newNameIO :: String -> IO Name newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } -badIO :: String -> IO a -badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") - ; fail "Template Haskell failure" } - -- Global variable to generate unique symbols counter :: IORef Uniq {-# NOINLINE counter #-} @@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0) -- ----------------------------------------------------- --- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the --- user. --- --- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad. --- The perceptive reader notices that 'Quasi' has only two instances, 'Q' --- itself and 'IO', neither of which have concrete implementations.'Q' plays --- the trick of [dependency --- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle), --- providing an abstract interface for the user which is later concretely --- fufilled by an concrete 'Quasi' instance, internal to GHC. -newtype Q a = Q { unQ :: forall m. Quasi m => m a } - --- | \"Runs\" the 'Q' monad. Normal users of Template Haskell --- should not need this function, as the splice brackets @$( ... )@ --- are the usual way of running a 'Q' computation. --- --- This function is primarily used in GHC internals, and for debugging --- splices by running them in 'IO'. --- --- Note that many functions in 'Q', such as 'reify' and other compiler --- queries, are not supported when running 'Q' in 'IO'; these operations --- simply fail at runtime. Indeed, the only operations guaranteed to succeed --- are 'newName', 'runIO', 'reportError' and 'reportWarning'. -runQ :: Quasi m => Q a -> m a -runQ (Q m) = m +-- | 'Q' is the base 'Monad' for TemplateHaskell splices, +-- similar to how 'IO' is the base 'Monad' for normal Haskell programs. +newtype Q a = Q { unQ :: MetaHandlers -> IO a } instance Monad Q where - Q m >>= k = Q (m >>= \x -> unQ (k x)) + Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h) (>>) = (*>) instance MonadFail Q where - fail s = report True s >> Q (fail "Q monad failure") + fail s = report True s >> Q (\h -> mFail h "Q monad failure") instance Functor Q where - fmap f (Q x) = Q (fmap f x) + fmap f (Q x) = Q $ \h -> fmap f (x h) instance Applicative Q where - pure x = Q (pure x) - Q f <*> Q x = Q (f <*> x) - Q m *> Q n = Q (m *> n) + pure x = Q $ \_ -> pure x + Q f <*> Q x = Q $ \h -> (f h <*> x h) + Q m *> Q n = Q $ \h -> (m h *> n h) -- | @since 2.17.0.0 instance Semigroup a => Semigroup (Q a) where @@ -319,7 +302,7 @@ class Monad m => Quote m where newName :: String -> m Name instance Quote Q where - newName s = Q (qNewName s) + newName s = Q $ \h -> mNewName h s ----------------------------------------------------- -- @@ -517,35 +500,26 @@ joinCode = flip bindCode id -- | Report an error (True) or warning (False), -- but carry on; use 'fail' to stop. report :: Bool -> String -> Q () -report b s = Q (qReport b s) -{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 - --- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. -reportError :: String -> Q () -reportError = report True - --- | Report a warning to the user, and carry on. -reportWarning :: String -> Q () -reportWarning = report False +report b s = Q $ \h -> mReport h b s -- | Recover from errors raised by 'reportError' or 'fail'. recover :: Q a -- ^ handler to invoke on failure -> Q a -- ^ computation to run -> Q a -recover (Q r) (Q m) = Q (qRecover r m) +recover rec main = Q $ \h -> mRecover h rec main -- We don't export lookupName; the Bool isn't a great API -- Instead we export lookupTypeName, lookupValueName lookupName :: Bool -> String -> Q (Maybe Name) -lookupName ns s = Q (qLookupName ns s) +lookupName ns s = Q $ \h -> mLookupName h ns s -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupTypeName :: String -> Q (Maybe Name) -lookupTypeName s = Q (qLookupName True s) +lookupTypeName s = Q $ \h -> mLookupName h True s -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupValueName :: String -> Q (Maybe Name) -lookupValueName s = Q (qLookupName False s) +lookupValueName s = Q $ \h -> mLookupName h False s {- Note [Name lookup] @@ -620,7 +594,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName': and to get information about @D@-the-type, use 'lookupTypeName'. -} reify :: Name -> Q Info -reify v = Q (qReify v) +reify v = Q $ \h -> mReify h v {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @@ -629,7 +603,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity nm = Q (qReifyFixity nm) +reifyFixity nm = Q $ \h -> mReifyFixity h nm {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @@ -637,7 +611,7 @@ reifyFixity nm = Q (qReifyFixity nm) This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type -reifyType nm = Q (qReifyType nm) +reifyType nm = Q $ \h -> mReifyType h nm {- | Template Haskell is capable of reifying information about types and terms defined in previous declaration groups. Top-level declaration splices break up @@ -729,7 +703,7 @@ has some discussion around this. -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] -reifyInstances cls tys = Q (qReifyInstances cls tys) +reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys {- | @reifyRoles nm@ returns the list of roles associated with the parameters (both visible and invisible) of @@ -748,20 +722,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i the role of the invisible @k@ parameter. Kind parameters are always nominal. -} reifyRoles :: Name -> Q [Role] -reifyRoles nm = Q (qReifyRoles nm) +reifyRoles nm = Q $ \h -> mReifyRoles h nm -- | @reifyAnnotations target@ returns the list of annotations -- associated with @target@. Only the annotations that are -- appropriately typed is returned. So if you have @Int@ and @String@ -- annotations for the same target, you have to call this function twice. reifyAnnotations :: Data a => AnnLookup -> Q [a] -reifyAnnotations an = Q (qReifyAnnotations an) +reifyAnnotations an = Q $ \h -> mReifyAnnotations h an -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return -- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo -reifyModule m = Q (qReifyModule m) +reifyModule m = Q $ \h -> mReifyModule h m -- | @reifyConStrictness nm@ looks up the strictness information for the fields -- of the constructor with the name @nm@. Note that the strictness information @@ -776,7 +750,7 @@ reifyModule m = Q (qReifyModule m) -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the -- @-XStrictData@ language extension was enabled. reifyConStrictness :: Name -> Q [DecidedStrictness] -reifyConStrictness n = Q (qReifyConStrictness n) +reifyConStrictness n = Q $ \h -> mReifyConStrictness h n -- | Is the list of instances returned by 'reifyInstances' nonempty? -- @@ -789,7 +763,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys -- | The location at which this computation is spliced. location :: Q Loc -location = Q qLocation +location = Q mLocation -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within @@ -799,7 +773,7 @@ location = Q qLocation -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a -runIO m = Q (qRunIO m) +runIO m = Q $ \h -> mLiftIO h m -- | Get the package root for the current package which is being compiled. -- This can be set explicitly with the -package-root flag but is normally @@ -811,7 +785,7 @@ runIO m = Q (qRunIO m) -- change directory when compiling files but instead set the -package-root flag -- appropriately. getPackageRoot :: Q FilePath -getPackageRoot = Q qGetPackageRoot +getPackageRoot = Q mGetPackageRoot -- | Record external directories that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -830,7 +804,7 @@ getPackageRoot = Q qGetPackageRoot -- * The state of the directory is read at the interface generation time, -- not at the time of the function call. addDependentDirectory :: FilePath -> Q () -addDependentDirectory dp = Q (qAddDependentDirectory dp) +addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -844,17 +818,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp) -- -- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () -addDependentFile fp = Q (qAddDependentFile fp) +addDependentFile fp = Q $ \h -> mAddDependentFile h fp -- | Obtain a temporary file path with the given suffix. The compiler will -- delete this file after compilation. addTempFile :: String -> Q FilePath -addTempFile suffix = Q (qAddTempFile suffix) +addTempFile suffix = Q $ \h -> mAddTempFile h suffix -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () -addTopDecls ds = Q (qAddTopDecls ds) +addTopDecls ds = Q $ \h -> mAddTopDecls h ds -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in @@ -863,7 +837,7 @@ addTopDecls ds = Q (qAddTopDecls ds) -- This is a good alternative to 'addForeignSource' when you are trying to -- directly link in an object file. addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () -addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) +addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. @@ -872,7 +846,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- 'reify' is able to find the local definitions when executed inside the -- finalizer. addModFinalizer :: Q () -> Q () -addModFinalizer act = Q (qAddModFinalizer (unQ act)) +addModFinalizer act = Q $ \h -> mAddModFinalizer h act -- | Adds a core plugin to the compilation pipeline. -- @@ -882,7 +856,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act)) -- to tell the compiler that we needed to compile first a plugin module in the -- current package. addCorePlugin :: String -> Q () -addCorePlugin plugin = Q (qAddCorePlugin plugin) +addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to -- a type-indexed finite map. That is, @@ -896,20 +870,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin) -- Note that the state is local to the Haskell module in which the Template -- Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) -getQ = Q qGetQ +getQ = Q mGetQ -- | Replace the state in the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. putQ :: Typeable a => a -> Q () -putQ x = Q (qPutQ x) +putQ x = Q $ \h -> mPutQ h x -- | Determine whether the given language extension is enabled in the 'Q' monad. isExtEnabled :: Extension -> Q Bool -isExtEnabled ext = Q (qIsExtEnabled ext) +isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext -- | List all enabled language extensions. extsEnabled :: Q [Extension] -extsEnabled = Q qExtsEnabled +extsEnabled = Q mExtsEnabled -- | Add Haddock documentation to the specified location. This will overwrite -- any documentation at the location if it already exists. This will reify the @@ -928,48 +902,18 @@ extsEnabled = Q qExtsEnabled -- Adding documentation to anything outside of the current module will cause an -- error. putDoc :: DocLoc -> String -> Q () -putDoc t s = Q (qPutDoc t s) +putDoc t s = Q $ \h -> mPutDoc h t s -- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag. getDoc :: DocLoc -> Q (Maybe String) -getDoc n = Q (qGetDoc n) +getDoc n = Q $ \h -> mGetDoc h n instance MonadIO Q where liftIO = runIO -instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyType = reifyType - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qGetPackageRoot = getPackageRoot - qAddDependentFile = addDependentFile - qAddDependentDirectory = addDependentDirectory - qAddTempFile = addTempFile - qAddTopDecls = addTopDecls - qAddForeignFilePath = addForeignFilePath - qAddModFinalizer = addModFinalizer - qAddCorePlugin = addCorePlugin - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - qPutDoc = putDoc - qGetDoc = getDoc - - ---------------------------------------------------- -- The following operations are used solely in GHC.HsToCore.Quote when -- desugaring brackets. They are not necessary for the user, who can use ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, - TupleSections, RecordWildCards, InstanceSigs, CPP #-} + TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do instance MonadIO GHCiQ where liftIO m = GHCiQ $ \_ -> m -instance TH.Quasi GHCiQ where - qNewName str = ghcCmd (NewName str) - qReport isError msg = ghcCmd (Report isError msg) - - -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do - s <- readIORef sRef - remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef - remoteTHCall (qsPipe s) (EndRecover (isLeft e)) - case e of - Left GHCiQException{} -> h sRef - Right r -> return r - qLookupName isType occ = ghcCmd (LookupName isType occ) - qReify name = ghcCmd (Reify name) - qReifyFixity name = ghcCmd (ReifyFixity name) - qReifyType name = ghcCmd (ReifyType name) - qReifyInstances name tys = ghcCmd (ReifyInstances name tys) - qReifyRoles name = ghcCmd (ReifyRoles name) - -- To reify annotations, we send GHC the AnnLookup and also the -- TypeRep of the thing we're looking for, to avoid needing to -- serialize irrelevant annotations. - qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] - qReifyAnnotations lookup = +reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] +reifyAnnotations lookup = map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep) where typerep = typeOf (undefined :: a) - qReifyModule m = ghcCmd (ReifyModule m) - qReifyConStrictness name = ghcCmd (ReifyConStrictness name) - qLocation = fromMaybe noLoc . qsLocation <$> getState - qGetPackageRoot = ghcCmd GetPackageRoot - qAddDependentFile file = ghcCmd (AddDependentFile file) - qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) - qAddTempFile suffix = ghcCmd (AddTempFile suffix) - qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>= +runQinGHCiQ :: TH.Q a -> GHCiQ a +runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef)) + where + runInIO :: IORef QState -> GHCiQ a -> IO a + runInIO sRef (GHCiQ m) = m sRef + +metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers +metaHandlersGHCiQ runInIO = TH.MetaHandlers { + mLiftIO = id + , mFail = runInIO . fail + , mNewName = \str -> runInIO $ ghcCmd (NewName str) + , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg) + + -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice + , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do + s <- readIORef sRef + remoteTHCall (qsPipe s) StartRecover + e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef + remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + case e of + Left GHCiQException{} -> + runGHCiQ (runQinGHCiQ h) sRef + Right r -> return r + , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ) + , mReify = \name ->runInIO $ ghcCmd (Reify name) + , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name) + , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name) + , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys) + , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name) + + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m) + , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name) + , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState + , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot + , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file) + , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir) + , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix) + , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls) + , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp) + , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer - qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = do + , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str) + , mGetQ = runInIO $ do s <- getState let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m return $ lookup (qsMap s) - qPutQ k = GHCiQ $ \sRef -> - modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) - qIsExtEnabled x = ghcCmd (IsExtEnabled x) - qExtsEnabled = ghcCmd ExtsEnabled - qPutDoc l s = ghcCmd (PutDoc l s) - qGetDoc l = ghcCmd (GetDoc l) + , mPutQ = \k -> runInIO $ GHCiQ $ \sRef -> + modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) + , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x) + , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled + , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s) + , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l) +} -- | The implementation of the 'StartTH' message: create -- a new IORef QState, and return a RemoteRef to it. @@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do qstateref <- localRef rstate qstate <- readIORef qstateref qstate' <- newIORef $ qstate { qsPipe = pipe } - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate' + _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message @@ -272,5 +284,5 @@ runTHQ runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) - r <- runGHCiQ (TH.runQ ghciq) qstateref + r <- runGHCiQ (runQinGHCiQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -5,13 +5,17 @@ {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} +-- Don't warn for using 'report' from ghc-internal +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} module Language.Haskell.TH.Syntax ( Quote (..), Exp (..), Match (..), Clause (..), - Q (..), + Q, + -- backwards compatibility + Language.Haskell.TH.Syntax.unQ, Pat (..), Stmt (..), Con (..), @@ -202,11 +206,14 @@ where import GHC.Boot.TH.Lift import GHC.Boot.TH.Syntax -import GHC.Boot.TH.Monad +import GHC.Boot.TH.Monad hiding (report) +import qualified GHC.Boot.TH.Monad as Internal import System.FilePath import Data.Data hiding (Fixity(..)) import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.IO (hPutStrLn, stderr) -- This module completely re-exports 'GHC.Boot.TH.Syntax', -- and exports additionally functions that depend on @filepath@ or @System.IO@. @@ -499,3 +506,172 @@ reassociate the tree as necessary. -- Subsumed by the more general 'SpecialiseEP' constructor. pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases + +unQ :: Q a -> (forall m. Quasi m => m a) +unQ m = runQ m + +----------------------------------------------------- +-- +-- The Quasi class +-- +----------------------------------------------------- + +-- | The 'Quasi' typeclass used to provide an exhaustive list of the effects exposed by the 'Q' monad. +-- This invariant no longer holds, and it is encouraged to use 'Q' or 'Quote' instead. +class (MonadIO m, MonadFail m) => Quasi m where + qRunQ :: Q a -> m a + -- | Fresh names. See 'newName'. + qNewName :: String -> m Name + qNewName = qRunQ . newName + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + qReport :: Bool -> String -> m () + qReport b s = qRunQ $ report b s + + -- | See 'recover'. + qRecover :: m a -- ^ the error handler + -> m a -- ^ action which may fail + -> m a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + qLookupName :: Bool -> String -> m (Maybe Name) + qLookupName ns s = qRunQ $ lookupName ns s + -- | See 'reify'. + qReify :: Name -> m Info + qReify v = qRunQ $ reify v + -- | See 'reifyFixity'. + qReifyFixity :: Name -> m (Maybe Fixity) + qReifyFixity v = qRunQ $ reifyFixity v + -- | See 'reifyType'. + qReifyType :: Name -> m Type + qReifyType v = qRunQ $ reifyType v + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + qReifyInstances :: Name -> [Type] -> m [Dec] + qReifyInstances cls tys = qRunQ $ reifyInstances cls tys + -- | See 'reifyRoles'. + qReifyRoles :: Name -> m [Role] + qReifyRoles nm = qRunQ $ reifyRoles nm + -- | See 'reifyAnnotations'. + qReifyAnnotations :: Data a => AnnLookup -> m [a] + qReifyAnnotations an = qRunQ $ reifyAnnotations an + -- | See 'reifyModule'. + qReifyModule :: Module -> m ModuleInfo + qReifyModule m = qRunQ $ reifyModule m + -- | See 'reifyConStrictness'. + qReifyConStrictness :: Name -> m [DecidedStrictness] + qReifyConStrictness nm = qRunQ $ reifyConStrictness nm + + -- | See 'location'. + qLocation :: m Loc + qLocation = qRunQ location + + -- | Input/output (dangerous). See 'runIO'. + qRunIO :: IO a -> m a + qRunIO = liftIO + -- | See 'getPackageRoot'. + qGetPackageRoot :: m FilePath + qGetPackageRoot = qRunQ getPackageRoot + + -- | See 'addDependentFile'. + qAddDependentFile :: FilePath -> m () + qAddDependentFile p = qRunQ $ addDependentFile p + + -- | See 'addDependentDirectory'. + qAddDependentDirectory :: FilePath -> m () + qAddDependentDirectory p = qRunQ $ addDependentDirectory p + + -- | See 'addTempFile'. + qAddTempFile :: String -> m FilePath + qAddTempFile p = qRunQ $ addTempFile p + + -- | See 'addTopDecls'. + qAddTopDecls :: [Dec] -> m () + qAddTopDecls decls = qRunQ $ addTopDecls decls + + -- | See 'addForeignFilePath'. + qAddForeignFilePath :: ForeignSrcLang -> String -> m () + qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp + + -- | See 'addModFinalizer'. + qAddModFinalizer :: Q () -> m () + qAddModFinalizer fin = qRunQ $ addModFinalizer fin + + -- | See 'addCorePlugin'. + qAddCorePlugin :: String -> m () + qAddCorePlugin nm = qRunQ $ addCorePlugin nm + + -- | See 'getQ'. + qGetQ :: Typeable a => m (Maybe a) + qGetQ = qRunQ getQ + + -- | See 'putQ'. + qPutQ :: Typeable a => a -> m () + qPutQ x = qRunQ $ putQ x + + -- | See 'isExtEnabled'. + qIsExtEnabled :: Extension -> m Bool + qIsExtEnabled ext = qRunQ $ isExtEnabled ext + -- | See 'extsEnabled'. + qExtsEnabled :: m [Extension] + qExtsEnabled = qRunQ extsEnabled + + -- | See 'putDoc'. + qPutDoc :: DocLoc -> String -> m () + qPutDoc l s = qRunQ $ putDoc l s + -- | See 'getDoc'. + qGetDoc :: DocLoc -> m (Maybe String) + qGetDoc l = qRunQ $ getDoc l + +-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell +-- should not need this function, as the splice brackets @$( ... )@ +-- are the usual way of running a 'Q' computation. +-- +-- This function is primarily used in GHC internals, and for debugging +-- splices by running them in 'IO'. +-- +-- Note that many functions in 'Q', such as 'reify' and other compiler +-- queries, are not supported when running 'Q' in 'IO'; these operations +-- simply fail at runtime. Indeed, the only operations guaranteed to succeed +-- are 'newName', 'runIO', 'reportError' and 'reportWarning'. +runQ :: Quasi m => Q a -> m a +runQ = qRunQ + +----------------------------------------------------- +-- The IO instance of Quasi +----------------------------------------------------- + +-- | This instance is used only when running a Q +-- computation in the IO monad, usually just to +-- print the result. There is no interesting +-- type environment, so reification isn't going to +-- work. Please use 'Quote' instead, which is much safer. +instance Quasi IO where + qRunQ (Q m) = m metaHandlersIO + qNewName = newNameIO + + qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + qRecover _ _ = badIO "recover" -- Maybe we could fix this? + +instance Quasi Q where + qRunQ = id + qRecover = recover + + +-- | Report an error (True) or warning (False), +-- but carry on; use 'fail' to stop. +report :: Bool -> String -> Q () +report = Internal.report +{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 + +-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. +reportError :: String -> Q () +reportError = report True + +-- | Report a warning to the user, and carry on. +reportWarning :: String -> Q () +reportWarning = report False ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -354,7 +354,6 @@ module Language.Haskell.TH where type Pred = Type type PredQ :: * type PredQ = Q Pred - type role Q nominal type Q :: * -> * newtype Q a = ... type Quote :: (* -> *) -> Constraint @@ -655,7 +654,7 @@ module Language.Haskell.TH where roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr runIO :: forall a. GHC.Internal.Types.IO a -> Q a - runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a + runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a safe :: Safety sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp @@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) type Pred :: * type Pred = Type - type role Q nominal type Q :: * -> * - newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a} + newtype Q a = ... type Quasi :: (* -> *) -> Constraint class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where + qRunQ :: forall a. Q a -> m a qNewName :: GHC.Internal.Base.String -> m Name qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m () qRecover :: forall a. m a -> m a -> m a @@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () qAddModFinalizer :: Q () -> m () qAddCorePlugin :: GHC.Internal.Base.String -> m () - qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) - qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () + qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) + qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) - {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} + {-# MINIMAL qRunQ, qRecover #-} type Quote :: (* -> *) -> Constraint class GHC.Internal.Base.Monad m => Quote m where newName :: GHC.Internal.Base.String -> m Name @@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where falseName :: Name getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) getPackageRoot :: Q GHC.Internal.IO.FilePath - getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) + getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) get_cons_names :: Con -> [Name] hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool @@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where oneName :: Name pkgString :: PkgName -> GHC.Internal.Base.String putDoc :: DocLoc -> GHC.Internal.Base.String -> Q () - putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () + putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () recover :: forall a. Q a -> Q a -> Q a reify :: Name -> Q Info reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a] @@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where trueName :: Name tupleDataName :: GHC.Internal.Types.Int -> Name tupleTypeName :: GHC.Internal.Types.Int -> Name + unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp unboxedSumDataName :: SumAlt -> SumArity -> Name @@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bf9e3c51c668f2d5fd6951f57356e8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bf9e3c51c668f2d5fd6951f57356e8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Decoupling 'L.H.S' from 'GHC.Types.SourceText'
by Marge Bot (＠marge-bot) 01 Jul '26

01 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d7cfea49 by Recursion Ninja at 2026-06-30T21:37:12-04:00 Decoupling 'L.H.S' from 'GHC.Types.SourceText' * Migrated 'IntegralLit' to 'L.H.S.Lit'. * Migrated 'FractionalLit' to 'L.H.S.Lit'. * Migrated 'StringLiteral' to 'L.H.S.Lit'. * Added TTG extension points to the types above. * Added nice export list to 'GHC.Hs.Lit'. * Added 'rnOverLitVal' and 'tcOverLitVal' functions to 'GHC.Hs.Lit'. * Added instance 'Anno (StringLiteral (GhcPass p)) = SrcSpanAnnN' * Moved [Notes] about 'SourceText' from 'L.H.S.*' to 'GHC.*'. * Removed all references to 'SourceText' from 'L.H.S'. * Removed the trailing comma record field from 'StringLiteral' * Renamed exported functions for nomenclature consistency. * Deprecated the renamed functions Fixes #26953 - - - - - a1f2558b by Recursion Ninja at 2026-06-30T21:37:12-04:00 Monomorphising GHC pass parameters where appropriate - - - - - 53 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/PkgQual.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - testsuite/tests/ghc-api/annotations-literals/literals.stdout - testsuite/tests/ghc-api/annotations-literals/parsed.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf7b5ce65f470f21eee29007f3d6a1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf7b5ce65f470f21eee29007f3d6a1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-4
by Alan Zimmerman (＠alanz) 01 Jul '26

01 Jul '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-4 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-4 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 3 commits: Fix ppr for ClassDecl to include DocDs
by Alan Zimmerman (＠alanz) 01 Jul '26

01 Jul '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: b11d4a77 by Alan Zimmerman at 2026-06-29T20:53:00+01:00 Fix ppr for ClassDecl to include DocDs - - - - - 38ffb9b2 by Alan Zimmerman at 2026-06-29T21:53:45+01:00 Some tidy ups of the decls stuff. Squash it in - - - - - ad58bb76 by Alan Zimmerman at 2026-06-30T22:35:08+01:00 EPA: ClsInstDecl as list in GhcPs - - - - - 31 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Stats.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - testsuite/tests/haddock/haddock_examples/haddock.Test.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74e5c1828c656a858fe83b55c36ea5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74e5c1828c656a858fe83b55c36ea5… You're receiving this email because of your account on gitlab.haskell.org.

1 0