From 217caad163283c37fb5560188a56511f24b1ee57 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Tue, 21 Jan 2025 12:05:17 +0000
Subject: [PATCH] Implement Explicit Level Imports for Template Haskell
This commit introduces the `ExplicitLevelImports` and
`ImplicitStagePersistence` language extensions as proposed in GHC
Proposal #682.
Key Features
------------
- `ExplicitLevelImports` adds two new import modifiers - `splice` and
`quote` - allowing precise control over the level at which imported
identifiers are available
- `ImplicitStagePersistence` (enabled by default) preserves existing
path-based cross-stage persistence behavior
- `NoImplicitStagePersistence` disables implicit cross-stage
persistence, requiring explicit level imports
Benefits
--------
- Improved compilation performance by reducing unnecessary code generation
- Enhanced IDE experience with faster feedback in `-fno-code` mode
- Better dependency tracking by distinguishing compile-time and runtime dependencies
- Foundation for future cross-compilation improvements
This implementation enables the separation of modules needed at
compile-time from those needed at runtime, allowing for more efficient
compilation pipelines and clearer code organization in projects using
Template Haskell.
Implementation Notes
--------------------
The level which a name is availble at is stored in the 'GRE', in the normal
GlobalRdrEnv. The function `greLevels` returns the levels which a specific GRE
is imported at. The level information for a 'Name' is computed by `getCurrentAndBindLevel`.
The level validity is checked by `checkCrossLevelLifting`.
Instances are checked by `checkWellLevelledDFun`, which computes the level an
instance by calling `checkWellLevelledInstanceWhat`, which sees what is
available at by looking at the module graph.
Modifications to downsweep
--------------------------
Code generation is now only enabled for modules which are needed at
compile time.
See the Note [-fno-code mode] for more information.
Uniform error messages for level errors
---------------------------------------
All error messages to do with levels are now reported uniformly using
the `TcRnBadlyStaged` constructor.
Error messages are uniformly reported in terms of levels.
0 - top-level
1 - quote level
-1 - splice level
The only level hard-coded into the compiler is the top-level in
GHC.Types.ThLevelIndex.topLevelIndex.
Uniformly refer to levels and stages
------------------------------------
There was much confusion about levels vs stages in the compiler.
A level is a semantic concept, used by the typechecker to ensure a
program can be evaluated in a well-staged manner.
A stage is an operational construct, program evaluation proceeds in
stages.
Deprecate -Wbadly-staged-types
------------------------------
`-Wbadly-staged-types` is deprecated in favour of `-Wbadly-levelled-types`.
Lift derivation changed
-----------------------
Derived lift instances will now not generate code with expression
quotations.
Before:
```
data A = A Int deriving Lift
=>
lift (A x) = [| A $(lift x) |]
```
After:
```
lift (A x) = conE 'A `appE` (lift x)
```
This is because if you attempt to derive `Lift` in a module where
`NoImplicitStagePersistence` is enabled, you would get an infinite loop
where a constructor was attempted to be persisted using the instance you
are currently defining.
GHC API Changes
---------------
The ModuleGraph now contains additional information about the type of
the edges (normal, quote or splice) between modules. This is abstracted
using the `ModuleGraphEdge` data type.
Fixes #25828
-------------------------
Metric Increase:
MultiLayerModulesTH_Make
-------------------------
---
compiler/GHC.hs | 3 +-
.../GHC/Data/Graph/Directed/Reachability.hs | 31 +-
compiler/GHC/Driver/Backpack.hs | 21 +-
compiler/GHC/Driver/Downsweep.hs | 616 ++++++++------
compiler/GHC/Driver/DynFlags.hs | 11 +-
compiler/GHC/Driver/Flags.hs | 10 +-
compiler/GHC/Driver/Make.hs | 3 +-
compiler/GHC/Driver/MakeFile.hs | 11 +-
compiler/GHC/Driver/Pipeline.hs | 4 +-
compiler/GHC/Driver/Pipeline/Execute.hs | 4 +-
compiler/GHC/Driver/Session.hs | 4 +-
compiler/GHC/Hs/ImpExp.hs | 27 +-
compiler/GHC/Iface/Recomp.hs | 52 +-
compiler/GHC/Iface/Tidy.hs | 5 +-
compiler/GHC/Parser.y | 57 +-
compiler/GHC/Parser/Errors/Ppr.hs | 4 +
compiler/GHC/Parser/Errors/Types.hs | 3 +
compiler/GHC/Parser/Header.hs | 18 +-
compiler/GHC/Parser/Lexer.x | 9 +-
compiler/GHC/Parser/PostProcess.hs | 54 +-
compiler/GHC/Rename/Env.hs | 14 +-
compiler/GHC/Rename/Expr.hs | 31 +-
compiler/GHC/Rename/Module.hs | 3 +-
compiler/GHC/Rename/Names.hs | 40 +-
compiler/GHC/Rename/Splice.hs | 223 ++---
compiler/GHC/Rename/Utils.hs | 2 +-
compiler/GHC/Runtime/Loader.hs | 2 +-
compiler/GHC/Tc/Deriv/Generate.hs | 40 +-
compiler/GHC/Tc/Deriv/Utils.hs | 1 +
compiler/GHC/Tc/Errors/Ppr.hs | 71 +-
compiler/GHC/Tc/Errors/Types.hs | 50 +-
compiler/GHC/Tc/Gen/App.hs | 4 +-
compiler/GHC/Tc/Gen/Head.hs | 57 +-
compiler/GHC/Tc/Gen/Splice.hs | 70 +-
compiler/GHC/Tc/Module.hs | 28 +
compiler/GHC/Tc/Plugin.hs | 1 -
compiler/GHC/Tc/Solver/Dict.hs | 2 +-
compiler/GHC/Tc/Solver/Monad.hs | 142 +++-
compiler/GHC/Tc/TyCl/Instance.hs | 4 +-
compiler/GHC/Tc/Types.hs | 28 +-
compiler/GHC/Tc/Types/LclEnv.hs | 17 +-
compiler/GHC/Tc/Types/Origin.hs | 2 +-
compiler/GHC/Tc/Types/TH.hs | 74 +-
compiler/GHC/Tc/Utils/Backpack.hs | 7 +-
compiler/GHC/Tc/Utils/Concrete.hs | 4 +-
compiler/GHC/Tc/Utils/Env.hs | 63 +-
compiler/GHC/Tc/Utils/Monad.hs | 46 +-
compiler/GHC/Tc/Utils/TcMType.hs | 16 +-
compiler/GHC/Types/Basic.hs | 31 +-
compiler/GHC/Types/Error/Codes.hs | 9 +-
compiler/GHC/Types/Name/Reader.hs | 38 +-
compiler/GHC/Types/ThLevelIndex.hs | 35 +
compiler/GHC/Unit/Home/PackageTable.hs | 2 +-
compiler/GHC/Unit/Module/Deps.hs | 53 +-
compiler/GHC/Unit/Module/Graph.hs | 267 +++++-
compiler/GHC/Unit/Module/Imported.hs | 3 +
compiler/GHC/Unit/Module/ModSummary.hs | 30 +-
compiler/GHC/Unit/Module/Stage.hs | 85 ++
compiler/GHC/Unit/Types.hs | 14 +-
compiler/GHC/Utils/Binary.hs | 24 +-
compiler/GHC/Utils/Outputable.hs | 18 +-
compiler/Language/Haskell/Syntax/ImpExp.hs | 21 +-
.../Language/Haskell/Syntax/ImpExp/IsBoot.hs | 15 +
compiler/ghc.cabal.in | 3 +
docs/users_guide/exts/control.rst | 4 +
docs/users_guide/exts/template_haskell.rst | 767 ++++++++++++------
docs/users_guide/phases.rst | 5 +
docs/users_guide/using-warnings.rst | 24 +-
ghc/GHCi/UI.hs | 1 +
libraries/base/tests/IO/Makefile | 8 +-
.../src/GHC/Internal/LanguageExtensions.hs | 2 +
testsuite/tests/ado/ado004.stderr | 2 +-
.../annotations/should_fail/annfail03.stderr | 22 +-
.../annotations/should_fail/annfail04.stderr | 10 +-
.../annotations/should_fail/annfail06.stderr | 10 +-
.../annotations/should_fail/annfail09.stderr | 22 +-
.../tests/count-deps/CountDepsAst.stdout | 2 +
.../tests/count-deps/CountDepsParser.stdout | 3 +
.../dependent/should_compile/T14729.stderr | 2 +-
.../dependent/should_compile/T15743.stderr | 2 +-
.../dependent/should_compile/T15743e.stderr | 2 +-
.../deriving/should_compile/T14682.stderr | 18 +-
.../determinism/determ021/determ021.stdout | 4 +-
testsuite/tests/driver/T4437.stdout | 6 +
testsuite/tests/driver/json2.stderr | 2 +-
testsuite/tests/gadt/T19847a.stderr | 2 +-
.../tests/ghc-api/fixed-nodes/FixedNodes.hs | 2 +-
.../fixed-nodes/ModuleGraphInvariants.hs | 14 +-
.../should_compile/T15711.stderr | 2 +-
.../should_compile/T15852.stderr | 2 +-
.../indexed-types/should_compile/T3017.stderr | 2 +-
.../template-haskell-exports.stdout | 6 +
testsuite/tests/module/mod185.stderr | 2 +
.../should_compile/DumpParsedAst.stderr | 2 +
.../should_compile/DumpRenamedAst.stderr | 6 +
.../parser/should_compile/DumpSemis.stderr | 4 +
.../parser/should_compile/KindSigs.stderr | 2 +
.../tests/parser/should_compile/T14189.stderr | 2 +
.../partial-sigs/should_compile/ADT.stderr | 2 +-
.../should_compile/AddAndOr1.stderr | 2 +-
.../should_compile/AddAndOr2.stderr | 2 +-
.../should_compile/AddAndOr3.stderr | 2 +-
.../should_compile/AddAndOr4.stderr | 2 +-
.../should_compile/AddAndOr5.stderr | 2 +-
.../should_compile/AddAndOr6.stderr | 2 +-
.../should_compile/BoolToBool.stderr | 2 +-
.../DataFamilyInstanceLHS.stderr | 2 +-
.../should_compile/Defaulting1MROn.stderr | 2 +-
.../should_compile/Defaulting2MROff.stderr | 2 +-
.../should_compile/Defaulting2MROn.stderr | 2 +-
.../partial-sigs/should_compile/Either.stderr | 2 +-
.../should_compile/EqualityConstraint.stderr | 2 +-
.../partial-sigs/should_compile/Every.stderr | 2 +-
.../should_compile/EveryNamed.stderr | 2 +-
.../should_compile/ExpressionSig.stderr | 2 +-
.../should_compile/ExpressionSigNamed.stderr | 2 +-
.../should_compile/ExtraConstraints1.stderr | 2 +-
.../should_compile/ExtraConstraints2.stderr | 2 +-
.../should_compile/ExtraConstraints3.stderr | 2 +-
.../should_compile/ExtraNumAMROff.stderr | 2 +-
.../should_compile/ExtraNumAMROn.stderr | 2 +-
.../should_compile/Forall1.stderr | 2 +-
.../should_compile/GenNamed.stderr | 2 +-
.../should_compile/HigherRank1.stderr | 2 +-
.../should_compile/HigherRank2.stderr | 2 +-
.../should_compile/LocalDefinitionBug.stderr | 2 +-
.../should_compile/Meltdown.stderr | 2 +-
.../should_compile/MonoLocalBinds.stderr | 2 +-
.../should_compile/NamedTyVar.stderr | 2 +-
...amedWildcardInDataFamilyInstanceLHS.stderr | 2 +-
...amedWildcardInTypeFamilyInstanceLHS.stderr | 2 +-
.../should_compile/ParensAroundContext.stderr | 2 +-
.../should_compile/PatBind.stderr | 2 +-
.../should_compile/PatBind2.stderr | 2 +-
.../should_compile/PatternSig.stderr | 2 +-
.../should_compile/Recursive.stderr | 2 +-
.../ScopedNamedWildcards.stderr | 2 +-
.../ScopedNamedWildcardsGood.stderr | 2 +-
.../should_compile/ShowNamed.stderr | 2 +-
.../should_compile/SimpleGen.stderr | 2 +-
.../should_compile/SkipMany.stderr | 2 +-
.../should_compile/SomethingShowable.stderr | 4 +-
.../TypeFamilyInstanceLHS.stderr | 2 +-
.../should_compile/Uncurry.stderr | 2 +-
.../should_compile/UncurryNamed.stderr | 2 +-
.../WarningWildcardInstantiations.stderr | 4 +-
testsuite/tests/polykinds/T15592.stderr | 2 +-
testsuite/tests/polykinds/T15592b.stderr | 2 +-
testsuite/tests/printer/T18052a.stderr | 2 +-
.../tests/quasiquotation/qq001/qq001.stderr | 10 +-
.../tests/quasiquotation/qq002/qq002.stderr | 10 +-
.../tests/quasiquotation/qq003/qq003.stderr | 10 +-
.../tests/quasiquotation/qq004/qq004.stderr | 10 +-
testsuite/tests/quotes/T5721.stderr | 3 +
.../tests/roles/should_compile/Roles1.stderr | 2 +-
.../tests/roles/should_compile/Roles14.stderr | 2 +-
.../tests/roles/should_compile/Roles2.stderr | 2 +-
.../tests/roles/should_compile/Roles3.stderr | 2 +-
.../tests/roles/should_compile/Roles4.stderr | 2 +-
.../tests/roles/should_compile/T8958.stderr | 2 +-
.../tests/showIface/DocsInHiFile1.stdout | 1 +
.../tests/showIface/DocsInHiFileTH.stdout | 1 +
.../tests/showIface/HaddockIssue849.stdout | 1 +
testsuite/tests/showIface/HaddockOpts.stdout | 1 +
.../showIface/HaddockSpanIssueT24378.stdout | 1 +
testsuite/tests/showIface/LanguageExts.stdout | 1 +
.../showIface/MagicHashInHaddocks.stdout | 1 +
testsuite/tests/showIface/NoExportList.stdout | 1 +
testsuite/tests/showIface/PragmaDocs.stdout | 1 +
testsuite/tests/showIface/ReExports.stdout | 1 +
testsuite/tests/splice-imports/ClassA.hs | 8 +
testsuite/tests/splice-imports/InstanceA.hs | 6 +
testsuite/tests/splice-imports/Makefile | 28 +
testsuite/tests/splice-imports/SI01.hs | 9 +
testsuite/tests/splice-imports/SI01A.hs | 3 +
testsuite/tests/splice-imports/SI02.hs | 11 +
testsuite/tests/splice-imports/SI03.hs | 10 +
testsuite/tests/splice-imports/SI03.stderr | 7 +
testsuite/tests/splice-imports/SI04.hs | 10 +
testsuite/tests/splice-imports/SI05.hs | 10 +
testsuite/tests/splice-imports/SI05.stderr | 18 +
testsuite/tests/splice-imports/SI05A.hs | 3 +
testsuite/tests/splice-imports/SI06.hs | 7 +
testsuite/tests/splice-imports/SI07.hs | 10 +
testsuite/tests/splice-imports/SI07.stderr | 3 +
testsuite/tests/splice-imports/SI07A.hs | 1 +
testsuite/tests/splice-imports/SI08.hs | 14 +
testsuite/tests/splice-imports/SI08.stderr | 7 +
.../tests/splice-imports/SI08_oneshot.stderr | 7 +
testsuite/tests/splice-imports/SI09.hs | 11 +
testsuite/tests/splice-imports/SI10.hs | 12 +
testsuite/tests/splice-imports/SI13.hs | 15 +
testsuite/tests/splice-imports/SI14.hs | 9 +
testsuite/tests/splice-imports/SI14.stderr | 5 +
testsuite/tests/splice-imports/SI15.hs | 10 +
testsuite/tests/splice-imports/SI15.stderr | 5 +
testsuite/tests/splice-imports/SI16.hs | 12 +
testsuite/tests/splice-imports/SI16.stderr | 6 +
testsuite/tests/splice-imports/SI17.hs | 7 +
testsuite/tests/splice-imports/SI18.hs | 7 +
testsuite/tests/splice-imports/SI18.stderr | 6 +
testsuite/tests/splice-imports/SI19.hs | 10 +
testsuite/tests/splice-imports/SI19A.hs | 3 +
testsuite/tests/splice-imports/SI20.hs | 9 +
testsuite/tests/splice-imports/SI20.stderr | 8 +
testsuite/tests/splice-imports/SI21.hs | 7 +
testsuite/tests/splice-imports/SI21.stderr | 4 +
testsuite/tests/splice-imports/SI22.hs | 5 +
testsuite/tests/splice-imports/SI22.stderr | 4 +
testsuite/tests/splice-imports/SI23.hs | 9 +
testsuite/tests/splice-imports/SI23A.hs | 5 +
testsuite/tests/splice-imports/SI24.hs | 8 +
testsuite/tests/splice-imports/SI25.hs | 16 +
testsuite/tests/splice-imports/SI25.stderr | 9 +
testsuite/tests/splice-imports/SI25Helper.hs | 11 +
testsuite/tests/splice-imports/SI26.hs | 28 +
testsuite/tests/splice-imports/SI27.hs | 10 +
testsuite/tests/splice-imports/SI27.stderr | 12 +
testsuite/tests/splice-imports/SI28.hs | 8 +
testsuite/tests/splice-imports/SI28.stderr | 8 +
testsuite/tests/splice-imports/SI29.hs | 11 +
testsuite/tests/splice-imports/SI29.stderr | 8 +
testsuite/tests/splice-imports/SI30.script | 1 +
testsuite/tests/splice-imports/SI30.stdout | 1 +
testsuite/tests/splice-imports/SI31.script | 2 +
testsuite/tests/splice-imports/SI31.stderr | 7 +
testsuite/tests/splice-imports/SI32.script | 5 +
testsuite/tests/splice-imports/SI32.stdout | 1 +
testsuite/tests/splice-imports/SI33.script | 8 +
testsuite/tests/splice-imports/SI33.stdout | 1 +
testsuite/tests/splice-imports/SI34.hs | 11 +
testsuite/tests/splice-imports/SI34.stderr | 3 +
testsuite/tests/splice-imports/SI34M1.hs | 14 +
testsuite/tests/splice-imports/SI34M2.hs | 28 +
testsuite/tests/splice-imports/SI35.hs | 79 ++
testsuite/tests/splice-imports/SI35A.hs | 21 +
testsuite/tests/splice-imports/SI36.hs | 37 +
testsuite/tests/splice-imports/SI36.stderr | 48 ++
testsuite/tests/splice-imports/SI36_A.hs | 14 +
testsuite/tests/splice-imports/SI36_B1.hs | 9 +
testsuite/tests/splice-imports/SI36_B2.hs | 9 +
testsuite/tests/splice-imports/SI36_B3.hs | 9 +
testsuite/tests/splice-imports/SI36_C1.hs | 15 +
testsuite/tests/splice-imports/SI36_C2.hs | 15 +
testsuite/tests/splice-imports/SI36_C3.hs | 15 +
testsuite/tests/splice-imports/all.T | 48 ++
testsuite/tests/th/T16976z.stderr | 7 +-
testsuite/tests/th/T17820a.stderr | 8 +-
testsuite/tests/th/T17820b.stderr | 8 +-
testsuite/tests/th/T17820c.stderr | 8 +-
testsuite/tests/th/T17820d.stderr | 5 +-
testsuite/tests/th/T17820e.stderr | 8 +-
testsuite/tests/th/T21547.stderr | 10 +-
testsuite/tests/th/T23829_hasty.stderr | 10 +-
testsuite/tests/th/T23829_hasty_b.stderr | 5 +-
testsuite/tests/th/T23829_tardy.ghc.stderr | 12 +-
testsuite/tests/th/T5795.stderr | 10 +-
testsuite/tests/th/TH_Roles2.stderr | 3 +-
.../typecheck/should_compile/T12763.stderr | 2 +-
.../typecheck/should_compile/T18406b.stderr | 2 +-
.../typecheck/should_compile/T18529.stderr | 2 +-
.../typecheck/should_compile/T21023.stderr | 2 +-
utils/check-exact/ExactPrint.hs | 4 +-
utils/count-deps/Main.hs | 2 +-
.../Haddock/Backends/Hyperlinker/Parser.hs | 2 +
265 files changed, 3462 insertions(+), 1293 deletions(-)
create mode 100644 compiler/GHC/Types/ThLevelIndex.hs
create mode 100644 compiler/GHC/Unit/Module/Stage.hs
create mode 100644 compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs
create mode 100644 testsuite/tests/driver/T4437.stdout
create mode 100644 testsuite/tests/quotes/T5721.stderr
create mode 100644 testsuite/tests/splice-imports/ClassA.hs
create mode 100644 testsuite/tests/splice-imports/InstanceA.hs
create mode 100644 testsuite/tests/splice-imports/Makefile
create mode 100644 testsuite/tests/splice-imports/SI01.hs
create mode 100644 testsuite/tests/splice-imports/SI01A.hs
create mode 100644 testsuite/tests/splice-imports/SI02.hs
create mode 100644 testsuite/tests/splice-imports/SI03.hs
create mode 100644 testsuite/tests/splice-imports/SI03.stderr
create mode 100644 testsuite/tests/splice-imports/SI04.hs
create mode 100644 testsuite/tests/splice-imports/SI05.hs
create mode 100644 testsuite/tests/splice-imports/SI05.stderr
create mode 100644 testsuite/tests/splice-imports/SI05A.hs
create mode 100644 testsuite/tests/splice-imports/SI06.hs
create mode 100644 testsuite/tests/splice-imports/SI07.hs
create mode 100644 testsuite/tests/splice-imports/SI07.stderr
create mode 100644 testsuite/tests/splice-imports/SI07A.hs
create mode 100644 testsuite/tests/splice-imports/SI08.hs
create mode 100644 testsuite/tests/splice-imports/SI08.stderr
create mode 100644 testsuite/tests/splice-imports/SI08_oneshot.stderr
create mode 100644 testsuite/tests/splice-imports/SI09.hs
create mode 100644 testsuite/tests/splice-imports/SI10.hs
create mode 100644 testsuite/tests/splice-imports/SI13.hs
create mode 100644 testsuite/tests/splice-imports/SI14.hs
create mode 100644 testsuite/tests/splice-imports/SI14.stderr
create mode 100644 testsuite/tests/splice-imports/SI15.hs
create mode 100644 testsuite/tests/splice-imports/SI15.stderr
create mode 100644 testsuite/tests/splice-imports/SI16.hs
create mode 100644 testsuite/tests/splice-imports/SI16.stderr
create mode 100644 testsuite/tests/splice-imports/SI17.hs
create mode 100644 testsuite/tests/splice-imports/SI18.hs
create mode 100644 testsuite/tests/splice-imports/SI18.stderr
create mode 100644 testsuite/tests/splice-imports/SI19.hs
create mode 100644 testsuite/tests/splice-imports/SI19A.hs
create mode 100644 testsuite/tests/splice-imports/SI20.hs
create mode 100644 testsuite/tests/splice-imports/SI20.stderr
create mode 100644 testsuite/tests/splice-imports/SI21.hs
create mode 100644 testsuite/tests/splice-imports/SI21.stderr
create mode 100644 testsuite/tests/splice-imports/SI22.hs
create mode 100644 testsuite/tests/splice-imports/SI22.stderr
create mode 100644 testsuite/tests/splice-imports/SI23.hs
create mode 100644 testsuite/tests/splice-imports/SI23A.hs
create mode 100644 testsuite/tests/splice-imports/SI24.hs
create mode 100644 testsuite/tests/splice-imports/SI25.hs
create mode 100644 testsuite/tests/splice-imports/SI25.stderr
create mode 100644 testsuite/tests/splice-imports/SI25Helper.hs
create mode 100644 testsuite/tests/splice-imports/SI26.hs
create mode 100644 testsuite/tests/splice-imports/SI27.hs
create mode 100644 testsuite/tests/splice-imports/SI27.stderr
create mode 100644 testsuite/tests/splice-imports/SI28.hs
create mode 100644 testsuite/tests/splice-imports/SI28.stderr
create mode 100644 testsuite/tests/splice-imports/SI29.hs
create mode 100644 testsuite/tests/splice-imports/SI29.stderr
create mode 100644 testsuite/tests/splice-imports/SI30.script
create mode 100644 testsuite/tests/splice-imports/SI30.stdout
create mode 100644 testsuite/tests/splice-imports/SI31.script
create mode 100644 testsuite/tests/splice-imports/SI31.stderr
create mode 100644 testsuite/tests/splice-imports/SI32.script
create mode 100644 testsuite/tests/splice-imports/SI32.stdout
create mode 100644 testsuite/tests/splice-imports/SI33.script
create mode 100644 testsuite/tests/splice-imports/SI33.stdout
create mode 100644 testsuite/tests/splice-imports/SI34.hs
create mode 100644 testsuite/tests/splice-imports/SI34.stderr
create mode 100644 testsuite/tests/splice-imports/SI34M1.hs
create mode 100644 testsuite/tests/splice-imports/SI34M2.hs
create mode 100644 testsuite/tests/splice-imports/SI35.hs
create mode 100644 testsuite/tests/splice-imports/SI35A.hs
create mode 100644 testsuite/tests/splice-imports/SI36.hs
create mode 100644 testsuite/tests/splice-imports/SI36.stderr
create mode 100644 testsuite/tests/splice-imports/SI36_A.hs
create mode 100644 testsuite/tests/splice-imports/SI36_B1.hs
create mode 100644 testsuite/tests/splice-imports/SI36_B2.hs
create mode 100644 testsuite/tests/splice-imports/SI36_B3.hs
create mode 100644 testsuite/tests/splice-imports/SI36_C1.hs
create mode 100644 testsuite/tests/splice-imports/SI36_C2.hs
create mode 100644 testsuite/tests/splice-imports/SI36_C3.hs
create mode 100644 testsuite/tests/splice-imports/all.T
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 2701cb7aec3..4c5ccd07a06 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1504,7 +1504,8 @@ availsToGlobalRdrEnv hsc_env mod avails
imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,
is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,
- is_dloc = srcLocSpan interactiveSrcLoc }
+ is_dloc = srcLocSpan interactiveSrcLoc,
+ is_level = NormalLevel }
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
diff --git a/compiler/GHC/Data/Graph/Directed/Reachability.hs b/compiler/GHC/Data/Graph/Directed/Reachability.hs
index a8d76b2a5b6..56317aa4af0 100644
--- a/compiler/GHC/Data/Graph/Directed/Reachability.hs
+++ b/compiler/GHC/Data/Graph/Directed/Reachability.hs
@@ -9,6 +9,10 @@ module GHC.Data.Graph.Directed.Reachability
-- * Reachability queries
, allReachable, allReachableMany
, isReachable, isReachableMany
+
+ -- * Debugging
+ , reachabilityIndexMembers
+
)
where
@@ -35,6 +39,10 @@ data ReachabilityIndex node = ReachabilityIndex {
to_vertex :: node -> Maybe Vertex
}
+--
+reachabilityIndexMembers :: ReachabilityIndex node -> [node]
+reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index)
+
--------------------------------------------------------------------------------
-- * Construction
--------------------------------------------------------------------------------
@@ -107,7 +115,6 @@ cyclicGraphReachability (Graph g from to) =
-- * The list of nodes /does not/ include the @root@ node!
-- * The list of nodes is deterministically ordered, but according to an
-- internal order determined by the indices attributed to graph nodes.
--- * This function has $O(1)$ complexity.
--
-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead.
allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -}
@@ -139,7 +146,6 @@ allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList h
--
-- Properties:
-- * No self loops, i.e. @isReachable _ a a == False@
--- * This function has $O(1)$ complexity.
isReachable :: ReachabilityIndex node {-^ @g@ -}
-> node -- ^ @a@
-> node -- ^ @b@
@@ -155,17 +161,18 @@ isReachable (ReachabilityIndex index _ to) a b =
-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@
-- asks whether @b@ can be reached through @g@ from any of the @roots@.
--
+-- By partially applying this function to a set of roots, the resulting function can
+-- be applied many times and share the initial work.
+--
-- Properties:
-- * No self loops, i.e. @isReachableMany _ [a] a == False@
--- * This function is $O(n)$ in the number of roots
isReachableMany :: ReachabilityIndex node -- ^ @g@
-> [node] -- ^ @roots@
- -> node -- ^ @b@
- -> Bool -- ^ @b@ is reachable from any of the @roots@
-isReachableMany (ReachabilityIndex index _ to) roots b =
- IS.member b_i $
- IS.unions $
- map (expectJust . flip IM.lookup index) roots_i
- where roots_i = [ v | Just v <- map to roots ]
- b_i = expectJust $ to b
-
+ -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@
+isReachableMany (ReachabilityIndex index _ to) roots =
+ let roots_i = [ v | Just v <- map to roots ]
+ unions =
+ IS.unions $
+ map (expectJust . flip IM.lookup index) roots_i
+ in \b -> let b_i = expectJust $ to b
+ in IS.member b_i unions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 9a098efec2b..ddbd21fd19d 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -51,6 +51,7 @@ import GHC.Types.SourceError
import GHC.Types.SourceFile
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
+import GHC.Types.Basic (convImportLevel)
import GHC.Utils.Outputable
import GHC.Utils.Fingerprint
@@ -584,7 +585,7 @@ mkBackpackMsg = do
NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of
MustCompile -> empty
RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
- ModuleNode _ _ ->
+ ModuleNode {} ->
case recomp of
UpToDate
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
@@ -803,7 +804,7 @@ summariseRequirement pn mod_name = do
ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp,
ms_srcimps = [],
- ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,
+ ms_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc) <$> extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule {
hpm_module = L loc (HsModule {
hsmodExt = XModulePs {
@@ -823,7 +824,7 @@ summariseRequirement pn mod_name = do
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing
}
- let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]
+ let nodes = [mkModuleEdge NormalLevel (NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit))) | mn <- extra_sig_imports ]
return (ModuleNode nodes (ModuleNodeCompile ms))
summariseDecl :: PackageName
@@ -881,7 +882,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_prelude imps
rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
- convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
+ convImport (L _ i) = (convImportLevel (ideclLevelSpec i), rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
@@ -902,13 +903,13 @@ hsModuleToModSummary home_keys pn hsc_src modname
Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing,
- ms_srcimps = map convImport src_idecls,
+ ms_srcimps = (\i -> reLoc (ideclName (unLoc i))) <$> src_idecls,
ms_textual_imps = normal_imports
-- We have to do something special here:
-- due to merging, requirements may end up with
-- extra imports
- ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)
- ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),
+ ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports)
+ ++ ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs),
-- This is our hack to get the parse tree to the right spot
ms_parsed_mod = Just (HsParsedModule {
hpm_module = hsmod,
@@ -928,12 +929,12 @@ hsModuleToModSummary home_keys pn hsc_src modname
let inst_nodes = map NodeKey_Unit inst_deps
mod_nodes =
-- hs-boot edge
- [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++
+ [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++
-- Normal edges
- [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]
+ [k | (_, _, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]
- return (ModuleNode (mod_nodes ++ inst_nodes) (ModuleNodeCompile ms))
+ return (ModuleNode (map mkNormalEdge (mod_nodes ++ inst_nodes)) (ModuleNodeCompile ms))
-- | Create a new, externally provided hashed unit id from
-- a hash.
diff --git a/compiler/GHC/Driver/Downsweep.hs b/compiler/GHC/Driver/Downsweep.hs
index 7f55db8e404..dafe1f834dc 100644
--- a/compiler/GHC/Driver/Downsweep.hs
+++ b/compiler/GHC/Driver/Downsweep.hs
@@ -13,6 +13,7 @@ module GHC.Driver.Downsweep
, downsweepThunk
, downsweepInstalledModules
, downsweepFromRootNodes
+ , downsweepInteractiveImports
, DownsweepMode(..)
-- * Summary functions
, summariseModule
@@ -49,6 +50,9 @@ import GHC.Iface.Load
import GHC.Parser.Header
import GHC.Rename.Names
import GHC.Tc.Utils.Backpack
+import GHC.Runtime.Context
+
+import Language.Haskell.Syntax.ImpExp
import GHC.Data.Graph.Directed
import GHC.Data.FastString
@@ -76,6 +80,8 @@ import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.Map
import GHC.Types.PkgQual
+import GHC.Types.Basic
+
import GHC.Unit
import GHC.Unit.Env
@@ -85,6 +91,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Deps
import qualified GHC.Unit.Home.Graph as HUG
+import GHC.Unit.Module.Stage
import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
@@ -98,7 +105,7 @@ import Data.Maybe
import Data.List (partition)
import Data.Time
import Data.List (unfoldr)
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
import System.Directory
import System.FilePath
@@ -235,6 +242,86 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
(GhcDriverMessage <$> unionManyMessages errs)
return (mkModuleGraph mg)
+-- | Construct a module graph starting from the interactive context.
+-- Produces, a thunk, which when forced will perform the downsweep.
+-- This graph contains the current interactive module, and its dependencies.
+--
+-- Invariant: The hsc_mod_graph already contains the relevant home modules which
+-- might be imported by the interactive imports.
+--
+-- This is a first approximation for this function. There probably should also
+-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6
+-- and so on)
+-- See Note [runTcInteractive module graph]
+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph
+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
+ debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")
+ let imps = ic_imports (hsc_IC hsc_env)
+
+ let interactive_mn = icInteractiveModule ic
+ -- No sensible value for ModLocation.. if you hit this panic then you probably
+ -- need to add proper support for modules without any source files to the driver.
+ let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)
+ let key = moduleToMnk interactive_mn NotBoot
+ let node_type = ModuleNodeFixed key ml
+
+ -- The existing nodes in the module graph. This will be populated when GHCi runs
+ -- :load. Any home package modules need to already be in here.
+ let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]
+
+ (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes
+ let interactive_node = ModuleNode module_edges node_type
+
+ let all_nodes = M.elems graph
+ return $ mkModuleGraph (interactive_node : all_nodes)
+
+ where
+ --
+ mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))
+ -- A simple edge to a module from the same home unit
+ mkEdge (IIModule n) =
+ let unitId = homeUnitId $ hsc_home_unit hsc_env
+ in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot)
+ -- A complete import statement
+ mkEdge (IIDecl i) =
+ let lvl = convImportLevel (ideclLevelSpec i)
+ wanted_mod = unLoc (ideclName i)
+ is_boot = ideclSource i
+ mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)
+ unitId = homeUnitId $ hsc_home_unit hsc_env
+ in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)
+
+loopFromInteractive :: HscEnv
+ -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ -> M.Map NodeKey ModuleGraphNode
+ -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
+loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
+loopFromInteractive hsc_env (edge:edges) cached_nodes = do
+ let (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) = edge
+ let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
+ let k _ loc mod =
+ let key = moduleToMnk mod is_boot
+ in return $ FoundHome (ModuleNodeFixed key loc)
+ found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []
+ case found of
+ -- Case 1: Home modules have to already be in the cache.
+ FoundHome (ModuleNodeFixed mod _) -> do
+ let edge = ModuleNodeEdge lvl (NodeKey_Module mod)
+ -- Note: Does not perform any further downsweep as the module must already be in the cache.
+ (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
+ return (edge : edges, cached_nodes')
+ -- Case 2: External units may not be in the cache, if we haven't already initialised the
+ -- module graph. We can construct the module graph for those here by calling loopUnit.
+ External uid -> do
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
+ cached_nodes' = loopUnit hsc_env' cached_nodes [uid]
+ edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)
+ (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'
+ return (edge : edges, cached_nodes')
+ -- And if it's not found.. just carry on and hope.
+ _ -> loopFromInteractive hsc_env edges cached_nodes
+
+
-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
-- isn't already an existing module graph. For example, when loading plugins
@@ -297,13 +384,16 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
= do
let root_map = mkRootMap root_nodes
checkDuplicates root_map
- (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
- let all_deps = loopUnit hsc_env module_deps root_uids
+ let env = DownsweepEnv hsc_env mode old_summaries excl_mods
+ (deps', map0) <- runDownsweepM env $ do
+ (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
+ let all_deps = loopUnit hsc_env module_deps root_uids
+ let all_instantiations = getHomeUnitInstantiations hsc_env
+ deps' <- loopInstantiations all_instantiations all_deps
+ return (deps', map0)
- let all_instantiations = getHomeUnitInstantiations hsc_env
- let deps' = loopInstantiations all_instantiations all_deps
- downsweep_errs = lefts $ concat $ M.elems map0
+ let downsweep_errs = lefts $ concat $ M.elems map0
downsweep_nodes = M.elems deps'
return (downsweep_errs, downsweep_nodes)
@@ -311,14 +401,6 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)
-
- calcDeps ms =
- -- Add a dependency on the HsBoot file if it exists
- -- This gets passed to the loopImports function which just ignores it if it
- -- can't be found.
- [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
- [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]
-
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
@@ -334,205 +416,231 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
- loopInstantiations :: [(UnitId, InstantiatedUnit)]
- -> M.Map NodeKey ModuleGraphNode
- -> M.Map NodeKey ModuleGraphNode
- loopInstantiations [] done = done
- loopInstantiations ((home_uid, iud) :xs) done =
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
- payload = InstantiationNode home_uid iud
- in loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
-
- where
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
-
-
- -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
- loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode,
- DownsweepCache)
- -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
- loopSummaries [] done = return done
- loopSummaries (ms:next) (done, summarised)
- | Just {} <- M.lookup k done
- = loopSummaries next (done, summarised)
- -- Didn't work out what the imports mean yet, now do that.
- | otherwise = do
- (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
- where
- k = NodeKey_Module (msKey ms)
-
- hs_file_for_boot
- | HsBootFile <- ms_hsc_src ms
- = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
- | otherwise
- = Nothing
-
- loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
- loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
-
- loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
- loopModuleNodeInfo mod_node_info (done, summarised) = do
- case mod_node_info of
- ModuleNodeCompile ms -> do
- loopSummaries [ms] (done, summarised)
- ModuleNodeFixed mod ml -> do
- done' <- loopFixedModule mod ml done
- return (done', summarised)
-
- -- NB: loopFixedModule does not take a downsweep cache, because if you
- -- ever reach a Fixed node, everything under that also must be fixed.
- loopFixedModule :: ModNodeKeyWithUid -> ModLocation
- -> M.Map NodeKey ModuleGraphNode
- -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedModule key loc done = do
- let nk = NodeKey_Module key
- case M.lookup nk done of
- Just {} -> return done
- Nothing -> do
- -- MP: TODO, we should just read the dependency info from the interface rather than either
- -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
- -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
- read_result <-
- -- 1. Check if the interface is already loaded into the EPS by some other
- -- part of the compiler.
- lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
- Just iface -> return (M.Succeeded iface)
- Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
- case read_result of
- M.Succeeded iface -> do
- -- Computer information about this node
- let node_deps = ifaceDeps (mi_deps iface)
- edges = map (either NodeKey_Module NodeKey_ExternalUnit) node_deps
- node = ModuleNode edges (ModuleNodeFixed key loc)
- foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) node_deps
- -- Ignore any failure, we might try to read a .hi-boot file for
- -- example, even if there is not one.
- M.Failed {} ->
- return done
-
- loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedNodeKey _ done (Left key) = do
- loopFixedImports [key] done
- loopFixedNodeKey home_uid done (Right uid) = do
- -- Set active unit so that looking loopUnit finds the correct
- -- -package flags in the unit state.
- let hsc_env' = hscSetActiveUnitId home_uid hsc_env
- return $ loopUnit hsc_env' done [uid]
-
-
- ifaceDeps :: Dependencies -> [Either ModNodeKeyWithUid UnitId]
- ifaceDeps deps =
- [ Left (ModNodeKeyWithUid dep uid)
- | (uid, dep) <- Set.toList (dep_direct_mods deps)
- ] ++
- [ Right uid
- | uid <- Set.toList (dep_direct_pkgs deps)
- ]
-
- -- Like loopImports, but we already know exactly which module we are looking for.
- loopFixedImports :: [ModNodeKeyWithUid]
- -> M.Map NodeKey ModuleGraphNode
- -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedImports [] done = pure done
- loopFixedImports (key:keys) done = do
- let nk = NodeKey_Module key
- case M.lookup nk done of
- Just {} -> loopFixedImports keys done
- Nothing -> do
- read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
- case read_result of
- InstalledFound loc -> do
- done' <- loopFixedModule key loc done
- loopFixedImports keys done'
- _otherwise ->
- -- If the finder fails, just keep going, there will be another
- -- error later.
- loopFixedImports keys done
-
- downsweepSummarise :: HscEnv
- -> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary
- -> IsBootInterface
- -> Located ModuleName
- -> PkgQual
- -> Maybe (StringBuffer, UTCTime)
- -> [ModuleName]
- -> IO SummariseResult
- downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =
- case mode of
- DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
- DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
-
-
- -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
- -- a new module by doing this.
- loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
- -- Work list: process these modules
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepCache
- -- Visited set; the range is a list because
- -- the roots can have the same module names
- -- if allow_dup_roots is True
- -> IO ([NodeKey],
- M.Map NodeKey ModuleGraphNode, DownsweepCache)
- -- The result is the completed NodeMap
- loopImports [] done summarised = return ([], done, summarised)
- loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised
- | Just summs <- M.lookup cache_key summarised
- = case summs of
- [Right ms] -> do
- let nk = NodeKey_Module (mnKey ms)
- (rest, summarised', done') <- loopImports ss done summarised
- return (nk: rest, summarised', done')
- [Left _err] ->
- loopImports ss done summarised
- _errs -> do
- loopImports ss done summarised
- | otherwise
- = do
- mb_s <- downsweepSummarise hsc_env home_unit old_summaries
- is_boot wanted_mod mb_pkg
- Nothing excl_mods
- case mb_s of
- NotThere -> loopImports ss done summarised
- External uid -> do
- -- Pass an updated hsc_env to loopUnit, as each unit might
- -- have a different visible package database.
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- let done' = loopUnit hsc_env' done [uid]
- (other_deps, done'', summarised') <- loopImports ss done' summarised
- return (NodeKey_ExternalUnit uid : other_deps, done'', summarised')
- FoundInstantiation iud -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (NodeKey_Unit iud : other_deps, done', summarised')
- FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
- FoundHome s -> do
- (done', summarised') <-
- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
- (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-
- -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (NodeKey_Module (mnKey s) : other_deps, final_done, final_summarised)
- where
- cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
- wanted_mod = L loc mod
-
- loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
- loopUnit _ cache [] = cache
- loopUnit lcl_hsc_env cache (u:uxs) = do
- let nk = (NodeKey_ExternalUnit u)
- case Map.lookup nk cache of
- Just {} -> loopUnit lcl_hsc_env cache uxs
- Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
- Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
- Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
+
+calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+calcDeps ms =
+ -- Add a dependency on the HsBoot file if it exists
+ -- This gets passed to the loopImports function which just ignores it if it
+ -- can't be found.
+ [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
+ [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]
+
+
+type DownsweepM a = ReaderT DownsweepEnv IO a
+data DownsweepEnv = DownsweepEnv {
+ downsweep_hsc_env :: HscEnv
+ , _downsweep_mode :: DownsweepMode
+ , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary
+ , _downsweep_excl_mods :: [ModuleName]
+}
+
+runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
+runDownsweepM env act = runReaderT act env
+
+
+loopInstantiations :: [(UnitId, InstantiatedUnit)]
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopInstantiations [] done = pure done
+loopInstantiations ((home_uid, iud) :xs) done = do
+ hsc_env <- asks downsweep_hsc_env
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
+ done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
+ payload = InstantiationNode home_uid iud
+ loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
+
+
+-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
+loopSummaries :: [ModSummary]
+ -> (M.Map NodeKey ModuleGraphNode,
+ DownsweepCache)
+ -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
+loopSummaries [] done = pure done
+loopSummaries (ms:next) (done, summarised)
+ | Just {} <- M.lookup k done
+ = loopSummaries next (done, summarised)
+ -- Didn't work out what the imports mean yet, now do that.
+ | otherwise = do
+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
+ where
+ k = NodeKey_Module (msKey ms)
+
+ hs_file_for_boot
+ | HsBootFile <- ms_hsc_src ms
+ = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
+ | otherwise
+ = Nothing
+
+loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
+
+loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
+loopModuleNodeInfo mod_node_info (done, summarised) = do
+ case mod_node_info of
+ ModuleNodeCompile ms -> do
+ loopSummaries [ms] (done, summarised)
+ ModuleNodeFixed mod ml -> do
+ done' <- loopFixedModule mod ml done
+ return (done', summarised)
+
+-- NB: loopFixedModule does not take a downsweep cache, because if you
+-- ever reach a Fixed node, everything under that also must be fixed.
+loopFixedModule :: ModNodeKeyWithUid -> ModLocation
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedModule key loc done = do
+ let nk = NodeKey_Module key
+ hsc_env <- asks downsweep_hsc_env
+ case M.lookup nk done of
+ Just {} -> return done
+ Nothing -> do
+ -- MP: TODO, we should just read the dependency info from the interface rather than either
+ -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
+ -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
+ read_result <- liftIO $
+ -- 1. Check if the interface is already loaded into the EPS by some other
+ -- part of the compiler.
+ lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
+ Just iface -> return (M.Succeeded iface)
+ Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+ case read_result of
+ M.Succeeded iface -> do
+ -- Computer information about this node
+ let node_deps = ifaceDeps (mi_deps iface)
+ edges = map mkFixedEdge node_deps
+ node = ModuleNode edges (ModuleNodeFixed key loc)
+ foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
+ -- Ignore any failure, we might try to read a .hi-boot file for
+ -- example, even if there is not one.
+ M.Failed {} ->
+ return done
+
+loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedNodeKey _ done (Left key) = do
+ loopFixedImports [key] done
+loopFixedNodeKey home_uid done (Right uid) = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ hsc_env <- asks downsweep_hsc_env
+ let hsc_env' = hscSetActiveUnitId home_uid hsc_env
+ return $ loopUnit hsc_env' done [uid]
+
+mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+
+ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
+ifaceDeps deps =
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
+ ] ++
+ [ Right (tcImportLevel lvl, uid)
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
+ ]
+
+-- Like loopImports, but we already know exactly which module we are looking for.
+loopFixedImports :: [ModNodeKeyWithUid]
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedImports [] done = pure done
+loopFixedImports (key:keys) done = do
+ let nk = NodeKey_Module key
+ hsc_env <- asks downsweep_hsc_env
+ case M.lookup nk done of
+ Just {} -> loopFixedImports keys done
+ Nothing -> do
+ read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
+ case read_result of
+ InstalledFound loc -> do
+ done' <- loopFixedModule key loc done
+ loopFixedImports keys done'
+ _otherwise ->
+ -- If the finder fails, just keep going, there will be another
+ -- error later.
+ loopFixedImports keys done
+
+downsweepSummarise :: HomeUnit
+ -> IsBootInterface
+ -> Located ModuleName
+ -> PkgQual
+ -> Maybe (StringBuffer, UTCTime)
+ -> DownsweepM SummariseResult
+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
+ DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
+ case mode of
+ DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
+ DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
+
+
+-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
+-- a new module by doing this.
+loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ -- Work list: process these modules
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepCache
+ -- Visited set; the range is a list because
+ -- the roots can have the same module names
+ -- if allow_dup_roots is True
+ -> DownsweepM ([ModuleNodeEdge],
+ M.Map NodeKey ModuleGraphNode, DownsweepCache)
+ -- The result is the completed NodeMap
+loopImports [] done summarised = return ([], done, summarised)
+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
+ | Just summs <- M.lookup cache_key summarised
+ = case summs of
+ [Right ms] -> do
+ let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
+ (rest, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, summarised', done')
+ [Left _err] ->
+ loopImports ss done summarised
+ _errs -> do
+ loopImports ss done summarised
+ | otherwise
+ = do
+ hsc_env <- asks downsweep_hsc_env
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ mb_s <- downsweepSummarise home_unit
+ is_boot wanted_mod mb_pkg
+ Nothing
+ case mb_s of
+ NotThere -> loopImports ss done summarised
+ External uid -> do
+ -- Pass an updated hsc_env to loopUnit, as each unit might
+ -- have a different visible package database.
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
+ let done' = loopUnit hsc_env' done [uid]
+ (other_deps, done'', summarised') <- loopImports ss done' summarised
+ return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
+ FoundInstantiation iud -> do
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
+ FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
+ FoundHome s -> do
+ (done', summarised') <-
+ loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
+
+ -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
+ return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
+ where
+ cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
+ GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
+ wanted_mod = L loc mod
+
+loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
+loopUnit _ cache [] = cache
+loopUnit lcl_hsc_env cache (u:uxs) = do
+ let nk = (NodeKey_ExternalUnit u)
+ case Map.lookup nk cache of
+ Just {} -> loopUnit lcl_hsc_env cache uxs
+ Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
+ Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
multiRootsErr :: [ModuleNodeInfo] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
@@ -775,7 +883,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
, ms_hsc_src = HsSrcFile
, ms_hspp_opts = dflags
} <- ms
- , Just enable_spec <- needs_codegen_map (NodeKey_Module (msKey ms)) =
+ , Just enable_spec <- needs_codegen_map ms =
if | nocode_enable ms -> do
let new_temp_file suf dynsuf = do
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
@@ -866,6 +974,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-- the linker can correctly load the object files. This isn't necessary
-- when using -fexternal-interpreter.
+ -- FIXME: Duplicated from makeDynFlagsConsistent
dynamic_too_enable enable_spec ms
| sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags =
not isDynWay && not dyn_too_enabled
@@ -893,44 +1002,61 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
lcl_dflags = ms_hspp_opts ms
internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
+
mg = mkModuleGraph mod_graph
- needs_obj_set, needs_bc_set :: NodeKey -> Bool
- needs_obj_set k = mgQueryMany mg need_obj_set k || k `elem` need_obj_set
+ (td_map, lookup_node) = mkStageDeps mod_graph
- needs_bc_set k = mgQueryMany mg need_bc_set k || k `elem` need_bc_set
+ queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns)
- -- A map which tells us how to enable code generation for a NodeKey
- needs_codegen_map :: NodeKey -> Maybe CodeGenEnable
- needs_codegen_map nk =
- -- Another option here would be to just produce object code, rather than both object and
- -- byte code
- case (needs_obj_set nk, needs_bc_set nk) of
- (True, True) -> Just EnableByteCodeAndObject
- (True, False) -> Just EnableObject
- (False, True) -> Just EnableByteCode
- (False, False) -> Nothing
+ -- NB: Do not inline these, it is very important to share them across all calls
+ -- to needs_obj_set and needs_bc_set.
+ !query_obj =
+ let !deps = queryReachable need_obj_set
+ in \k -> deps (expectJust $ lookup_node k)
+
+ !query_bc =
+ let !deps = queryReachable need_bc_set
+ in \k -> deps (expectJust $ lookup_node k)
-- The direct dependencies of modules which require object code
need_obj_set =
- concat
+
-- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
-- it's dependencies.
- [ deps
- | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph
+ [ (mkNodeKey m, RunStage)
+ | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
]
-- The direct dependencies of modules which require byte code
need_bc_set =
- concat
- [ deps
- | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph
+ [ (mkNodeKey m, RunStage)
+ | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
]
+ needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool
+ needs_obj_set k = query_obj (NodeKey_Module k, CompileStage)
+
+ needs_bc_set k = query_bc (NodeKey_Module k, CompileStage)
+
+ -- A map which tells us how to enable code generation for a NodeKey
+ needs_codegen_map :: ModSummary -> Maybe CodeGenEnable
+ needs_codegen_map ms =
+ let nk = msKey ms
+
+
+ -- Another option here would be to just produce object code, rather than both object and
+ -- byte code
+ in case (needs_obj_set nk, needs_bc_set nk) of
+ (True, True) -> Just EnableByteCodeAndObject
+ (True, False) -> Just EnableObject
+ (False, True) -> Just EnableByteCode
+ (False, False) -> Nothing
+
-- FIXME: Duplicated from makeDynFlagsConsistent
needs_full_ways dflags
= ghcLink dflags == LinkInMemory &&
@@ -994,12 +1120,22 @@ for Template Haskell are written to temporary files.
Note that since Template Haskell can run arbitrary IO actions, -fno-code mode
is no more secure than running without it.
+Explicit Level Imports
+~~~~~~~~~~~~~~~~~~~~~~
+When `-XExplicitLevelImports` is enabled, code is only generated for modules
+needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers
+the question, if I compile a module for a specific stage, then which modules at
+other stages do I need. The roots of this query are the modules which use `TemplateHaskell`
+at the runtime stage, and modules we need code generation for are those which
+are needed at the compile time stage. All the logic about how ExplicitLevelImports
+and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps.
+
Potential TODOS:
~~~~~
* Remove -fwrite-interface and have interface files always written in -fno-code
mode
* Both .o and .dyn_o files are generated for template haskell, but we only need
- .dyn_o. Fix it.
+ .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays')
* In make mode, a message like
Compiling A (A.hs, /tmp/ghc_123.o)
is shown if downsweep enabled object code generation for A. Perhaps we should
@@ -1351,8 +1487,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
, ms_parsed_mod = Nothing
, ms_srcimps = pi_srcimps
, ms_textual_imps =
- ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++
- ((,) NoPkgQual . noLoc <$> implicit_sigs) ++
+ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++
+ ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) ++
pi_theimps
, ms_hs_hash = nms_src_hash
, ms_iface_date = hi_timestamp
@@ -1364,8 +1500,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
data PreprocessedImports
= PreprocessedImports
{ pi_local_dflags :: DynFlags
- , pi_srcimps :: [(PkgQual, Located ModuleName)]
- , pi_theimps :: [(PkgQual, Located ModuleName)]
+ , pi_srcimps :: [Located ModuleName]
+ , pi_theimps :: [(ImportLevel, PkgQual, Located ModuleName)]
, pi_hspp_fn :: FilePath
, pi_hspp_buf :: StringBuffer
, pi_mod_name_loc :: SrcSpan
@@ -1392,7 +1528,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
- let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
- let pi_srcimps = rn_imps pi_srcimps'
+ let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))
+ let pi_srcimps = pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
return PreprocessedImports {..}
diff --git a/compiler/GHC/Driver/DynFlags.hs b/compiler/GHC/Driver/DynFlags.hs
index c3682314b20..7973b83ee68 100644
--- a/compiler/GHC/Driver/DynFlags.hs
+++ b/compiler/GHC/Driver/DynFlags.hs
@@ -1323,7 +1323,8 @@ languageExtensions (Just Haskell98)
-- default unless you specify another language.
LangExt.DeepSubsumption,
-- Non-standard but enabled for backwards compatability (see GHC proposal #511)
- LangExt.ListTuplePuns
+ LangExt.ListTuplePuns,
+ LangExt.ImplicitStagePersistence
]
languageExtensions (Just Haskell2010)
@@ -1341,7 +1342,9 @@ languageExtensions (Just Haskell2010)
LangExt.FieldSelectors,
LangExt.RelaxedPolyRec,
LangExt.DeepSubsumption,
- LangExt.ListTuplePuns ]
+ LangExt.ListTuplePuns,
+ LangExt.ImplicitStagePersistence
+ ]
languageExtensions (Just GHC2021)
= [LangExt.ImplicitPrelude,
@@ -1392,7 +1395,9 @@ languageExtensions (Just GHC2021)
LangExt.TupleSections,
LangExt.TypeApplications,
LangExt.TypeOperators,
- LangExt.TypeSynonymInstances]
+ LangExt.TypeSynonymInstances,
+ LangExt.ImplicitStagePersistence
+ ]
languageExtensions (Just GHC2024)
= languageExtensions (Just GHC2021) ++
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 79ff8de6afc..0efa9b539d7 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -259,6 +259,8 @@ extensionName = \case
LangExt.ExtendedLiterals -> "ExtendedLiterals"
LangExt.ListTuplePuns -> "ListTuplePuns"
LangExt.MultilineStrings -> "MultilineStrings"
+ LangExt.ExplicitLevelImports -> "ExplicitLevelImports"
+ LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence"
-- | Is this extension known by any other names? For example
-- -XGeneralizedNewtypeDeriving is accepted
@@ -352,6 +354,8 @@ impliedXFlags
-- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind
, (LangExt.LinearTypes, On LangExt.MonoLocalBinds)
+
+ , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence)
]
@@ -1087,7 +1091,7 @@ data WarningFlag =
| Opt_WarnImplicitRhsQuantification -- ^ @since 9.8
| Opt_WarnIncompleteExportWarnings -- ^ @since 9.8
| Opt_WarnIncompleteRecordSelectors -- ^ @since 9.10
- | Opt_WarnBadlyStagedTypes -- ^ @since 9.10
+ | Opt_WarnBadlyLevelledTypes -- ^ @since 9.10
| Opt_WarnInconsistentFlags -- ^ @since 9.8
| Opt_WarnDataKindsTC -- ^ @since 9.10
| Opt_WarnDefaultedExceptionContext -- ^ @since 9.10
@@ -1210,7 +1214,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| []
Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| []
Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| []
- Opt_WarnBadlyStagedTypes -> "badly-staged-types" :| []
+ Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| []
Opt_WarnInconsistentFlags -> "inconsistent-flags" :| []
Opt_WarnDataKindsTC -> "data-kinds-tc" :| []
Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| []
@@ -1355,7 +1359,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnOperatorWhitespaceExtConflict,
Opt_WarnUnicodeBidirectionalFormatCharacters,
Opt_WarnGADTMonoLocalBinds,
- Opt_WarnBadlyStagedTypes,
+ Opt_WarnBadlyLevelledTypes,
Opt_WarnTypeEqualityRequiresOperators,
Opt_WarnInconsistentFlags,
Opt_WarnDataKindsTC,
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index c3c53f1e85c..da026b01400 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -458,7 +458,7 @@ warnUnusedPackages us dflags mod_graph =
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
used_args = Set.fromList (map unitId loadedPackages)
@@ -1194,7 +1194,6 @@ upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = d
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])
-
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int -- index of module
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 9c081d08b07..2b3bbdb7293 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -282,10 +282,10 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
; let do_imps is_boot idecls = sequence_
[ do_imp loc is_boot mb_pkg mod
- | (mb_pkg, L loc mod) <- idecls,
+ | (_lvl, mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
- ; do_imps IsBoot (ms_srcimps node)
+ ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node))
; do_imps NotBoot (ms_imps node)
}
@@ -428,7 +428,8 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True
is_boot_key _ = False
is_boot_only n@(ModuleNode deps ms) =
- let non_boot_deps = filter (not . is_boot_key) deps
+ let dep_mods = map edgeTargetKey deps
+ non_boot_deps = filter (not . is_boot_key) dep_mods
in if not (any in_group non_boot_deps)
then Left (deps, ms)
else Right n
@@ -441,9 +442,9 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
groups =
GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
- pp_mod :: [NodeKey] -> ModuleNodeInfo -> SDoc
+ pp_mod :: [ModuleNodeEdge] -> ModuleNodeInfo -> SDoc
pp_mod deps mn =
- text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps deps
+ text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps (map edgeTargetKey deps)
where
mod_str = moduleNameString (moduleNodeInfoModuleName mn)
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index ed66fec3848..ea01b4e10fc 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -403,7 +403,9 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt
_ -> False
-- the packages we depend on
- pkg_deps <- Set.toList <$> hptCollectDependencies hpt
+ -- TODO: This should be a query on the 'ModuleGraph', since we need to
+ -- know which packages are actually needed at the runtime stage.
+ pkg_deps <- map snd . Set.toList <$> hptCollectDependencies hpt
-- the linkables to link
linkables <- hptCollectObjects hpt
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index afafd55d6d9..75244d20bf0 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -709,12 +709,12 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
- rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
+ rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
Left errs -> throwErrors (GhcPsMessage <$> errs)
Right (src_imps,imps, L _ mod_name) -> return
- (Just buf, mod_name, rn_imps imps, rn_imps src_imps)
+ (Just buf, mod_name, rn_imps imps, src_imps)
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index dcd0a151301..aeed58acaaf 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2265,7 +2265,9 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
Opt_WarnAmbiguousFields -> warnSpec x
Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"
Opt_WarnCPPUndef -> warnSpec x
- Opt_WarnBadlyStagedTypes -> warnSpec x
+ Opt_WarnBadlyLevelledTypes ->
+ warnSpec x ++
+ subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types"
Opt_WarnUnbangedStrictPatterns -> warnSpec x
Opt_WarnDeferredTypeErrors -> warnSpec x
Opt_WarnDeferredOutOfScopeVariables -> warnSpec x
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 3db8fe5c617..1f640156b23 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -8,6 +8,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
+{-# LANGUAGE MultiWayIf #-}
+
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -57,15 +59,7 @@ One per import declaration in a module.
type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA
--- | Given two possible located 'qualified' tokens, compute a style
--- (in a conforming Haskell program only one of the two can be not
--- 'Nothing'). This is called from "GHC.Parser".
-importDeclQualifiedStyle :: Maybe (EpToken "qualified")
- -> Maybe (EpToken "qualified")
- -> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-importDeclQualifiedStyle mPre mPost =
- if isJust mPre then (mPre, QualifiedPre)
- else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified)
+
-- | Convenience function to answer the question if an import decl. is
-- qualified.
@@ -74,6 +68,7 @@ isImportDeclQualified NotQualified = False
isImportDeclQualified _ = True
+
type instance ImportDeclPkgQual GhcPs = RawPkgQual
type instance ImportDeclPkgQual GhcRn = PkgQual
type instance ImportDeclPkgQual GhcTc = PkgQual
@@ -114,13 +109,24 @@ data EpAnnImportDecl = EpAnnImportDecl
{ importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword
, importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively
, importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword
+ , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword
, importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword
, importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@)
, importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword
} deriving (Data)
+
instance NoAnn EpAnnImportDecl where
- noAnn = EpAnnImportDecl noAnn Nothing Nothing Nothing Nothing Nothing
+ noAnn = EpAnnImportDecl noAnn Nothing Nothing noAnn Nothing Nothing Nothing
+
+data EpAnnLevel = EpAnnLevelSplice (EpToken "splice")
+ | EpAnnLevelQuote (EpToken "quote")
+ deriving Data
+
+instance HasLoc EpAnnLevel where
+ getHasLoc (EpAnnLevelSplice tok) = getEpTokenSrcSpan tok
+ getHasLoc (EpAnnLevelQuote tok) = getEpTokenSrcSpan tok
+
-- ---------------------------------------------------------------------
simpleImportDecl :: ModuleName -> ImportDecl GhcPs
@@ -130,6 +136,7 @@ simpleImportDecl mn = ImportDecl {
ideclPkgQual = NoRawPkgQual,
ideclSource = NotBoot,
ideclSafe = False,
+ ideclLevelSpec = NotLevelled,
ideclQualified = NotQualified,
ideclAs = Nothing,
ideclImportList = Nothing
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 7d15fb3a590..a65eb39cbfd 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -55,6 +55,7 @@ import GHC.Utils.Constants (debugIsOn)
import GHC.Types.Annotations
import GHC.Types.Avail
+import GHC.Types.Basic ( ImportLevel(..) )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
@@ -86,9 +87,10 @@ import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
-import Data.Bifunctor
import GHC.Iface.Errors.Ppr
import Data.Functor
+import Data.Bifunctor (first)
+import GHC.Types.PkgQual
{-
-----------------------------------------------
@@ -174,7 +176,7 @@ instance Monoid RecompileRequired where
mempty = UpToDate
data RecompReason
- = UnitDepRemoved UnitId
+ = UnitDepRemoved (ImportLevel, UnitId)
| ModulePackageChanged FastString
| SourceFileChanged
| NoSelfRecompInfo
@@ -187,8 +189,8 @@ data RecompReason
| HieOutdated
| SigsMergeChanged
| ModuleChanged ModuleName
- | ModuleRemoved (UnitId, ModuleName)
- | ModuleAdded (UnitId, ModuleName)
+ | ModuleRemoved (ImportLevel, UnitId, ModuleName)
+ | ModuleAdded (ImportLevel, UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
@@ -210,7 +212,7 @@ data RecompReason
instance Outputable RecompReason where
ppr = \case
- UnitDepRemoved uid -> ppr uid <+> text "removed"
+ UnitDepRemoved (_lvl, uid) -> ppr uid <+> text "removed"
ModulePackageChanged s -> ftext s <+> text "package changed"
SourceFileChanged -> text "Source file changed"
NoSelfRecompInfo -> text "Old interface lacks recompilation info"
@@ -225,8 +227,8 @@ instance Outputable RecompReason where
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
ModuleChangedIface m -> ppr m <+> text "changed (interface)"
- ModuleRemoved (_uid, m) -> ppr m <+> text "removed"
- ModuleAdded (_uid, m) -> ppr m <+> text "added"
+ ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
+ ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
@@ -633,8 +635,12 @@ checkMergedSignatures hsc_env mod_summary self_recomp = do
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
- res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod) (ms_plugin_imps summary)
+ res_normal <- classify_import (findImportedModule hsc_env)
+ ([(st, p, m) | (st, p, m) <- (ms_textual_imps summary)]
+ ++
+ [(NormalLevel, NoPkgQual, m) | m <- ms_srcimps summary ])
+ res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod)
+ [(st, p, m) | (st, p, m) <- (ms_plugin_imps summary) ]
case sequence (res_normal ++ res_plugin) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
@@ -647,27 +653,27 @@ checkDependencies hsc_env summary iface
where
classify_import :: (ModuleName -> t -> IO FindResult)
- -> [(t, GenLocated l ModuleName)]
+ -> [(ImportLevel, t, GenLocated l ModuleName)]
-> IfG
[Either
- CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
+ CompileReason (Either (ImportLevel, UnitId, ModuleName) (FastString, (ImportLevel, UnitId)))]
classify_import find_import imports =
- liftIO $ traverse (\(mb_pkg, L _ mod) ->
+ liftIO $ traverse (\(st, mb_pkg, L _ mod) ->
let reason = ModuleChanged mod
- in classify reason <$> find_import mod mb_pkg)
+ in classify st reason <$> find_import mod mb_pkg)
imports
logger = hsc_logger hsc_env
all_home_units = hsc_all_home_unit_ids hsc_env
- prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
- prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))
- (dep_plugin_pkgs (mi_deps iface)))
+ prev_dep_mods = map (\(IfaceImportLevel s,u, a) -> (s, u, gwib_mod a)) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
+ prev_dep_pkgs = Set.toAscList (Set.union (Set.map (first tcImportLevel) (dep_direct_pkgs (mi_deps iface)))
+ (Set.map ((SpliceLevel),) (dep_plugin_pkgs (mi_deps iface))))
- classify _ (Found _ mod)
- | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))
- | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod))
- classify reason _ = Left (RecompBecause reason)
+ classify st _ (Found _ mod)
+ | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((st, toUnitId $ moduleUnit mod, moduleName mod)))
+ | otherwise = Right (Right (moduleNameFS (moduleName mod), (st, toUnitId $ moduleUnit mod)))
+ classify _ reason _ = Left (RecompBecause reason)
- check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
+ check_mods :: [(ImportLevel, UnitId, ModuleName)] -> [(ImportLevel, UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = return UpToDate
check_mods [] (old:_) = do
-- This case can happen when a module is change from HPT to package import
@@ -685,14 +691,14 @@ checkDependencies hsc_env summary iface
text " not among previous dependencies"
return $ needsRecompileBecause $ ModuleAdded new
- check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
+ check_packages :: [(FastString, (ImportLevel, UnitId))] -> [(ImportLevel, UnitId)] -> IO RecompileRequired
check_packages [] [] = return UpToDate
check_packages [] (old:_) = do
trace_hi_diffs logger $
text "package " <> quotes (ppr old) <>
text "no longer in dependencies"
return $ needsRecompileBecause $ UnitDepRemoved old
- check_packages ((new_name, new_unit):news) olds
+ check_packages ((new_name, (new_unit)):news) olds
| Just (old, olds') <- uncons olds
, new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds'
| otherwise = do
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 9553e4544e3..307124fdc95 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -477,7 +477,10 @@ tidyProgram opts (ModGuts { mg_module = mod
, cg_ccs = S.toList local_ccs
, cg_foreign = all_foreign_stubs
, cg_foreign_files = foreign_files
- , cg_dep_pkgs = dep_direct_pkgs deps
+ -- TODO: Check whether we need to account for levels here.
+ -- It seems that this field just gets used to write a comment
+ -- in C codegen, so it's value doesn't affect an important result.
+ , cg_dep_pkgs = S.map snd (dep_direct_pkgs deps)
, cg_modBreaks = modBreaks
, cg_spt_entries = spt_entries
}
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 171a1026f7d..58bacbaf051 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -639,6 +639,8 @@ are the most common patterns, rewritten as regular expressions for clarity:
'stock' { L _ ITstock } -- for DerivingStrategies extension
'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
'via' { L _ ITvia } -- for DerivingStrategies extension
+ 'splice' { L _ ITsplice } -- For StagedImports extension
+ 'quote' { L _ ITquote } -- For StagedImports extension
'unit' { L _ ITunit }
'signature' { L _ ITsignature }
@@ -1118,28 +1120,33 @@ importdecls_semi
| {- empty -} { [] }
importdecl :: { LImportDecl GhcPs }
- : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
+ : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec
{% do {
- ; let { ; mPreQual = unLoc $4
- ; mPostQual = unLoc $7 }
- ; checkImportDecl mPreQual mPostQual
+ ; let { ; mPreQual = $5
+ ; mPostQual = $9
+ ; mPreLevel = $3
+ ; mPostLevel = $8 }
+ ; (qualSpec, levelSpec) <- checkImportDecl mPreQual mPostQual mPreLevel mPostLevel
; let anns
= EpAnnImportDecl
{ importDeclAnnImport = epTok $1
, importDeclAnnPragma = fst $ fst $2
- , importDeclAnnSafe = fst $3
- , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual
- , importDeclAnnPackage = fst $5
- , importDeclAnnAs = fst $8
+ , importDeclAnnLevel = fst $ levelSpec
+ , importDeclAnnSafe = fst $4
+ , importDeclAnnQualified = fst $ qualSpec
+ , importDeclAnnPackage = fst $6
+ , importDeclAnnAs = fst $10
}
- ; let loc = (comb5 $1 $6 $7 (snd $8) $9);
+ ; let loc = (comb6 $1 $7 $8 $9 (snd $10) $11);
; fmap reLoc $ acs loc (\loc cs -> L loc $
ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False
- , ideclName = $6, ideclPkgQual = snd $5
- , ideclSource = snd $2, ideclSafe = snd $3
- , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual
- , ideclAs = unLoc (snd $8)
- , ideclImportList = unLoc $9 })
+ , ideclName = $7, ideclPkgQual = snd $6
+ , ideclSource = snd $2
+ , ideclLevelSpec = snd $ levelSpec
+ , ideclSafe = snd $4
+ , ideclQualified = snd $ qualSpec
+ , ideclAs = unLoc (snd $10)
+ , ideclImportList = unLoc $11 })
}
}
@@ -1153,6 +1160,11 @@ maybe_safe :: { (Maybe (EpToken "safe"),Bool) }
: 'safe' { (Just (epTok $1),True) }
| {- empty -} { (Nothing, False) }
+maybe_splice :: { (Maybe EpAnnLevel) }
+ : 'splice' { (Just (EpAnnLevelSplice (epTok $1))) }
+ | 'quote' { (Just (EpAnnLevelQuote (epTok $1))) }
+ | {- empty -} { (Nothing) }
+
maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }
: STRING {% do { let { pkgFS = getSTRING $1 }
; unless (looksLikePackageName (unpackFS pkgFS)) $
@@ -1161,9 +1173,9 @@ maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }
; return (Just (glR $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }
| {- empty -} { (Nothing,NoRawPkgQual) }
-optqualified :: { Located (Maybe (EpToken "qualified")) }
- : 'qualified' { sL1 $1 (Just (epTok $1)) }
- | {- empty -} { noLoc Nothing }
+optqualified :: { Maybe (EpToken "qualified") }
+ : 'qualified' { Just (epTok $1) }
+ | {- empty -} { Nothing }
maybeas :: { (Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName))) }
: 'as' modid { (Just (epTok $1)
@@ -4068,6 +4080,9 @@ special_id
| 'unit' { sL1 $1 (fsLit "unit") }
| 'dependency' { sL1 $1 (fsLit "dependency") }
| 'signature' { sL1 $1 (fsLit "signature") }
+ | 'quote' { sL1 $1 (fsLit "quote") }
+ | 'splice' { sL1 $1 (fsLit "splice") }
+
special_sym :: { Located FastString }
special_sym : '.' { sL1 $1 (fsLit ".") }
@@ -4326,6 +4341,14 @@ comb5 !a !b !c !d !e =
combineSrcSpans (getHasLoc c) $
combineSrcSpans (getHasLoc d) (getHasLoc e)
+comb6 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e, HasLoc f) => a -> b -> c -> d -> e -> f -> SrcSpan
+comb6 !a !b !c !d !e !f =
+ combineSrcSpans (getHasLoc a) $
+ combineSrcSpans (getHasLoc b) $
+ combineSrcSpans (getHasLoc c) $
+ combineSrcSpans (getHasLoc d) $
+ combineSrcSpans (getHasLoc e) (getHasLoc f)
+
-- strict constructor version:
{-# INLINE sL #-}
sL :: l -> a -> GenLocated l a
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 47650862a3e..8600601fd77 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -287,6 +287,8 @@ instance Diagnostic PsMessage where
<+> text "in postpositive position. "
PsErrImportQualifiedTwice
-> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'"
+ PsErrSpliceOrQuoteTwice
+ -> mkSimpleDecorated $ text "Multiple occurrences of a splice or quote keyword"
PsErrIllegalImportBundleForm
-> mkSimpleDecorated $
text "Illegal import form, this syntax can only be used to bundle"
@@ -617,6 +619,7 @@ instance Diagnostic PsMessage where
PsErrUnallowedPragma{} -> ErrorWithoutFlag
PsErrImportPostQualified -> ErrorWithoutFlag
PsErrImportQualifiedTwice -> ErrorWithoutFlag
+ PsErrSpliceOrQuoteTwice -> ErrorWithoutFlag
PsErrIllegalImportBundleForm -> ErrorWithoutFlag
PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag
PsErrMissingBlock -> ErrorWithoutFlag
@@ -755,6 +758,7 @@ instance Diagnostic PsMessage where
PsErrUnallowedPragma{} -> noHints
PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost]
PsErrImportQualifiedTwice -> noHints
+ PsErrSpliceOrQuoteTwice -> noHints
PsErrIllegalImportBundleForm -> noHints
PsErrInvalidRuleActivationMarker -> noHints
PsErrMissingBlock -> noHints
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 8419ecebc1a..c2241f72d9f 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -207,6 +207,9 @@ data PsMessage
-- | Import: multiple occurrences of 'qualified'
| PsErrImportQualifiedTwice
+ -- | Multiple occurrences of a splice or quote keyword
+ | PsErrSpliceOrQuoteTwice
+
-- | Post qualified import without 'ImportQualifiedPost'
| PsErrImportPostQualified
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 14357cad6b6..5fd7c748eb0 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -38,6 +38,7 @@ import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText
import GHC.Types.PkgQual
+import GHC.Types.Basic (ImportLevel(..), convImportLevel)
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -73,8 +74,8 @@ getImports :: ParserOpts -- ^ Parser options
-- in the function result)
-> IO (Either
(Messages PsMessage)
- ([(RawPkgQual, Located ModuleName)],
- [(RawPkgQual, Located ModuleName)],
+ ([Located ModuleName],
+ [(ImportLevel, RawPkgQual, Located ModuleName)],
Located ModuleName))
-- ^ The source imports and normal imports (with optional package
-- names from -XPackageImports), and the module name.
@@ -101,13 +102,15 @@ getImports popts implicit_prelude buf filename source_filename = do
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
- convImport (L _ (i::ImportDecl GhcPs))
- = (ideclPkgQual i, reLoc $ ideclName i)
+ convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i)
+ convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i)
in
- return (map convImport src_idecls
+ return (map convImport_src src_idecls
, map convImport (implicit_imports ++ ord_idecls)
, reLoc mod)
+
+
mkPrelImports :: ModuleName
-> SrcSpan -- Attribute the "import Prelude" to this location
-> Bool -> [LImportDecl GhcPs]
@@ -133,6 +136,10 @@ mkPrelImports this_mod loc implicit_prelude import_decls
&& case ideclPkgQual decl of
NoRawPkgQual -> True
RawPkgQual {} -> False
+ -- Only a "normal" level import will override the implicit prelude import.
+ && case ideclLevelSpec decl of
+ NotLevelled -> True
+ _ -> False
loc' = noAnnSrcSpan loc
@@ -149,6 +156,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls
ideclSafe = False, -- Not a safe import
ideclQualified = NotQualified,
ideclAs = Nothing,
+ ideclLevelSpec = NotLevelled,
ideclImportList = Nothing }
--------------------------------------------------------------
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index a5089f3d7c8..3a0278bbf83 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -956,6 +956,9 @@ data Token
-- represents a qualified quasi-quote of the form
-- [Qual.quoter| quote |]
+ | ITsplice
+ | ITquote
+
-- Arrow notation extension
| ITproc
| ITrec
@@ -1095,7 +1098,9 @@ reservedWordsFM = listToUFM $
( "rec", ITrec, xbit ArrowsBit .|.
xbit RecursiveDoBit),
- ( "proc", ITproc, xbit ArrowsBit)
+ ( "proc", ITproc, xbit ArrowsBit),
+ ( "splice", ITsplice, xbit LevelImportsBit),
+ ( "quote", ITquote, xbit LevelImportsBit)
]
{-----------------------------------
@@ -2775,6 +2780,7 @@ data ExtBits
| ViewPatternsBit
| RequiredTypeArgumentsBit
| MultilineStringsBit
+ | LevelImportsBit
-- Flags that are updated once parsing starts
| InRulePragBit
@@ -2858,6 +2864,7 @@ mkParserOpts extensionFlags diag_opts
.|. ViewPatternsBit `xoptBit` LangExt.ViewPatterns
.|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments
.|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings
+ .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports
optBits =
HaddockBit `setBitIf` isHaddock
.|. RawTokenStreamBit `setBitIf` rawTokStream
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 5cc3c3f8bf8..d7b7b6f7766 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -92,6 +92,7 @@ module GHC.Parser.PostProcess (
failOpFewArgs,
failNotEnabledImportQualifiedPost,
failImportQualifiedTwice,
+ failSpliceOrQuoteTwice,
SumOrTuple (..),
@@ -1276,8 +1277,11 @@ checkContextExpr orig_expr@(L (EpAnn l _ cs) _) =
checkImportDecl :: Maybe (EpToken "qualified")
-> Maybe (EpToken "qualified")
- -> P ()
-checkImportDecl mPre mPost = do
+ -> Maybe EpAnnLevel
+ -> Maybe EpAnnLevel
+ -> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
+ , (Maybe EpAnnLevel, ImportDeclLevelStyle))
+checkImportDecl mPre mPost preLevel postLevel = do
let whenJust mg f = maybe (pure ()) f mg
tokenSpan tok = RealSrcSpan (epaLocationRealSrcSpan $ getEpTokenLoc tok) Strict.Nothing
@@ -1291,15 +1295,47 @@ checkImportDecl mPre mPost = do
-- Error if 'qualified' occurs in both pre and postpositive
-- positions.
- whenJust mPost $ \post ->
- when (isJust mPre) $
- failImportQualifiedTwice (tokenSpan post)
+ qualSpec <- importDeclQualifiedStyle mPre mPost
+ levelSpec <- importDeclLevelStyle preLevel postLevel
-- Warn if 'qualified' found in prepositive position and
-- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
whenJust mPre $ \pre ->
warnPrepositiveQualifiedModule (tokenSpan pre)
+ return (qualSpec, levelSpec)
+
+-- | Given two possible located 'qualified' tokens, compute a style
+-- (in a conforming Haskell program only one of the two can be not
+-- 'Nothing'). This is called from "GHC.Parser".
+importDeclQualifiedStyle :: Maybe (EpToken "qualified")
+ -> Maybe (EpToken "qualified")
+ -> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
+importDeclQualifiedStyle mPre mPost =
+ case (mPre, mPost) of
+ (Just {}, Just post) -> failImportQualifiedTwice (getEpTokenSrcSpan post)
+ >> return (Just post, QualifiedPost)
+ (Nothing, Just post) -> pure (Just post, QualifiedPost)
+ (Just pre, Nothing) -> pure (Just pre, QualifiedPre)
+ (Nothing, Nothing) -> pure (Nothing, NotQualified)
+
+importDeclLevelStyle :: (Maybe EpAnnLevel)
+ -> (Maybe EpAnnLevel)
+ -> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
+importDeclLevelStyle preImportLevel postImportLevel =
+ case (preImportLevel, postImportLevel) of
+ (Just {}, Just tok) -> failSpliceOrQuoteTwice tok
+ >> return (Just tok, LevelStylePost (tokToLevel tok))
+ (Nothing, Just post) -> pure (Just post, LevelStylePost (tokToLevel post))
+ (Just pre, Nothing) -> pure (Just pre, LevelStylePre (tokToLevel pre))
+ (Nothing, Nothing) -> pure (Nothing, NotLevelled)
+ where
+ tokToLevel tok = case tok of
+ EpAnnLevelSplice {} -> ImportDeclSplice
+ EpAnnLevelQuote {} -> ImportDeclQuote
+
+
+
-- -------------------------------------------------------------------------
-- Checking Patterns.
@@ -3302,6 +3338,14 @@ failImportQualifiedTwice :: SrcSpan -> P ()
failImportQualifiedTwice loc =
addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice
+failSpliceOrQuoteTwice :: EpAnnLevel -> P ()
+failSpliceOrQuoteTwice lvl =
+ addError $ mkPlainErrorMsgEnvelope loc $ PsErrSpliceOrQuoteTwice
+ where
+ loc = case lvl of
+ EpAnnLevelSplice tok -> getEpTokenSrcSpan tok
+ EpAnnLevelQuote tok -> getEpTokenSrcSpan tok
+
warnStarIsType :: SrcSpan -> P ()
warnStarIsType span = addPsMessage span PsWarnStarIsType
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 1c3f2f86a7a..c3cabb5ea9e 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -238,8 +238,8 @@ newTopSrcBinder (L loc rdr_name)
-- Binders should not be qualified; if they are, and with a different
-- module name, we get a confusing "M.T is not in scope" error later
- ; stage <- getStage
- ; if isBrackStage stage then
+ ; level <- getThLevel
+ ; if isBrackLevel level then
-- We are inside a TH bracket, so make an *Internal* name
-- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names
do { uniq <- newUnique
@@ -1015,7 +1015,7 @@ lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
-lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevelIndex))
-- Just look in the local environment
lookupLocalOccThLvl_maybe name
= do { lcl_env <- getLclEnv
@@ -1978,7 +1978,13 @@ lookupQualifiedNameGHCi fos rdr_name
, gre_info = info }
where
info = lookupGREInfo hsc_env nm
- spec = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_pkg_qual = NoPkgQual, is_qual = True, is_isboot = NotBoot, is_dloc = noSrcSpan }
+ spec = ImpDeclSpec { is_mod = mod
+ , is_as = moduleName mod
+ , is_pkg_qual = NoPkgQual
+ , is_qual = True
+ , is_isboot = NotBoot
+ , is_dloc = noSrcSpan
+ , is_level = NormalLevel }
is = ImpSpec { is_decl = spec, is_item = ImpAll }
-- | Look up the 'GREInfo' associated with the given 'Name'
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index e92a6f63490..64412c9e37e 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -33,7 +33,7 @@ import GHC.Prelude hiding (head, init, last, scanl, tail)
import GHC.Hs
import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env ( isBrackStage )
+import GHC.Tc.Utils.Env ( isBrackLevel )
import GHC.Tc.Utils.Monad
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
@@ -43,7 +43,7 @@ import GHC.Rename.Fixity
import GHC.Rename.Utils
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice
- , rnUntypedSpliceExpr, checkThLocalName )
+ , rnUntypedSpliceExpr, checkThLocalNameWithLift )
import GHC.Rename.HsType
import GHC.Rename.Pat
@@ -306,15 +306,6 @@ rnLExpr = wrapLocFstMA rnExpr
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-finishHsVar :: RdrName -> LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
--- Separated from rnExpr because it's also used
--- when renaming infix expressions
-finishHsVar rdr (L l name)
- = do { this_mod <- getModule
- ; when (nameIsLocalOrFrom this_mod name) $
- checkThLocalName name
- ; return (mkHsVarWithUserRdr rdr (L (l2l l) name), unitFV name) }
-
rnUnboundVar :: SrcSpanAnnN -> RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar l v = do
deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables
@@ -337,10 +328,8 @@ rnExpr (HsVar _ (L l v))
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
-> do { let sel_name = flSelector $ recFieldLabel fld_info
- ; this_mod <- getModule
- ; when (nameIsLocalOrFrom this_mod sel_name) $
- checkThLocalName sel_name
- ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
+ ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift sel_name
+ ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
}
| nm == nilDataConName
-- Treat [] as an ExplicitList, so that
@@ -350,9 +339,11 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar v (L (l2l l) nm)
+ -> do { unless (isExact v || isOrig v) (checkThLocalNameWithLift nm)
+ ; return (HsVar noExtField (L (l2l l) (WithUserRdr v nm)), unitFV nm) }
}}}
+
rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs)
@@ -665,9 +656,9 @@ rnExpr e@(HsStatic _ expr) = do
unlessXOptM LangExt.StaticPointers $
addErr $ TcRnIllegalStaticExpression e
(expr',fvExpr) <- rnLExpr expr
- stage <- getStage
- case stage of
- Splice _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e
+ level <- getThLevel
+ case level of
+ Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e
_ -> return ()
mod <- getModule
let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
@@ -1161,7 +1152,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
| otherwise = False
-- don't apply the transformation inside TH brackets, because
-- GHC.HsToCore.Quote does not handle ApplicativeDo.
- ; in_th_bracket <- isBrackStage <$> getStage
+ ; in_th_bracket <- isBrackLevel <$> getThLevel
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
; rearrangeForApplicativeDo ctxt stmts }
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 12bdfe6c897..0fcd2c4e593 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -348,7 +348,8 @@ rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl ann@(HsAnnotation (_, s) provenance expr)
= addErrCtxt (AnnCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
- ; (expr', expr_fvs) <- setStage (Splice Untyped) $
+ ; cur_level <- getThLevel
+ ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $
rnLExpr expr
; return (HsAnnotation (noAnn, s) provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index dd1c0a6f135..6a9be12e600 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -74,7 +74,7 @@ import GHC.Types.FieldLabel
import GHC.Types.Hint
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..) )
+import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..), convImportLevel )
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.PkgQual
@@ -228,8 +228,8 @@ rnImports imports = do
(imp_boot_mods imp_avails)
(imp_direct_dep_mods imp_avails)
- combJ (GWIB _ IsBoot) x = Just x
- combJ r _ = Just r
+ combJ (GWIB _ IsBoot) (_, x) = Just x
+ combJ r _ = Just r
-- See Note [Combining ImportAvails]
combine :: [(LImportDecl GhcRn, ImportUserSpec, GlobalRdrEnv, ImportAvails)]
-> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails)
@@ -313,7 +313,9 @@ rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)
rnImportDecl this_mod
(L loc decl@(ImportDecl { ideclName = loc_imp_mod_name
, ideclPkgQual = raw_pkg_qual
- , ideclSource = want_boot, ideclSafe = mod_safe
+ , ideclSource = want_boot
+ , ideclSafe = mod_safe
+ , ideclLevelSpec = import_level
, ideclQualified = qual_style
, ideclExt = XImportDeclPass { ideclImplicit = implicit }
, ideclAs = as_mod, ideclImportList = imp_details }), import_reason)
@@ -391,7 +393,8 @@ rnImportDecl this_mod
qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
imp_spec = ImpDeclSpec { is_mod = imp_mod, is_qual = qual_only,
is_dloc = locA loc, is_as = qual_mod_name,
- is_pkg_qual = pkg_qual, is_isboot = want_boot }
+ is_pkg_qual = pkg_qual, is_isboot = want_boot,
+ is_level = convImportLevel import_level }
-- filter the imports according to the import declaration
(new_imp_details, imp_user_list, gbl_env) <- filterImports hsc_env iface imp_spec imp_details
@@ -418,6 +421,7 @@ rnImportDecl this_mod
, imv_is_hiding = is_hiding
, imv_all_exports = potential_gres
, imv_qualified = qual_only
+ , imv_is_level = convImportLevel import_level
}
imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)
@@ -435,6 +439,7 @@ rnImportDecl this_mod
, ideclQualified = ideclQualified decl
, ideclAs = ideclAs decl
, ideclImportList = new_imp_details
+ , ideclLevelSpec = ideclLevelSpec decl
}
return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports)
@@ -547,14 +552,20 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by
dependent_pkgs = if toUnitId pkg `S.member` other_home_units
then S.empty
- else S.singleton ipkg
+ else S.singleton (lvl, ipkg)
- direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units
- then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))
- else S.empty
+ lvl = case imported_by of
+ ImportedByUser imv -> imv_is_level imv
+ ImportedBySystem -> NormalLevel
+
+
+ direct_mods = if toUnitId pkg `S.member` other_home_units
+ then mkPlusModDeps (moduleUnitId imp_mod) lvl (GWIB (moduleName imp_mod) want_boot)
+ else emptyInstalledModuleEnv
dep_boot_mods_map = mkModDeps (dep_boot_mods deps)
+
boot_mods
-- If we are looking for a boot module, it must be HPT
| IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)
@@ -590,6 +601,9 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by
imp_trust_own_pkg = pkg_trust_req
}
+mkPlusModDeps :: UnitId -> ImportLevel -> ModuleNameWithIsBoot
+ -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)
+mkPlusModDeps uid st elt = extendInstalledModuleEnv emptyInstalledModuleEnv (mkModule uid (gwib_mod elt)) (S.singleton st, elt)
{-
************************************************************************
@@ -621,7 +635,7 @@ top level binders specially in two ways
See Note [GlobalRdrEnv shadowing]
3. We find out whether we are inside a [d| ... |] by testing the TH
- stage. This is a slight hack, because the stage field was really
+ level. This is a slight hack, because the level field was really
meant for the type checker, and here we are not interested in the
fields of Brack, hence the error thunks in thRnBrack.
-}
@@ -637,18 +651,18 @@ extendGlobalRdrEnvRn :: [GlobalRdrElt]
extendGlobalRdrEnvRn new_gres new_fixities
= checkNoErrs $ -- See Note [Fail fast on duplicate definitions]
do { (gbl_env, lcl_env) <- getEnvs
- ; stage <- getStage
+ ; level <- getThLevel
; isGHCi <- getIsGHCi
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
th_bndrs = getLclEnvThBndrs lcl_env
- th_lvl = thLevel stage
+ th_lvl = thLevelIndex level
-- Delete new_occs from global and local envs
-- If we are in a TemplateHaskell decl bracket,
-- we are going to shadow them
-- See Note [GlobalRdrEnv shadowing]
- inBracket = isBrackStage stage
+ inBracket = isBrackLevel level
lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env
-- See Note [GlobalRdrEnv shadowing]
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index a0e340250c7..931824745dc 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -13,7 +13,7 @@ module GHC.Rename.Splice (
-- Brackets
rnTypedBracket, rnUntypedBracket,
- checkThLocalName, traceSplice, SpliceInfo(..),
+ checkThLocalName, checkThLocalNameWithLift, checkThLocalNameNoLift, traceSplice, SpliceInfo(..),
checkThLocalTyName,
) where
@@ -44,7 +44,7 @@ import Control.Monad ( unless, when )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
-import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy )
+import GHC.Tc.Utils.Env ( tcMetaTy )
import GHC.Driver.DynFlags
import GHC.Data.FastString
@@ -70,6 +70,7 @@ import GHCi.RemoteTypes ( ForeignRef )
import qualified GHC.Boot.TH.Syntax as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
+import qualified Data.Set as Set
{-
************************************************************************
@@ -123,9 +124,9 @@ rnTypedBracket e br_body
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
- ; cur_stage <- getStage
- ; case cur_stage of
- { Splice _ -> return ()
+ ; cur_level <- getThLevel
+ ; case cur_level of
+ { Splice _ _ -> return ()
-- See Note [Untyped quotes in typed splices and vice versa]
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in GHC.Tc.Types.
@@ -140,7 +141,7 @@ rnTypedBracket e br_body
; recordThUse
; traceRn "Renaming typed TH bracket" empty
- ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
+ ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body
; return (HsTypedBracket noExtField body', fvs_e)
@@ -152,9 +153,9 @@ rnUntypedBracket e br_body
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
- ; cur_stage <- getStage
- ; case cur_stage of
- { Splice _ -> return ()
+ ; cur_level <- getThLevel
+ ; case cur_level of
+ { Splice _ _ -> return ()
-- See Note [Untyped quotes in typed splices and vice versa]
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in GHC.Tc.Types.
@@ -173,49 +174,30 @@ rnUntypedBracket e br_body
; (body', fvs_e) <-
-- See Note [Rebindable syntax and Template Haskell]
unsetXOptM LangExt.RebindableSyntax $
- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
- rn_utbracket cur_stage br_body
+ setThLevel (Brack cur_level (RnPendingUntyped ps_var)) $
+ rn_utbracket br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', fvs_e)
}
-rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
-rn_utbracket outer_stage br@(VarBr _ flg rdr_name)
+rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
+rn_utbracket (VarBr _ flg rdr_name)
= do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name)
+ ; if flg then checkThLocalNameNoLift name else checkThLocalTyName name
; check_namespace flg name
- ; this_mod <- getModule
-
- ; when (flg && nameIsLocalOrFrom this_mod name) $
- -- Type variables can be quoted in TH. See #5721.
- do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
- ; case mb_bind_lvl of
- { Nothing -> return () -- Can happen for data constructors,
- -- but nothing needs to be done for them
-
- ; Just (top_lvl, bind_lvl) -- See Note [Quoting names]
- | isTopLevel top_lvl
- -> when (isExternalName name) (keepAlive name)
- | otherwise
- -> do { traceRn "rn_utbracket VarBr"
- (ppr name <+> ppr bind_lvl
- <+> ppr outer_stage)
- ; checkTc (thLevel outer_stage + 1 == bind_lvl) $
- TcRnTHError $ THNameError $ QuotedNameWrongStage br }
- }
- }
; return (VarBr noExtField flg (noLocA name), unitFV name) }
-rn_utbracket _ (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
+rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr noExtField e', fvs) }
-rn_utbracket _ (PatBr _ p)
+rn_utbracket (PatBr _ p)
= rnPat ThPatQuote p $ \ p' -> return (PatBr noExtField p', emptyFVs)
-rn_utbracket _ (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+rn_utbracket (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t
; return (TypBr noExtField t', fvs) }
-rn_utbracket _ (DecBrL _ decls)
+rn_utbracket (DecBrL _ decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -241,7 +223,7 @@ rn_utbracket _ (DecBrL _ decls)
}
}}
-rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
+rn_utbracket (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
-- | Ensure that we are not using a term-level name in a type-level namespace
@@ -297,14 +279,14 @@ rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnUntypedSpliceGen run_splice pend_splice splice
= addErrCtxt (UntypedSpliceCtxt splice) $ do
- { stage <- getStage
- ; case stage of
+ { level <- getThLevel
+ ; case level of
Brack _ RnPendingTyped
-> failWithTc $ thSyntaxError
$ MismatchedSpliceType Untyped IsSplice
- Brack pop_stage (RnPendingUntyped ps_var)
- -> do { (splice', fvs) <- setStage pop_stage $
+ Brack pop_level (RnPendingUntyped ps_var)
+ -> do { (splice', fvs) <- setThLevel pop_level $
rnUntypedSplice splice
; loc <- getSrcSpanM
; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
@@ -314,8 +296,9 @@ rnUntypedSpliceGen run_splice pend_splice splice
; return (result, fvs) }
_ -> do { checkTopSpliceAllowed splice
+ ; cur_level <- getThLevel
; (splice', fvs1) <- checkNoErrs $
- setStage (Splice Untyped) $
+ setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
@@ -367,7 +350,7 @@ runRnSplice flavour run_meta ppr_res splice
-- Run the expression
; mod_finalizers_ref <- newTcRef []
- ; result <- setStage (RunSplice mod_finalizers_ref) $
+ ; result <- setThLevel (RunSplice mod_finalizers_ref) $
run_meta zonked_q_expr
; mod_finalizers <- readTcRef mod_finalizers_ref
; traceSplice (SpliceInfo { spliceDescription = what
@@ -442,7 +425,7 @@ rnUntypedSplice (HsQuasiQuote ext quoter quote)
; quoter' <- lookupOccRn WL_TermVariable quoter
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod quoter') $
- checkThLocalName quoter'
+ checkThLocalNameNoLift quoter'
; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }
@@ -451,10 +434,10 @@ rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression
-> RnM (HsExpr GhcRn, FreeVars)
rnTypedSplice expr
= addErrCtxt (TypedSpliceCtxt Nothing expr) $ do
- { stage <- getStage
- ; case stage of
- Brack pop_stage RnPendingTyped
- -> setStage pop_stage rn_splice
+ { level <- getThLevel
+ ; case level of
+ Brack pop_level RnPendingTyped
+ -> setThLevel pop_level rn_splice
Brack _ (RnPendingUntyped _)
-> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice
@@ -462,7 +445,8 @@ rnTypedSplice expr
_ -> do { unlessXOptM LangExt.TemplateHaskell
(failWith $ thSyntaxError IllegalTHSplice)
- ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice
+ ; cur_level <- getThLevel
+ ; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) rn_splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
-- errors from e.g. unbound variables
@@ -806,8 +790,9 @@ rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
rnTopSpliceDecls splice
= do { checkTopSpliceAllowed splice
+ ; cur_level <- getThLevel
; (rn_splice, fvs) <- checkNoErrs $
- setStage (Splice Untyped) $
+ setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice
-- As always, be sure to checkNoErrs above lest we end up with
-- holes making it to typechecking, hence #12584.
@@ -924,66 +909,104 @@ checkThLocalTyName name
| otherwise
= do { traceRn "checkThLocalTyName" (ppr name)
- ; mb_local_use <- getStageAndBindLevel name
+ ; mb_local_use <- getCurrentAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
- Just (top_lvl, bind_lvl, use_stage) ->
- do { let use_lvl = thLevel use_stage
- -- We don't check the well stageness of name here.
+ Just (top_lvl, bind_lvl, use_lvl) ->
+ do { let use_lvl_idx = thLevelIndex use_lvl
+ -- We don't check the well levelledness of name here.
-- this would break test for #20969
--
-- Consequently there is no check&restiction for top level splices.
-- But it's annoying anyway.
--
- -- Therefore checkCrossStageLiftingTy shouldn't assume anything
+ -- Therefore checkCrossLevelLiftingTy shouldn't assume anything
-- about bind_lvl and use_lvl relation.
--
- -- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
-
; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl
- <+> ppr use_stage
+ <+> ppr use_lvl
<+> ppr use_lvl)
- ; checkCrossStageLiftingTy top_lvl bind_lvl use_stage use_lvl name } } }
-
-checkThLocalName :: Name -> RnM ()
-checkThLocalName name
+ ; dflags <- getDynFlags
+ ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } }
+
+-- | Check whether we are allowed to use a Name in this context (for TH purposes)
+-- In the case of a level incorrect program, attempt to fix it by using
+-- a Lift constraint.
+checkThLocalNameWithLift :: Name -> RnM ()
+checkThLocalNameWithLift = checkThLocalName True
+
+-- | Check whether we are allowed to use a Name in this context (for TH purposes)
+-- In the case of a level incorrect program, do not attempt to fix it by using
+-- a Lift constraint.
+checkThLocalNameNoLift :: Name -> RnM ()
+checkThLocalNameNoLift = checkThLocalName False
+
+checkThLocalName :: Bool -> Name -> RnM ()
+checkThLocalName allow_lifting name
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
+ | isWiredInName name
+ = return ()
+
| otherwise
- = do { traceRn "checkThLocalName" (ppr name)
- ; mb_local_use <- getStageAndBindLevel name
+ = do {
+ mb_local_use <- getCurrentAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
- Just (top_lvl, bind_lvl, use_stage) ->
- do { let use_lvl = thLevel use_stage
- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
- ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
- <+> ppr use_stage
- <+> ppr use_lvl)
- ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
+ Just (top_lvl, bind_lvl, use_lvl) ->
+ do { let use_lvl_idx = thLevelIndex use_lvl
+ ; cur_mod <- extractModule <$> getGblEnv
+ ; let is_local
+ | Just mod <- nameModule_maybe name = mod == cur_mod
+ | otherwise = True
+ ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl)
+ ; dflags <- getDynFlags
+ ; env <- getGlobalRdrEnv
+ ; let mgre = lookupGRE_Name env name
+ ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name } } }
--------------------------------------
-checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
+checkCrossLevelLifting :: DynFlags
+ -> LevelCheckReason
+ -> TopLevelFlag
+ -> Bool
+ -> Bool
+ -> Set.Set ThLevelIndex
+ -> ThLevel
+ -> ThLevelIndex
-> Name -> TcM ()
--- We are inside brackets, and (use_lvl > bind_lvl)
--- Now we must check whether there's a cross-stage lift to do
--- Examples \x -> [| x |]
--- [| map |]
---
--- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but
--- this is only run on *untyped* brackets.
-
-checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
- | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets
- , use_lvl > bind_lvl -- Cross-stage condition
- = check_cross_stage_lifting top_lvl name ps_var
- | otherwise
- = return ()
-
-check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
-check_cross_stage_lifting top_lvl name ps_var
+checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name
+ -- 1. If name is in-scope, at the correct level.
+ | use_lvl_idx `Set.member` bind_lvl = return ()
+ -- 2. Name is imported with -XImplicitStagePersistence
+ | not is_local
+ , xopt LangExt.ImplicitStagePersistence dflags = return ()
+ -- 3. Name is top-level, with -XImplicitStagePersistence, and needs
+ -- to be persisted into the future.
+ | isTopLevel top_lvl
+ , is_local
+ , any (use_lvl_idx >=) (Set.toList bind_lvl)
+ , xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name)
+ -- 4. Name is in an untyped bracket, and lifting is allowed.
+ | Brack _ (RnPendingUntyped ps_var) <- use_lvl -- Only for untyped brackets
+ , any (use_lvl_idx >=) (Set.toList bind_lvl)
+ , allow_lifting
+ = do
+ dflags <- getDynFlags
+ check_cross_level_lifting dflags top_lvl name ps_var
+ -- 5. For a typed bracket, these checks happen again later on (checkThLocalId)
+ -- In the future we should do all the level checks here.
+ | Brack _ RnPendingTyped <- use_lvl -- Lift for typed brackets is inserted later.
+ , any (use_lvl_idx >=) (Set.toList bind_lvl)
+ = return ()
+ -- Otherwise, we have a level error, report.
+ | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx)
+
+check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
+check_cross_level_lifting dflags top_lvl name ps_var
| isTopLevel top_lvl
+ , xopt LangExt.ImplicitStagePersistence dflags
-- Top-level identifiers in this module,
-- (which have External Names)
-- are just like the imported case:
@@ -1004,7 +1027,7 @@ check_cross_stage_lifting top_lvl name ps_var
-- If 'x' occurs many times we may get many identical
-- bindings of the same SplicePointName, but that doesn't
-- matter, although it's a mite untidy.
- do { traceRn "checkCrossStageLifting" (ppr name)
+ do { traceRn "checkCrossLevelLifting" (ppr name)
-- Construct the (lift x) expression
; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
@@ -1017,20 +1040,20 @@ check_cross_stage_lifting top_lvl name ps_var
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }
-checkCrossStageLiftingTy :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> TcM ()
-checkCrossStageLiftingTy top_lvl bind_lvl _use_stage use_lvl name
+checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()
+checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name
| isTopLevel top_lvl
+ , xopt LangExt.ImplicitStagePersistence dflags
= return ()
-- There is no liftType (yet), so we could error, or more conservatively, just warn.
--
-- For now, we check here for both untyped and typed splices, as we don't create splices.
- | use_lvl > bind_lvl
- = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl
- -- See comment in checkThLocalTyName: this can also happen.
- | bind_lvl < use_lvl
- = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl
+ -- Can also happen for negative cases
+ -- See comment in checkThLocalTyName:
+ | use_lvl_idx `notElem` bind_lvl
+ = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl_idx
| otherwise
= return ()
@@ -1071,7 +1094,7 @@ them in the keep-alive set.
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
A quoted name 'n is a bit like a quoted expression [| n |], except that we
-have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing
+have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing
the use-level to account for the brackets, the cases are:
bind > use Error
@@ -1090,7 +1113,7 @@ Examples:
\x. f 'x -- Not ok (bind = 1, use = 1)
-- (whereas \x. f [| x |] might have been ok, by
- -- cross-stage lifting
+ -- cross-level lifting
\y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index dc87141e8c4..a7a6fadd669 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -106,7 +106,7 @@ newLocalBndrsRn = mapM newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names
= updLclCtxt $ \ lcl_env ->
- let th_level = thLevel (tcl_th_ctxt lcl_env)
+ let th_level = thLevelIndex (tcl_th_ctxt lcl_env)
th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
[ (n, (NotTopLevel, th_level)) | n <- names ]
rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 012306bf623..a6b236441e4 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -354,7 +354,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
Just iface -> do
-- Try and find the required name in the exports
let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name, is_pkg_qual = NoPkgQual
- , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot }
+ , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot, is_level = SpliceLevel }
imp_spec = ImpSpec decl_spec ImpAll
env = mkGlobalRdrEnv
$ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index c8ca522b04e..7466df924e1 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1624,14 +1624,14 @@ Example:
==>
instance (Lift a) => Lift (Foo a) where
- lift (Foo a) = [| Foo $(lift a) |]
- lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |]
+ lift (Foo a) = ConE 'Foo `appE` (lift a)
+ lift ((:^:) u v) = ConE '(:^:) `appE` (lift u) `appE` (lift v)
- liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]
- liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]
+ liftTyped (Foo a) = unsafeCodeCoerce (ConE 'Foo `appE` (lift a))
+ liftTyped ((:^:) u v) = unsafeCodeCoerce (ConE '(:^:) `appE` (lift u) `appE` (lift v))
-Note that we use explicit splices here in order to not trigger the implicit
-lifting warning in derived code. (See #20688)
+Note that we use variable quotes, in order to avoid the constructor being
+lifted by implicit cross-stage lifting when `-XNoImplicitStagePersistence` is enabled.
-}
@@ -1641,33 +1641,37 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
([lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
- (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)
+ (map (pats_etc mk_untyped_bracket ) data_cons)
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
- (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
+ (map (pats_etc mk_typed_bracket ) data_cons)
- mk_untyped_bracket = HsUntypedBracket noExtField . ExpBr noAnn
- mk_typed_bracket = HsTypedBracket noAnn
+ mk_untyped_bracket = id
+ mk_typed_bracket = nlHsApp unsafeCodeCoerce_Expr
- mk_tsplice = HsTypedSplice noAnn
- mk_usplice = HsUntypedSplice noExtField . HsUntypedSpliceExpr noAnn
data_cons = getPossibleDataCons tycon tycon_args
- pats_etc mk_bracket mk_splice lift_name data_con
+
+ pats_etc :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
+ pats_etc mk_bracket data_con
= ([con_pat], lift_Expr)
where
con_pat = nlConVarPat data_con_RDR as_needed
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs
- lift_Expr = noLocA (mk_bracket br_body)
- br_body = nlHsApps (Exact (dataConName data_con))
- (map lift_var as_needed)
+ lift_Expr = mk_bracket finish
+ con_brack :: LHsExpr GhcPs
+ con_brack = nlHsApps (Exact conEName)
+ [noLocA $ HsUntypedBracket noExtField
+ $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))]
+
+ finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed)
lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
- lift_var x = noLocA (mk_splice (nlHsPar (mk_lift_expr x)))
+ lift_var x = nlHsPar (mk_lift_expr x)
mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
- mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]
+ mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x]
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 67e7d59bc1d..d9abd855aee 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -927,6 +927,7 @@ stockSideConditions deriv_ctxt cls
cond_vanilla `andCond`
cond_Representable1Ok)
| sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
+ checkFlag LangExt.ImplicitStagePersistence `andCond`
cond_vanilla `andCond`
cond_args cls)
| otherwise = Nothing
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 43070e36131..aaa7da3440a 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -129,6 +129,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormulaNice)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
+import qualified Data.Set as Set
import Data.Foldable ( fold )
import Data.Function (on)
import Data.List ( groupBy, sortBy, tails
@@ -1515,29 +1516,28 @@ instance Diagnostic TcRnMessage where
hsep [ text "Unknown type variable" <> plural errorVars
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ]
- TcRnBadlyStaged reason bind_lvl use_lvl
- -> mkSimpleDecorated $
+ TcRnBadlyLevelled reason bind_lvls use_lvl
+ ->
+ mkSimpleDecorated $
vcat $
- [ text "Stage error:" <+> pprStageCheckReason reason <+>
- hsep [text "is bound at stage" <+> ppr bind_lvl,
- text "but used at stage" <+> ppr use_lvl]
+ [ fsep [ text "Level error:", pprLevelCheckReason reason
+ , text "is bound at" <+> pprThBindLevel bind_lvls
+ , text "but used at level" <+> ppr use_lvl]
] ++
- [ hsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)
- , text "or an enclosing expression would allow the quotation to be used in an earlier stage"
+ [ fsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)
+ , text "or an enclosing expression"
+ , text "would allow the quotation to be used at an earlier level"
]
- | StageCheckSplice n <- [reason]
- ]
- TcRnBadlyStagedType name bind_lvl use_lvl
- -> mkSimpleDecorated $
- text "Badly staged type:" <+> ppr name <+>
- hsep [text "is bound at stage" <+> ppr bind_lvl,
- text "but used at stage" <+> ppr use_lvl]
- TcRnStageRestriction reason
- -> mkSimpleDecorated $
- sep [ text "GHC stage restriction:"
- , nest 2 (vcat [ pprStageCheckReason reason <+>
- text "is used in a top-level splice, quasi-quote, or annotation,"
- , text "and must be imported, not defined locally"])]
+ | LevelCheckSplice n _ <- [reason]
+ ] ++
+ [ "From imports" <+> (ppr (gre_imp gre))
+ | LevelCheckSplice _ (Just gre) <- [reason]
+ , not (isEmptyBag (gre_imp gre)) ]
+ TcRnBadlyLevelledType name bind_lvls use_lvl
+ -> mkSimpleDecorated $
+ text "Badly levelled type:" <+> ppr name <+>
+ fsep [text "is bound at" <+> pprThBindLevel bind_lvls,
+ text "but used at level" <+> ppr use_lvl]
TcRnTyThingUsedWrong sort thing name
-> mkSimpleDecorated $
pprTyThingUsedWrong sort thing name
@@ -2489,12 +2489,10 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> ErrorWithoutFlag
- TcRnBadlyStaged{}
- -> ErrorWithoutFlag
- TcRnBadlyStagedType{}
- -> WarningWithFlag Opt_WarnBadlyStagedTypes
- TcRnStageRestriction{}
+ TcRnBadlyLevelled{}
-> ErrorWithoutFlag
+ TcRnBadlyLevelledType{}
+ -> WarningWithFlag Opt_WarnBadlyLevelledTypes
TcRnTyThingUsedWrong{}
-> ErrorWithoutFlag
TcRnCannotDefaultKindVar{}
@@ -3176,11 +3174,9 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> noHints
- TcRnBadlyStaged{}
- -> noHints
- TcRnBadlyStagedType{}
+ TcRnBadlyLevelled{}
-> noHints
- TcRnStageRestriction{}
+ TcRnBadlyLevelledType{}
-> noHints
TcRnTyThingUsedWrong{}
-> noHints
@@ -5780,11 +5776,11 @@ pprWrongThingSort =
WrongThingTyCon -> "type constructor"
WrongThingAxiom -> "axiom"
-pprStageCheckReason :: StageCheckReason -> SDoc
-pprStageCheckReason = \case
- StageCheckInstance _ t ->
+pprLevelCheckReason :: LevelCheckReason -> SDoc
+pprLevelCheckReason = \case
+ LevelCheckInstance _ t ->
text "instance for" <+> quotes (ppr t)
- StageCheckSplice t ->
+ LevelCheckSplice t _ ->
quotes (ppr t)
pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc
@@ -6887,10 +6883,6 @@ pprTHNameError = \case
mkSimpleDecorated $
hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")
2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
- QuotedNameWrongStage quote ->
- mkSimpleDecorated $
- sep [ text "Stage error: the non-top-level quoted name" <+> ppr quote
- , text "must be used at the same stage at which it is bound." ]
pprTHReifyError :: THReifyError -> DecoratedSDoc
pprTHReifyError = \case
@@ -7012,7 +7004,6 @@ thSyntaxErrorReason = \case
thNameErrorReason :: THNameError -> DiagnosticReason
thNameErrorReason = \case
NonExactName {} -> ErrorWithoutFlag
- QuotedNameWrongStage {} -> ErrorWithoutFlag
thReifyErrorReason :: THReifyError -> DiagnosticReason
thReifyErrorReason = \case
@@ -7073,7 +7064,6 @@ thSyntaxErrorHints = \case
thNameErrorHints :: THNameError -> [GhcHint]
thNameErrorHints = \case
NonExactName {} -> noHints
- QuotedNameWrongStage {} -> noHints
thReifyErrorHints :: THReifyError -> [GhcHint]
thReifyErrorHints = \case
@@ -7473,3 +7463,6 @@ pprErrCtxtMsg = \case
text "in" <+> quotes (ppr req_uid) <> dot
--------------------------------------------------------------------------------
+
+pprThBindLevel :: Set.Set ThLevelIndex -> SDoc
+pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set
\ No newline at end of file
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index c70019d4b76..794659c1a24 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -99,7 +99,7 @@ module GHC.Tc.Errors.Types (
, RuleLhsErrReason(..)
, HsigShapeMismatchReason(..)
, WrongThingSort(..)
- , StageCheckReason(..)
+ , LevelCheckReason(..)
, UninferrableTyVarCtx(..)
, PatSynInvalidRhsReason(..)
, BadFieldAnnotationReason(..)
@@ -254,6 +254,7 @@ import Data.Map.Strict (Map)
import GHC.Generics ( Generic )
+import qualified Data.Set as Set
data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
, tcOptsIfaceOpts :: !IfaceMessageOpts
@@ -3486,41 +3487,31 @@ data TcRnMessage where
-> !LookupInstanceErrReason
-> TcRnMessage
- {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an
- invalid stage.
+ {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an
+ invalid level.
Test cases:
- T17820d
+ T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}
-}
- TcRnBadlyStaged
- :: !StageCheckReason -- ^ The binding being spliced.
- -> !Int -- ^ The binding stage.
- -> !Int -- ^ The stage at which the binding is used.
+ TcRnBadlyLevelled
+ :: !LevelCheckReason -- ^ The binding
+ -> !(Set.Set ThLevelIndex) -- ^ The binding levels
+ -> !ThLevelIndex -- ^ The level at which the binding is used.
-> TcRnMessage
- {-| TcRnStageRestriction is an error that occurs when a top level splice refers to
- a local name.
-
- Test cases:
- T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}
- -}
- TcRnStageRestriction
- :: !StageCheckReason -- ^ The binding being spliced.
- -> TcRnMessage
-
- {-| TcRnBadlyStagedWarn is a warning that occurs when a TH type binding is
+ {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is
used in an invalid stage.
Controlled by flags:
- - Wbadly-staged-type
+ - Wbadly-levelled-type
Test cases:
T23829_timely T23829_tardy T23829_hasty
-}
- TcRnBadlyStagedType
+ TcRnBadlyLevelledType
:: !Name -- ^ The type binding being spliced.
- -> !Int -- ^ The binding stage.
- -> !Int -- ^ The stage at which the binding is used.
+ -> !(Set.Set ThLevelIndex) -- ^ The binding stage.
+ -> !ThLevelIndex -- ^ The stage at which the binding is used.
-> TcRnMessage
{-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another
@@ -6244,9 +6235,9 @@ data WrongThingSort
| WrongThingTyCon
| WrongThingAxiom
-data StageCheckReason
- = StageCheckInstance !InstanceWhat !PredType
- | StageCheckSplice !Name
+data LevelCheckReason
+ = LevelCheckInstance !InstanceWhat !PredType
+ | LevelCheckSplice !Name !(Maybe GlobalRdrElt)
data UninferrableTyVarCtx
= UninfTyCtx_ClassContext [TcType]
@@ -6759,13 +6750,6 @@ data THNameError
-}
= NonExactName !RdrName
- {-| QuotedNameWrongStage is an error that can happen when a
- (non-top-level) Name is used at a different Template Haskell stage
- than the stage at which it is bound.
-
- Test cases: T16976z
- -}
- | QuotedNameWrongStage !(HsQuote GhcPs)
deriving Generic
data THReifyError
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index d3a55393550..b93683f9b0c 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -1217,13 +1217,13 @@ tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty
--
-- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins]
-- in GHC.Tc.Utils.Concrete.
- ; th_stage <- getStage
+ ; th_lvl <- getThLevel
; ty_arg <- case mb_conc of
Nothing -> return ty_arg0
Just conc
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> return ty_arg0
| otherwise
->
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 8231ca0e9e9..4b46ef978d0 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -83,6 +83,10 @@ import GHC.Utils.Panic
import GHC.Data.Maybe
import Control.Monad
+import qualified Data.Set as Set
+import qualified GHC.LanguageExtensions as LangExt
+
+
{- *********************************************************************
* *
@@ -1067,32 +1071,34 @@ Wrinkles
************************************************************************
-}
+-- TODO: We should do all level checks, once, and for all in the renamer in
+-- checkThLocalName.
checkThLocalId :: Id -> TcM ()
--- The renamer has already done checkWellStaged,
--- in RnSplice.checkThLocalName, so don't repeat that here.
--- Here we just add constraints for cross-stage lifting
checkThLocalId id
- = do { mb_local_use <- getStageAndBindLevel (idName id)
+ = do { mb_local_use <- getCurrentAndBindLevel (idName id)
; case mb_local_use of
- Just (top_lvl, bind_lvl, use_stage)
- | thLevel use_stage > bind_lvl
- -> checkCrossStageLifting top_lvl id use_stage
+ Just (top_lvl, bind_lvl, use_lvl)
+ | thLevelIndex use_lvl `Set.notMember` bind_lvl
+ -> do
+ dflags <- getDynFlags
+ checkCrossLevelLifting dflags top_lvl id use_lvl
_ -> return () -- Not a locally-bound thing, or
-- no cross-stage link
}
--------------------------------------
-checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
+checkCrossLevelLifting :: DynFlags -> TopLevelFlag -> Id -> ThLevel -> TcM ()
-- If we are inside typed brackets, and (use_lvl > bind_lvl)
-- we must check whether there's a cross-stage lift to do
-- Examples \x -> [|| x ||]
-- [|| map ||]
--
--- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
+-- This is similar to checkCrossLevelLifting in GHC.Rename.Splice, but
-- this code is applied to *typed* brackets.
-checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
+checkCrossLevelLifting dflags top_lvl id (Brack _ (TcPending ps_var lie_var q))
| isTopLevel top_lvl
+ , xopt LangExt.ImplicitStagePersistence dflags
= when (isExternalName id_name) (keepAlive id_name)
-- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice
@@ -1140,7 +1146,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
where
id_name = idName id
-checkCrossStageLifting _ _ _ = return ()
+checkCrossLevelLifting _ _ _ _ = return ()
{-
Note [Lifting strings]
@@ -1160,6 +1166,35 @@ Note [Local record selectors]
Record selectors for TyCons in this module are ordinary local bindings,
which show up as ATcIds rather than AGlobals. So we need to check for
naughtiness in both branches. c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds.
+
+Note [Explicit Level Imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This is the overview note which explains the whole implementation of ExplicitLevelImports
+
+GHC Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0682-explicit-level-imports.rst
+Paper: https://mpickering.github.io/papers/explicit-level-imports.pdf
+
+The feature is turned on by the `ExplicitLevelImports` extension.
+At the source level, the user marks imports with `quote` or `splice` to introduce
+them at level 1 or -1.
+
+The function GHC.Tc.Utils.Monad.getCurrentAndBindLevel. computes the levels
+at which a Name is available:
+ - for top-level Names, this information is stored in its GRE; it is either local
+ (level 0) or imported, in which case the levels it is imported at are stored in the
+ 'ImpDeclSpec's for the GRE. The function 'greLevels' retrieves this information.
+ - for locally-bound Names, this information is stored in the ThBindEnv.
+GHC.Rename.Splice.checkCrossLevelLifting checks that levels in user-written programs
+are correct.
+
+Instances are checked by `checkWellLevelledDFun`, which computes the level of an
+instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph.
+
+That's it for the main implementation of the feature; the rest is modifications
+to the driver parts of the code to use this information. For example, in downsweep,
+we only enable code generation for modules needed at the runtime stage.
+See Note [-fno-code mode].
+
-}
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index f01623d1de4..4f3ef2010c4 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -173,27 +173,27 @@ import GHC.Rename.Doc (rnHsDoc)
{-
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here are the ThStages, s, their corresponding level numbers
-(the result of (thLevel s)), and their state transitions.
+Here are the ThLevels, their corresponding level numbers
+(the result of (thLevelIndex s)), and their state transitions.
The top level of the program is stage Comp:
Start here
|
V
- ----------- $ ------------ $
- | Comp | ---------> | Splice | -----|
- | 1 | | 0 | <----|
- ----------- ------------
+ ----------- $ ------------ $ -----------------
+ | Comp | ---------> | Splice | -----> | Splice Splice |
+ | 0 | | -1 | <---- | -2 |
+ ----------- ------------ [||] -----------------
^ | ^ |
$ | | [||] $ | | [||]
| v | v
-------------- ----------------
| Brack Comp | | Brack Splice |
- | 2 | | 1 |
+ | 1 | | 0 |
-------------- ----------------
* Normal top-level declarations start in state Comp
- (which has level 1).
+ (which has level 0).
Annotations start in state Splice, since they are
treated very like a splice (only without a '$')
@@ -201,31 +201,28 @@ The top level of the program is stage Comp:
will be *run at compile time*, with the result replacing
the splice
-* The original paper used level -1 instead of 0, etc.
-
* The original paper did not allow a splice within a
splice, but there is no reason not to. This is the
$ transition in the top right.
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Imported things are impLevel (= 0)
+* Imported things are level 0
-* However things at level 0 are not *necessarily* imported.
- eg $( \b -> ... ) here b is bound at level 0
+* Top-level things are level 0
* In GHCi, variables bound by a previous command are treated
- as impLevel, because we have bytecode for them.
+ as imported, because we have bytecode for them.
* Variables are bound at the "current level"
-* The current level starts off at outerLevel (= 1)
+* The current level starts off at 0
* The level is decremented by splicing $(..)
incremented by brackets [| |]
incremented by name-quoting 'f
-* When a variable is used, checkWellStaged compares
+* When a variable is used, checkThLocalName compares
bind: binding level, and
use: current level at usage site
@@ -236,16 +233,18 @@ Note [Template Haskell levels]
bind = use Always OK (bound same stage as used)
[| \x -> $(f [| x |]) |]
- bind < use Inside brackets, it depends
- Inside splice, OK
- Inside neither, OK
+ bind < use Inside brackets, it depends on what cross stage
+ persistence rules are used.
For (bind < use) inside brackets, there are three cases:
- - Imported things OK f = [| map |]
- - Top-level things OK g = [| f |]
+ - Imported things (if ImplicitStagePersistence is enabled) OK f = [| map |]
+ - Top-level things (if ImplicitStagePersistence is enabled) OK g = [| f |]
- Non-top-level Only if there is a liftable instance
h = \(x:Int) -> [| x |]
+ If ExplicitLevelImports is used, then imports can bring identifiers into scope
+ at non-zero levels.
+
To track top-level-ness we use the ThBindEnv in TcLclEnv
For example:
@@ -448,7 +447,7 @@ without having to walk over the untyped bracket code. Our example
RENAMER (rnUntypedBracket):
-* Set the ThStage to (Brack s (RnPendingUntyped ps_var))
+* Set the ThLevel to (Brack s (RnPendingUntyped ps_var))
* Rename the body
@@ -558,7 +557,7 @@ RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn:
TYPECHECKER (tcTypedBracket):
-* Set the ThStage to (Brack s (TcPending ps_var lie_var))
+* Set the ThLevel to (Brack s (TcPending ps_var lie_var))
* Typecheck the body, and keep the elaborated result (despite never using it!)
@@ -670,7 +669,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-- See Note [How brackets and nested splices are handled]
tcTypedBracket rn_expr expr res_ty
= addErrCtxt (TypedTHBracketCtxt expr) $
- do { cur_stage <- getStage
+ do { cur_lvl <- getThLevel
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
-- should get thrown into the constraint set
@@ -687,7 +686,7 @@ tcTypedBracket rn_expr expr res_ty
-- The typechecked expression won't be used, so we just discard it
-- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)
-- We'll typecheck it again when we splice it in somewhere
- ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
+ ; (tc_expr, expr_ty) <- setThLevel (Brack cur_lvl (TcPending ps_ref lie_var wrapper)) $
tcScalingUsage ManyTy $
-- Scale by Many, TH lifting is currently nonlinear (#18465)
tcInferRhoNC expr
@@ -836,8 +835,8 @@ getUntypedSpliceBody (HsUntypedSpliceNested {})
tcTypedSplice splice_name expr res_ty
= addErrCtxt (TypedSpliceCtxt (Just splice_name) expr) $
setSrcSpan (getLocA expr) $ do
- { stage <- getStage
- ; case stage of
+ { lvl <- getThLevel
+ ; case lvl of
Splice {} -> tcTopSplice expr res_ty
Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty
RunSplice _ ->
@@ -889,7 +888,8 @@ tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
tcTopSpliceExpr isTypedSplice tc_action
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
- setStage (Splice isTypedSplice) $
+
+ setThLevel (Splice isTypedSplice Comp) $
do { -- Typecheck the expression
(mb_expr', wanted) <- tryCaptureConstraints tc_action
-- If tc_action fails (perhaps because of insoluble constraints)
@@ -904,7 +904,7 @@ tcTopSpliceExpr isTypedSplice tc_action
Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }
------------------
-tcNestedSplice :: ThStage -> PendingStuff -> Name
+tcNestedSplice :: ThLevel -> PendingStuff -> Name
-> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
@@ -912,7 +912,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl
= do { res_ty <- expTypeToType res_ty
; let rep = getRuntimeRep res_ty
; meta_exp_ty <- tcTExpTy m_var res_ty
- ; expr' <- setStage pop_stage $
+ ; expr' <- setThLevel pop_stage $
setConstraintVar lie_var $
tcCheckMonoExpr expr meta_exp_ty
; untype_code <- tcLookupId unTypeCodeName
@@ -940,7 +940,7 @@ runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
-- See Note [Collecting modFinalizers in typed splices].
; modfinalizers_ref <- newTcRef []
-- Run the expression
- ; expr2 <- setStage (RunSplice modfinalizers_ref) $
+ ; expr2 <- setThLevel (RunSplice modfinalizers_ref) $
runMetaE zonked_q_expr
; mod_finalizers <- readTcRef modfinalizers_ref
; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
@@ -1651,15 +1651,15 @@ lookupThInstName th_type = do
-- | Adds a mod finalizer reference to the local environment.
addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
addModFinalizerRef finRef = do
- th_stage <- getStage
- case th_stage of
+ th_lvl <- getThLevel
+ case th_lvl of
RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
-- This case happens only if a splice is executed and the caller does
- -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
+ -- not set the 'ThLevel' to 'RunSplice' to collect finalizers.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
_ ->
pprPanic "addModFinalizer was called when no finalizers were collected"
- (ppr th_stage)
+ (ppr th_lvl)
-- | Releases the external interpreter state.
finishTH :: TcM ()
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 8d4a56fbd2b..efede09cdf1 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -164,6 +164,7 @@ import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
+import GHC.Driver.Downsweep
import GHC.Data.FastString
import GHC.Data.Maybe
@@ -2069,6 +2070,25 @@ exist. For this logic see GHC.IfaceToCore.mk_top_id.
There is also some similar (probably dead) logic in GHC.Rename.Env which says it
was added for External Core which faced a similar issue.
+Note [runTcInteractive module graph]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The `withInteractiveModuleNode` function sets up the module graph which contains
+the interactive module used by `runTcInteractive`.
+
+The module graph is essentially the ambient module graph which is set up when
+ghci loads a module using `load`, with the addition of the interactive module (Ghci<N>),
+which imports the parts specified by the `InteractiveImports`.
+
+Therefore `downsweepInteractiveImports` presumes that any import which is
+determined to be from the home module is already present in the module graph.
+This saves resummarising and performing the whole downsweep again if it's already been
+done.
+
+On the other hand, when GHCi starts up, and no modules have been loaded yet, the
+module graph will be empty. Therefore `downsweepInteractiveImports` will perform
+for the unit portion of the graph, if it's not already been performed.
+
*********************************************************
* *
@@ -2077,12 +2097,20 @@ was added for External Core which faced a similar issue.
*********************************************************
-}
+-- See Note [runTcInteractive module graph]
+withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a
+withInteractiveModuleNode hsc_env thing_inside = do
+ mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env)
+ updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside
+
+
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive hsc_env thing_inside
= initTcInteractive hsc_env $ withTcPlugins hsc_env $
withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
+ withInteractiveModuleNode hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
index 7b6dc06ce38..abd7da5c5b5 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ b/compiler/GHC/Tc/Plugin.hs
@@ -101,7 +101,6 @@ tcPluginIO a = unsafeTcPluginTcM (liftIO a)
tcPluginTrace :: String -> SDoc -> TcPluginM ()
tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
-
findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult
findImportedModule mod_name mb_pkg = do
hsc_env <- getTopEnv
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index 6c040969002..17b18254b64 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -904,7 +904,7 @@ checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
-- Returns the CtLoc to used for sub-goals
-- Probably also want to call checkReductionDepth
checkInstanceOK loc what pred
- = do { checkWellStagedDFun loc what pred
+ = do { checkWellLevelledDFun loc what pred
; return deeper_loc }
where
deeper_loc = zap_origin (bumpCtLocDepth loc)
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index f664527cb13..5efc8ef4550 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -125,7 +125,7 @@ module GHC.Tc.Solver.Monad (
-- Misc
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
- checkWellStagedDFun,
+ checkWellLevelledDFun,
pprEq,
-- Enforcing invariants for type equalities
@@ -145,9 +145,9 @@ import qualified GHC.Tc.Utils.Monad as TcM
import qualified GHC.Tc.Utils.TcMType as TcM
import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )
import qualified GHC.Tc.Utils.Env as TcM
- ( checkWellStaged, tcGetDefaultTys
+ ( tcGetDefaultTys
, tcLookupClass, tcLookupId, tcLookupTyCon
- , topIdLvl )
+ )
import GHC.Tc.Zonk.Monad ( ZonkM )
import qualified GHC.Tc.Zonk.TcType as TcM
import qualified GHC.Tc.Zonk.Type as TcM
@@ -156,6 +156,7 @@ import GHC.Driver.DynFlags
import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )
import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )
+import GHC.Utils.Misc
import GHC.Tc.Solver.Types
@@ -192,14 +193,16 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
import GHC.Types.Unique.Set( elementOfUniqSet )
+import GHC.Types.Id
+import GHC.Types.Basic (allImportLevels)
+import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel)
-import GHC.Unit.Module ( HasModule, getModule, extractModule )
+import GHC.Unit.Module
import qualified GHC.Rename.Env as TcM
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
-import GHC.Utils.Misc (HasDebugCallStack, (<||>))
import GHC.Data.Bag as Bag
import GHC.Data.Pair
@@ -213,16 +216,21 @@ import Data.IORef
import Data.List ( mapAccumL )
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NE
-import Data.Maybe ( isJust )
import qualified Data.Semigroup as S
import GHC.Types.SrcLoc
import GHC.Rename.Env
+import GHC.LanguageExtensions as LangExt
#if defined(DEBUG)
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
import GHC.Data.Graph.Directed
#endif
+import qualified Data.Set as Set
+import GHC.Unit.Module.Graph
+
+import GHC.Data.Maybe
+
{- *********************************************************************
* *
SolverStage and StopOrContinue
@@ -1592,40 +1600,118 @@ recordUsedGREs gres
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
+checkWellLevelledDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
-- Check that we do not try to use an instance before it is available. E.g.
-- instance Eq T where ...
-- f x = $( ... (\(p::T) -> p == p)... )
-- Here we can't use the equality function from the instance in the splice
-checkWellStagedDFun loc what pred
+checkWellLevelledDFun loc what pred
= do
- mbind_lvl <- checkWellStagedInstanceWhat what
+ mbind_lvl <- checkWellLevelledInstanceWhat what
case mbind_lvl of
- Just bind_lvl | bind_lvl > impLevel ->
+ Just (bind_lvls, is_local) ->
wrapTcS $ TcM.setCtLocM loc $ do
- { use_stage <- TcM.getStage
- ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) }
- _ ->
- return ()
+ { use_lvl <- thLevelIndex <$> TcM.getThLevel
+ ; dflags <- getDynFlags
+ ; checkCrossLevelClsInst dflags (LevelCheckInstance what pred) bind_lvls use_lvl is_local }
+ -- If no level information is returned for an InstanceWhat, then it's safe to use
+ -- at any level.
+ Nothing -> return ()
+
+
+-- TODO: Unify this with checkCrossLevelLifting function
+checkCrossLevelClsInst :: DynFlags -> LevelCheckReason
+ -> Set.Set ThLevelIndex -> ThLevelIndex
+ -> Bool -> TcM ()
+checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local
+ -- If the Id is imported, then allow with ImplicitStagePersistence
+ | not is_local
+ , xopt LangExt.ImplicitStagePersistence dflags
+ = return ()
+ -- NB: Do this check after the ImplicitStagePersistence check, because
+ -- it will do some computation to work out the levels of instances.
+ | use_lvl_idx `Set.member` bind_lvls = return ()
+ -- With ImplicitStagePersistence, using later than bound is fine
+ | xopt LangExt.ImplicitStagePersistence dflags
+ , any (use_lvl_idx >=) bind_lvls = return ()
+ | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx)
+
+
-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)
--- See Note [Well-staged instance evidence]
-checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)
-checkWellStagedInstanceWhat what
+-- See Note [Well-levelled instance evidence]
+checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool))
+checkWellLevelledInstanceWhat what
| TopLevInstance { iw_dfun_id = dfun_id } <- what
- = return $ Just (TcM.topIdLvl dfun_id)
+ = Just <$> checkNameVisibleLevels (idName dfun_id)
| BuiltinTypeableInstance tc <- what
- = do
- cur_mod <- extractModule <$> getGblEnv
- return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)
- then outerLevel
- else impLevel)
+ -- The typeable instance is always defined in the same module as the TyCon.
+ = Just <$> checkNameVisibleLevels (tyConName tc)
| otherwise = return Nothing
+-- | Check the levels at which the given name is visible, including a boolean
+-- indicating if the name is local or not.
+checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool)
+checkNameVisibleLevels name = do
+ cur_mod <- extractModule <$> getGblEnv
+ if nameIsLocalOrFrom cur_mod name
+ then return (Set.singleton topLevelIndex, True)
+ else do
+ lvls <- checkModuleVisibleLevels (nameModule name)
+ return (lvls, False)
+
+{- Note [Using the module graph to compute TH level visiblities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking a module M, in order to implement GHC proposal #682
+(see Note [Explicit Level Imports] in GHC.Tc.Gen.Head), we need to be able to
+compute the Template Haskell levels that typeclass instances are visible at in M.
+
+To do this, we use the "level 0 imports" module graph, which we query via
+GHC.Unit.Module.Graph.mgQueryZero. For example, if we want all modules that are
+visible at level -1 from M, we do the following:
+
+ 1. start with all the direct of M imports at level -1, i.e. the "splice imports"
+ 2. then look at all modules that are reachable from these using only level 0
+ normal imports, using 'mgQueryZero'.
+
+This works precisely because, as specified in the proposal, with -XNoImplicitStagePersistence,
+modules only export items at level 0. In particular, instances are only exported
+at level 0.
+
+See the SI36 test for an illustration.
+-}
+
+-- | Check which TH levels a module is visable at
+--
+-- Used to check visibility of instances (do not use this for normal identifiers).
+checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex)
+checkModuleVisibleLevels check_mod = do
+ cur_mod <- extractModule <$> getGblEnv
+ hsc_env <- getTopEnv
+
+ -- 0. The keys for the scope of the current module.
+ let mkKey s m = (ModuleScope (moduleToMnk m NotBoot) s)
+ cur_mod_scope_key s = mkKey s cur_mod
+
+ -- 1. is_visible checks that a specific key is visible from the given level in the
+ -- current module.
+ let is_visible :: ImportLevel -> ZeroScopeKey -> Bool
+ is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k
+
+ -- 2. The key we are looking for, either the module itself in the home package or the
+ -- module unit id of the module we are checking.
+ let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env
+ then mkKey NormalLevel check_mod
+ else UnitScope (moduleUnitId check_mod)
+
+ -- 3. For each level, check if the key is visible from that level.
+ let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key]
+ return $ Set.fromList lvls
+
{-
-Note [Well-staged instance evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Well-levelled instance evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Evidence for instances must obey the same level restrictions as normal bindings.
In particular, it is forbidden to use an instance in a top-level splice in the
@@ -1665,12 +1751,12 @@ Main.hs:12:14: error:
Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on
`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`
-is well staged. It's easy to know the stage of `$tcT`: for imported TyCons it
-will be `impLevel`, and for local TyCons it will be `toplevel`.
+is well levelled. It's easy to know the level of `$tcT`: for imported TyCons it
+will be the level of the imported TyCon Name, and for local TyCons it will be `toplevel`.
Therefore the `InstanceWhat` type had to be extended with
a special case for `Typeable`, which recorded the TyCon the evidence was for and
-could them be used to check that we were not attempting to evidence in a stage incorrect
+could them be used to check that we were not attempting to evidence in a level incorrect
manner.
-}
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 60fe7a96917..d26590136b1 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -418,8 +418,8 @@ tcInstDeclsDeriv
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
tcInstDeclsDeriv deriv_infos derivds
- = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
- if isBrackStage th_stage
+ = do th_lvl <- getThLevel -- See Note [Deriving inside TH brackets]
+ if isBrackLevel th_lvl
then do { gbl_env <- getGblEnv
; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 02f195c3277..da7ecf0edab 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -59,9 +59,15 @@ module GHC.Tc.Types(
CompleteMatch, CompleteMatches,
-- Template Haskell
- ThStage(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),
- topStage, topAnnStage, topSpliceStage,
- ThLevel, impLevel, outerLevel, thLevel,
+ ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),
+ topLevel, topAnnLevel, topSpliceLevel,
+ ThLevelIndex,
+ topLevelIndex,
+ spliceLevelIndex,
+ quoteLevelIndex,
+
+ thLevelIndex,
+
ForeignSrcLang(..), THDocs, DocLoc(..),
ThBindEnv,
@@ -902,6 +908,20 @@ mkModDeps deps = S.foldl' add emptyInstalledModuleEnv deps
where
add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt
+plusDirectModDeps :: InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)
+ -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)
+ -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)
+plusDirectModDeps = plusInstalledModuleEnv plus_mod_dep
+ where
+ plus_mod_dep (st1, r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 }))
+ (st2, r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2}))
+ | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))
+ boot1 == IsBoot = (st1 `S.union` st2, r2)
+ | otherwise = (st1 `S.union` st2, r1)
+ -- If either side can "see" a non-hi-boot interface, use that
+ -- Reusing existing tuples saves 10% of allocations on test
+ -- perf/compiler/MultiLayerModules
+
plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot
-> InstalledModuleEnv ModuleNameWithIsBoot
-> InstalledModuleEnv ModuleNameWithIsBoot
@@ -949,7 +969,7 @@ plusImportAvails
imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = M.unionWith (++) mods1 mods2,
- imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2,
+ imp_direct_dep_mods = ddmods1 `plusDirectModDeps` ddmods2,
imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2,
imp_trust_pkgs = tpkgs1 `S.union` tpkgs2,
imp_trust_own_pkg = tself1 || tself2,
diff --git a/compiler/GHC/Tc/Types/LclEnv.hs b/compiler/GHC/Tc/Types/LclEnv.hs
index 78f5ad51ffa..6764dc5007f 100644
--- a/compiler/GHC/Tc/Types/LclEnv.hs
+++ b/compiler/GHC/Tc/Types/LclEnv.hs
@@ -11,13 +11,13 @@ module GHC.Tc.Types.LclEnv (
, getLclEnvLoc
, getLclEnvRdrEnv
, getLclEnvTcLevel
- , getLclEnvThStage
+ , getLclEnvThLevel
, setLclEnvTcLevel
, setLclEnvLoc
, setLclEnvRdrEnv
, setLclEnvBinderStack
, setLclEnvErrCtxt
- , setLclEnvThStage
+ , setLclEnvThLevel
, setLclEnvTypeEnv
, modifyLclEnvTcLevel
@@ -108,7 +108,7 @@ data TcLclCtxt
-- we can look up record field names
- tcl_th_ctxt :: ThStage, -- Template Haskell context
+ tcl_th_ctxt :: ThLevel, -- Template Haskell context
tcl_th_bndrs :: ThBindEnv, -- and binder info
-- The ThBindEnv records the TH binding level of in-scope Names
-- defined in this module (not imported)
@@ -121,11 +121,11 @@ data TcLclCtxt
-- Ids and TyVars defined in this module
}
-getLclEnvThStage :: TcLclEnv -> ThStage
-getLclEnvThStage = tcl_th_ctxt . tcl_lcl_ctxt
+getLclEnvThLevel :: TcLclEnv -> ThLevel
+getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt
-setLclEnvThStage :: ThStage -> TcLclEnv -> TcLclEnv
-setLclEnvThStage s = modifyLclCtxt (\env -> env { tcl_th_ctxt = s })
+setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv
+setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l })
getLclEnvThBndrs :: TcLclEnv -> ThBindEnv
getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt
@@ -187,7 +187,7 @@ modifyLclCtxt upd env =
type TcTypeEnv = NameEnv TcTyThing
-type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)
+type ThBindEnv = NameEnv (TopLevelFlag, ThLevelIndex)
-- Domain = all Ids bound in this module (ie not imported)
-- The TopLevelFlag tells if the binding is syntactically top level.
-- We need to know this, because the cross-stage persistence story allows
@@ -196,6 +196,7 @@ type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)
-- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being
-- bound at top level! See Note [Template Haskell levels] in GHC.Tc.Gen.Splice
+
---------------------------
-- Arrow-notation context
---------------------------
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 2b6f01e8ea4..221305584bc 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -1533,7 +1533,7 @@ data InstanceWhat -- How did we solve this constraint?
-- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
| BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn)
- -- See Note [Well-staged instance evidence]
+ -- See Note [Well-levelled instance evidence]
| BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is
-- KnownNat, .. etc (classes with no top-level evidence)
diff --git a/compiler/GHC/Tc/Types/TH.hs b/compiler/GHC/Tc/Types/TH.hs
index 245bf54d28c..85caa70bbdc 100644
--- a/compiler/GHC/Tc/Types/TH.hs
+++ b/compiler/GHC/Tc/Types/TH.hs
@@ -1,25 +1,27 @@
module GHC.Tc.Types.TH (
SpliceType(..)
, SpliceOrBracket(..)
- , ThStage(..)
+ , ThLevel(..)
, PendingStuff(..)
- , ThLevel
- , topStage
- , topAnnStage
- , topSpliceStage
- , thLevel
- , impLevel
- , outerLevel
+ , ThLevelIndex
+ , topLevel
+ , topAnnLevel
+ , topSpliceLevel
+ , thLevelIndex
+ , topLevelIndex
+ , spliceLevelIndex
+ , quoteLevelIndex
+ , thLevelIndexFromImportLevel
) where
import GHCi.RemoteTypes
import qualified GHC.Boot.TH.Syntax as TH
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
-import GHC.Prelude
import GHC.Tc.Types.TcRef
import GHC.Tc.Types.Constraint
import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )
+import GHC.Types.ThLevelIndex
---------------------------
-- Template Haskell stages and levels
@@ -28,16 +30,12 @@ import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )
data SpliceType = Typed | Untyped
data SpliceOrBracket = IsSplice | IsBracket
-data ThStage -- See Note [Template Haskell state diagram]
+data ThLevel -- See Note [Template Haskell state diagram]
-- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice
-- Start at: Comp
-- At bracket: wrap current stage in Brack
- -- At splice: currently Brack: return to previous stage
- -- currently Comp/Splice: compile and run
- = Splice SpliceType -- Inside a top-level splice
- -- This code will be run *at compile time*;
- -- the result replaces the splice
- -- Binding level = 0
+ -- At splice: wrap current stage in Splice
+ = Splice SpliceType ThLevel -- Inside a splice
| RunSplice (TcRef [ForeignRef (TH.Q ())])
-- Set when running a splice, i.e. NOT when renaming or typechecking the
@@ -55,10 +53,10 @@ data ThStage -- See Note [Template Haskell state diagram]
-- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice".
| Comp -- Ordinary Haskell code
- -- Binding level = 1
+ -- Binding level = 0
| Brack -- Inside brackets
- ThStage -- Enclosing stage
+ ThLevel -- Enclosing level
PendingStuff
data PendingStuff
@@ -78,43 +76,34 @@ data PendingStuff
-- `lift`.
-topStage, topAnnStage, topSpliceStage :: ThStage
-topStage = Comp
-topAnnStage = Splice Untyped
-topSpliceStage = Splice Untyped
+topLevel, topAnnLevel, topSpliceLevel :: ThLevel
+topLevel = Comp
+topAnnLevel = Splice Untyped Comp
+topSpliceLevel = Splice Untyped Comp
-instance Outputable ThStage where
- ppr (Splice _) = text "Splice"
+instance Outputable ThLevel where
+ ppr (Splice _ s) = text "Splice" <> parens (ppr s)
ppr (RunSplice _) = text "RunSplice"
ppr Comp = text "Comp"
ppr (Brack s _) = text "Brack" <> parens (ppr s)
-type ThLevel = Int
- -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice
- -- Incremented when going inside a bracket,
- -- decremented when going inside a splice
- -- NB: ThLevel is one greater than the 'n' in Fig 2 of the
- -- original "Template meta-programming for Haskell" paper
-
-impLevel, outerLevel :: ThLevel
-impLevel = 0 -- Imported things; they can be used inside a top level splice
-outerLevel = 1 -- Things defined outside brackets
-
-thLevel :: ThStage -> ThLevel
-thLevel (Splice _) = 0
-thLevel Comp = 1
-thLevel (Brack s _) = thLevel s + 1
-thLevel (RunSplice _) = 0 -- previously: panic "thLevel: called when running a splice"
+
+thLevelIndex :: ThLevel -> ThLevelIndex
+thLevelIndex (Splice _ s) = decThLevelIndex (thLevelIndex s)
+thLevelIndex Comp = topLevelIndex
+thLevelIndex (Brack s _) = incThLevelIndex (thLevelIndex s)
+thLevelIndex (RunSplice _) = thLevelIndex (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice"
-- See Note [RunSplice ThLevel].
+
{- Note [RunSplice ThLevel]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The 'RunSplice' stage is set when executing a splice, and only when running a
+The 'RunSplice' level is set when executing a splice, and only when running a
splice. In particular it is not set when the splice is renamed or typechecked.
However, this is not true. `reifyInstances` for example does rename the given type,
and these types may contain variables (#9262 allow free variables in reifyInstances).
-Therefore here we assume that thLevel (RunSplice _) = 0.
+Therefore here we assume that thLevel (RunSplice _) = 0
Proper fix would probably require renaming argument `reifyInstances` separately prior
to evaluation of the overall splice.
@@ -125,3 +114,4 @@ set 'RunSplice' when renaming or typechecking the splice, where 'Splice',
'Brack' or 'Comp' are used instead.
-}
+
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 54af27c6c5e..f778e1f6fb7 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -299,14 +299,14 @@ implicitRequirements hsc_env normal_imports
-- than a transitive closure done here) all the free holes are still reachable.
implicitRequirementsShallow
:: HscEnv
- -> [(PkgQual, Located ModuleName)]
+ -> [(ImportLevel, PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
where
mhome_unit = hsc_home_unit_maybe hsc_env
go acc [] = pure acc
- go (accL, accR) ((mb_pkg, L _ imp):imports) = do
+ go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do
found <- findImportedModule hsc_env imp mb_pkg
let acc' = case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
@@ -634,7 +634,8 @@ mergeSignatures
is_pkg_qual = NoPkgQual,
is_qual = False,
is_isboot = NotBoot,
- is_dloc = locA loc
+ is_dloc = locA loc,
+ is_level = NormalLevel
} ImpAll
rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1
setGblEnv tcg_env {
diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs
index 623063ce683..75ca01bbc79 100644
--- a/compiler/GHC/Tc/Utils/Concrete.hs
+++ b/compiler/GHC/Tc/Utils/Concrete.hs
@@ -670,7 +670,7 @@ checkFRR_with :: HasDebugCallStack
-- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@
-- and @frr_@ty has a fixed 'RuntimeRep'.
checkFRR_with check_kind frr_ctxt ty
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.
| TyConApp tc [] <- ki
@@ -678,7 +678,7 @@ checkFRR_with check_kind frr_ctxt ty
-> return refl
-- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> return refl
-- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index d110fb2cbba..a751b290110 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -60,9 +60,9 @@ module GHC.Tc.Utils.Env(
tcGetDefaultTys,
-- Template Haskell stuff
- StageCheckReason(..),
- checkWellStaged, tcMetaTy, thLevel,
- topIdLvl, isBrackStage,
+ LevelCheckReason(..),
+ tcMetaTy, thLevelIndex,
+ isBrackLevel,
-- New Ids
newDFunName,
@@ -520,9 +520,8 @@ tcExtendTyConEnv tycons thing_inside
-- See GHC ticket #17820 .
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders implicit_things = do
- stage <- getStage
- let th_lvl = thLevel stage
- th_bndrs = mkNameEnv
+ th_lvl <- thLevelIndex <$> getThLevel
+ let th_bndrs = mkNameEnv
[ ( n , (TopLevel, th_lvl) ) | n <- names ]
return th_bndrs
where
@@ -758,7 +757,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
= do { traceTc "tc_extend_local_env" (ppr extra_env)
; updLclCtxt upd_lcl_env thing_inside }
where
- upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = stage
+ upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = th_lvl
, tcl_rdr = rdr_env
, tcl_th_bndrs = th_bndrs
, tcl_env = lcl_type_env })
@@ -775,7 +774,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
-- Template Haskell staging env simultaneously. Reason for extending
-- LocalRdrEnv: after running a TH splice we need to do renaming.
where
- thlvl = (top_lvl, thLevel stage)
+ thlvl = (top_lvl, thLevelIndex th_lvl)
tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
@@ -922,34 +921,6 @@ tcExtendRules lcl_rules thing_inside
************************************************************************
-}
-checkWellStaged :: StageCheckReason -- What the stage check is for
- -> ThLevel -- Binding level (increases inside brackets)
- -> ThLevel -- Use stage
- -> TcM () -- Fail if badly staged, adding an error
-checkWellStaged pp_thing bind_lvl use_lvl
- | use_lvl >= bind_lvl -- OK! Used later than bound
- = return () -- E.g. \x -> [| $(f x) |]
-
- | bind_lvl == outerLevel -- GHC restriction on top level splices
- = failWithTc (TcRnStageRestriction pp_thing)
-
- | otherwise -- Badly staged
- = failWithTc $ -- E.g. \x -> $(f x)
- TcRnBadlyStaged pp_thing bind_lvl use_lvl
-
-topIdLvl :: Id -> ThLevel
--- Globals may either be imported, or may be from an earlier "chunk"
--- (separated by declaration splices) of this module. The former
--- *can* be used inside a top-level splice, but the latter cannot.
--- Hence we give the former impLevel, but the latter topLevel
--- E.g. this is bad:
--- x = [| foo |]
--- $( f x )
--- By the time we are processing the $(f x), the binding for "x"
--- will be in the global env, not the local one.
-topIdLvl id | isLocalId id = outerLevel
- | otherwise = impLevel
-
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
@@ -958,9 +929,9 @@ tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConTy t)
-isBrackStage :: ThStage -> Bool
-isBrackStage (Brack {}) = True
-isBrackStage _other = False
+isBrackLevel :: ThLevel -> Bool
+isBrackLevel (Brack {}) = True
+isBrackLevel _other = False
{-
************************************************************************
@@ -1242,14 +1213,8 @@ pprBinders bndrs = pprWithCommas ppr bndrs
notFound :: Name -> TcM TyThing
notFound name
= do { lcl_env <- getLclEnv
- ; let stage = getLclEnvThStage lcl_env
- ; case stage of -- See Note [Out of scope might be a staging error]
- Splice {}
- | isUnboundName name -> failM -- If the name really isn't in scope
- -- don't report it again (#11941)
- | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))
-
- _ | isTermVarOrFieldNameSpace (nameNameSpace name) ->
+ ; if isTermVarOrFieldNameSpace (nameNameSpace name)
+ then
-- This code path is only reachable with RequiredTypeArguments enabled
-- via the following chain of calls:
-- `notFound` called from
@@ -1262,8 +1227,8 @@ notFound name
-- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env
failWithTc $ TcRnUnpromotableThing name TermVariablePE
- | otherwise -> failWithTc $
- TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) (getRdrName name)
+ else failWithTc $
+ TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) (getRdrName name)
-- Take care: printing the whole gbl env can
-- cause an infinite loop, in the case where we
-- are in the middle of a recursive TyCon/Class group;
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 9d41db1355b..12528020042 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -118,7 +118,7 @@ module GHC.Tc.Utils.Monad(
-- * Template Haskell context
recordThUse, recordThNeededRuntimeDeps,
- keepAlive, getStage, getStageAndBindLevel, setStage,
+ keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel,
addModFinalizersWithLclEnv,
-- * Safe Haskell context
@@ -170,6 +170,7 @@ import GHC.Tc.Types.Evidence
import GHC.Tc.Types.LclEnv
import GHC.Tc.Types.Origin
import GHC.Tc.Types.TcRef
+import GHC.Tc.Types.TH
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.TcType
@@ -210,6 +211,7 @@ import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import qualified GHC.Data.Strict as Strict
+import qualified Data.Set as Set
import GHC.Types.Error
import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )
@@ -229,7 +231,7 @@ import GHC.Types.Unique.FM ( emptyUFM )
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Supply
import GHC.Types.Annotations
-import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
+import GHC.Types.Basic( TopLevelFlag(..), TypeOrKind(..) )
import GHC.Types.CostCentre.State
import GHC.Types.SourceFile
@@ -399,7 +401,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
tcl_in_gen_code = False,
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
- tcl_th_ctxt = topStage,
+ tcl_th_ctxt = topLevel,
tcl_th_bndrs = emptyNameEnv,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
@@ -2113,18 +2115,38 @@ keepAlive name
; traceRn "keep alive" (ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
-getStage :: TcM ThStage
-getStage = do { env <- getLclEnv; return (getLclEnvThStage env) }
+getThLevel :: TcM ThLevel
+getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) }
-getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
-getStageAndBindLevel name
+getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
+getCurrentAndBindLevel name
= do { env <- getLclEnv;
; case lookupNameEnv (getLclEnvThBndrs env) name of
- Nothing -> return Nothing
- Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, getLclEnvThStage env)) }
-
-setStage :: ThStage -> TcM a -> TcRn a
-setStage s = updLclEnv (setLclEnvThStage s)
+ Nothing -> do
+ lvls <- getExternalBindLvl name
+ if Set.empty == lvls
+ -- This case happens when code is generated for identifiers which are not
+ -- in scope.
+ --
+ -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
+ then do
+ return Nothing
+ else return (Just (TopLevel, lvls, getLclEnvThLevel env))
+ Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) }
+
+getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex)
+getExternalBindLvl name = do
+ env <- getGlobalRdrEnv
+ mod <- getModule
+ case lookupGRE_Name env name of
+ Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre))
+ Nothing ->
+ if nameIsLocalOrFrom mod name
+ then return $ Set.singleton topLevelIndex
+ else return Set.empty
+
+setThLevel :: ThLevel -> TcM a -> TcRn a
+setThLevel l = updLclEnv (setLclEnvThLevel l)
-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 96e50ecc74a..980f8f4dcb0 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -458,11 +458,11 @@ newInferExpType = new_inferExpType Nothing
newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
newInferExpTypeFRR frr_orig
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> new_inferExpType Nothing
| otherwise
@@ -800,11 +800,11 @@ newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin
-> FastString -> TcKind -> TcM TcTyVar
newConcreteTyVar reason fs kind
= assertPpr (isConcreteType kind) assert_msg $
- do { th_stage <- getStage
+ do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> newNamedAnonMetaTyVar fs TauTv kind
| otherwise
@@ -986,8 +986,8 @@ newOpenFlexiTyVar
-- in GHC.Tc.Utils.Concrete.
newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar
newOpenFlexiFRRTyVar frr_ctxt
- = do { th_stage <- getStage
- ; case th_stage of
+ = do { th_lvl <- getThLevel
+ ; case th_lvl of
{ Brack _ (TcPending {}) -- See [Wrinkle: Typed Template Haskell]
-> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
; _ ->
@@ -1040,11 +1040,11 @@ newMetaTyVarX = new_meta_tv_x TauTv
-- | Like 'newMetaTyVarX', but for concrete type variables.
newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar)
newConcreteTyVarX conc subst tv
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> new_meta_tv_x TauTv subst tv
| otherwise
-> new_meta_tv_x (ConcreteTv conc) subst tv }
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index efe560cb76e..faf238b7aeb 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -21,6 +21,8 @@ types that
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
module GHC.Types.Basic (
LeftOrRight(..),
@@ -119,7 +121,9 @@ module GHC.Types.Basic (
NonStandardDefaultingStrategy(..),
DefaultingStrategy(..), defaultNonStandardTyVars,
- ForeignSrcLang (..)
+ ForeignSrcLang (..),
+
+ ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels
) where
import GHC.Prelude
@@ -134,12 +138,12 @@ import qualified GHC.LanguageExtensions as LangExt
import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted)
import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag)
import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour)
-
import Control.DeepSeq ( NFData(..) )
import Data.Data
import Data.Maybe
import qualified Data.Semigroup as Semi
+import Language.Haskell.Syntax.ImpExp
{-
************************************************************************
* *
@@ -2435,3 +2439,26 @@ instance Outputable NonStandardDefaultingStrategy where
instance Outputable DefaultingStrategy where
ppr DefaultKindVars = text "DefaultKindVars"
ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns
+
+-- | ImportLevel
+
+data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded)
+
+instance Outputable ImportLevel where
+ ppr NormalLevel = text "normal"
+ ppr SpliceLevel = text "splice"
+ ppr QuoteLevel = text "quote"
+
+deriving via (EnumBinary ImportLevel) instance Binary ImportLevel
+
+allImportLevels :: [ImportLevel]
+allImportLevels = [minBound..maxBound]
+
+convImportLevel :: ImportDeclLevelStyle -> ImportLevel
+convImportLevel (LevelStylePre level) = convImportLevelSpec level
+convImportLevel (LevelStylePost level) = convImportLevelSpec level
+convImportLevel NotLevelled = NormalLevel
+
+convImportLevelSpec :: ImportDeclLevel -> ImportLevel
+convImportLevelSpec ImportDeclQuote = QuoteLevel
+convImportLevelSpec ImportDeclSplice = SpliceLevel
\ No newline at end of file
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 1b1296f8dc7..f3d47723056 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -295,6 +295,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrUnallowedPragma" = 85314
GhcDiagnosticCode "PsErrImportPostQualified" = 87491
GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661
+ GhcDiagnosticCode "PsErrSpliceOrQuoteTwice" = 26105
GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284
GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396
GhcDiagnosticCode "PsErrMissingBlock" = 16849
@@ -621,9 +622,9 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412
GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333
GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254
- GhcDiagnosticCode "TcRnBadlyStaged" = 28914
- GhcDiagnosticCode "TcRnBadlyStagedType" = 86357
- GhcDiagnosticCode "TcRnStageRestriction" = 18157
+ GhcDiagnosticCode "TcRnBadlyLevelled" = 28914
+ GhcDiagnosticCode "TcRnBadlyLevelledType" = 86357
+ GhcDiagnosticCode "TcRnStageRestriction" = Outdated 18157
GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969
GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924
GhcDiagnosticCode "TcRnUninferrableTyVar" = 16220
@@ -965,7 +966,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "NestedTHBrackets" = 59185
GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice" = 17599
GhcDiagnosticCode "BadImplicitSplice" = 25277
- GhcDiagnosticCode "QuotedNameWrongStage" = 57695
+ GhcDiagnosticCode "QuotedNameWrongStage" = Outdated 57695
GhcDiagnosticCode "IllegalStaticFormInSplice" = 12219
-- Zonker messages
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 7619fc03b4d..5f5b45a1012 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -90,7 +90,7 @@ module GHC.Types.Name.Reader (
pprNameProvenance,
mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE,
mkLocalConLikeGRE, mkLocalFieldGREs,
- gresToNameSet,
+ gresToNameSet, greLevels,
-- ** Shadowing
greClashesWith, shadowNames,
@@ -106,10 +106,12 @@ module GHC.Types.Name.Reader (
Parent(..), ParentGRE(..), greParent_maybe,
mkParent, availParent,
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- importSpecLoc, importSpecModule, isExplicitItem, bestImport,
+ importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport,
+ ImportLevel(..),
-- * Utils
- opIsAt
+ opIsAt,
+
) where
import GHC.Prelude
@@ -131,6 +133,8 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Builtin.Uniques ( isFldNSUnique )
+import GHC.Types.ThLevelIndex
+import qualified Data.Set as Set
import GHC.Unit.Module
@@ -637,6 +641,11 @@ greParent = gre_par
greInfo :: GlobalRdrElt -> GREInfo
greInfo = gre_info
+greLevels :: GlobalRdrElt -> Set.Set ImportLevel
+greLevels g =
+ if gre_lcl g then Set.singleton NormalLevel
+ else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g)))
+
-- | See Note [Parents]
data Parent = NoParent
| ParentIs { par_is :: !Name }
@@ -1812,6 +1821,7 @@ shadowNames drop_only_qualified env new_gres = minusOccEnv_C_Ns do_shadowing env
, is_as = old_mod_name
, is_pkg_qual = NoPkgQual
, is_qual = True
+ , is_level = NormalLevel -- MP: Not 100% sure this is correct
, is_isboot = NotBoot
, is_dloc = greDefinitionSrcSpan old_gre }
@@ -1974,19 +1984,24 @@ data ImpDeclSpec
is_pkg_qual :: !PkgQual, -- ^ Was this a package import?
is_qual :: !Bool, -- ^ Was this import qualified?
is_dloc :: !SrcSpan, -- ^ The location of the entire import declaration
- is_isboot :: !IsBootInterface -- ^ Was this a SOURCE import?
+ is_isboot :: !IsBootInterface, -- ^ Was this a SOURCE import?
+ is_level :: !ImportLevel -- ^ Was this import level modified? splice/quote +-1
} deriving (Eq, Data)
+
+
instance NFData ImpDeclSpec where
rnf = rwhnf -- Already strict in all fields
+
instance Binary ImpDeclSpec where
- put_ bh (ImpDeclSpec mod as pkg_qual qual _dloc isboot) = do
+ put_ bh (ImpDeclSpec mod as pkg_qual qual _dloc isboot isstage) = do
put_ bh mod
put_ bh as
put_ bh pkg_qual
put_ bh qual
put_ bh isboot
+ put_ bh (fromEnum isstage)
get bh = do
mod <- get bh
@@ -1994,7 +2009,8 @@ instance Binary ImpDeclSpec where
pkg_qual <- get bh
qual <- get bh
isboot <- get bh
- return (ImpDeclSpec mod as pkg_qual qual noSrcSpan isboot)
+ isstage <- toEnum <$> get bh
+ return (ImpDeclSpec mod as pkg_qual qual noSrcSpan isboot isstage)
-- | Import Item Specification
--
@@ -2108,6 +2124,9 @@ importSpecLoc (ImpSpec _ item) = is_iloc item
importSpecModule :: ImportSpec -> ModuleName
importSpecModule = moduleName . is_mod . is_decl
+importSpecLevel :: ImportSpec -> ImportLevel
+importSpecLevel = is_level . is_decl
+
isExplicitItem :: ImpItemSpec -> Bool
isExplicitItem ImpAll = False
isExplicitItem (ImpSome {is_explicit = exp}) = exp
@@ -2145,11 +2164,18 @@ instance Outputable ImportSpec where
ppr imp_spec
= text "imported" <+> qual
<+> text "from" <+> quotes (ppr (importSpecModule imp_spec))
+ <+> level_ppr
<+> pprLoc (importSpecLoc imp_spec)
where
qual | is_qual (is_decl imp_spec) = text "qualified"
| otherwise = empty
+ level = thLevelIndexFromImportLevel (is_level (is_decl imp_spec))
+ level_ppr
+ | level == topLevelIndex = empty
+ | otherwise = text "at" <+> ppr level
+
+
pprLoc :: SrcSpan -> SDoc
pprLoc (RealSrcSpan s _) = text "at" <+> ppr s
pprLoc (UnhelpfulSpan {}) = empty
diff --git a/compiler/GHC/Types/ThLevelIndex.hs b/compiler/GHC/Types/ThLevelIndex.hs
new file mode 100644
index 00000000000..9db6e4d2cbb
--- /dev/null
+++ b/compiler/GHC/Types/ThLevelIndex.hs
@@ -0,0 +1,35 @@
+module GHC.Types.ThLevelIndex where
+
+import GHC.Prelude
+import GHC.Utils.Outputable
+import GHC.Types.Basic ( ImportLevel(..) )
+
+-- | The integer which represents the level
+newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord)
+ -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice
+ -- Incremented when going inside a bracket,
+ -- decremented when going inside a splice
+
+instance Outputable ThLevelIndex where
+ ppr (ThLevelIndex i) = int i
+
+incThLevelIndex :: ThLevelIndex -> ThLevelIndex
+incThLevelIndex (ThLevelIndex i) = ThLevelIndex (i + 1)
+
+decThLevelIndex :: ThLevelIndex -> ThLevelIndex
+decThLevelIndex (ThLevelIndex i) = ThLevelIndex (i - 1)
+
+topLevelIndex :: ThLevelIndex
+topLevelIndex = ThLevelIndex 0
+
+spliceLevelIndex :: ThLevelIndex
+spliceLevelIndex = decThLevelIndex topLevelIndex
+
+quoteLevelIndex :: ThLevelIndex
+quoteLevelIndex = incThLevelIndex topLevelIndex
+
+-- | Convert a 'GHC.Types.Basic.ImportLevel' to a 'ThLevelIndex'
+thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex
+thLevelIndexFromImportLevel NormalLevel = topLevelIndex
+thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex
+thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex
\ No newline at end of file
diff --git a/compiler/GHC/Unit/Home/PackageTable.hs b/compiler/GHC/Unit/Home/PackageTable.hs
index dd1b8ed0d3a..880270154ba 100644
--- a/compiler/GHC/Unit/Home/PackageTable.hs
+++ b/compiler/GHC/Unit/Home/PackageTable.hs
@@ -232,7 +232,7 @@ hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)
-- ever want to collect *all* dependencies. The current caller of this function
-- currently takes all dependencies only to then filter them with an ad-hoc transitive closure check.
-- See #25639
-hptCollectDependencies :: HomePackageTable -> IO (Set.Set UnitId)
+hptCollectDependencies :: HomePackageTable -> IO (Set.Set (IfaceImportLevel, UnitId))
hptCollectDependencies HPT{table} = do
hpt <- readIORef table
return $
diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs
index 2980b156a15..26a87d0a86b 100644
--- a/compiler/GHC/Unit/Module/Deps.hs
+++ b/compiler/GHC/Unit/Module/Deps.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE DerivingVia #-}
-- | Dependencies and Usage of a module
module GHC.Unit.Module.Deps
( Dependencies(dep_direct_mods
@@ -21,6 +22,8 @@ module GHC.Unit.Module.Deps
, HomeModImport (..)
, HomeModImportedAvails (..)
, ImportAvails (..)
+ , IfaceImportLevel(..)
+ , tcImportLevel
)
where
@@ -31,6 +34,7 @@ import GHC.Data.FastString
import GHC.Types.Avail
import GHC.Types.SafeHaskell
import GHC.Types.Name
+import GHC.Types.Basic
import GHC.Unit.Module.Imported
import GHC.Unit.Module
@@ -49,6 +53,7 @@ import Control.DeepSeq
import GHC.Types.Name.Set
+
-- | Dependency information about ALL modules and packages below this one
-- in the import hierarchy. This is the serialisable version of `ImportAvails`.
--
@@ -60,11 +65,11 @@ import GHC.Types.Name.Set
--
-- See Note [Transitive Information in Dependencies]
data Dependencies = Deps
- { dep_direct_mods_ :: Set (UnitId, ModuleNameWithIsBoot)
+ { dep_direct_mods_ :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot)
-- ^ All home-package modules which are directly imported by this one.
-- This may include modules from other units when using multiple home units
- , dep_direct_pkgs_ :: Set UnitId
+ , dep_direct_pkgs_ :: Set (IfaceImportLevel, UnitId)
-- ^ All packages directly imported by this module
-- I.e. packages to which this module's direct imports belong.
-- Does not include other home units when using multiple home units.
@@ -113,8 +118,8 @@ data Dependencies = Deps
-- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints
-- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.
-pattern Dependencies :: Set (UnitId, ModuleNameWithIsBoot)
- -> Set UnitId
+pattern Dependencies :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot)
+ -> Set (IfaceImportLevel, UnitId)
-> Set UnitId
-> [ModuleName]
-> Set UnitId
@@ -145,6 +150,22 @@ instance NFData Dependencies where
`seq` rnf finsts
`seq` ()
+newtype IfaceImportLevel = IfaceImportLevel ImportLevel
+ deriving (Eq, Ord)
+ deriving Binary via EnumBinary ImportLevel
+
+tcImportLevel :: IfaceImportLevel -> ImportLevel
+tcImportLevel (IfaceImportLevel lvl) = lvl
+
+instance NFData IfaceImportLevel where
+ rnf (IfaceImportLevel lvl) = case lvl of
+ NormalLevel -> ()
+ QuoteLevel -> ()
+ SpliceLevel -> ()
+
+instance Outputable IfaceImportLevel where
+ ppr (IfaceImportLevel lvl) = ppr lvl
+
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
@@ -154,15 +175,19 @@ mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies
mkDependencies home_unit mod imports plugin_mods =
let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods
plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins)
- all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot))
+ all_direct_mods = foldr (\(s, mn) m -> extendInstalledModuleEnv m mn (s, (GWIB (moduleName mn) NotBoot)))
(imp_direct_dep_mods imports)
- (map (fmap toUnitId) home_plugins)
+ (map (fmap (fmap toUnitId) . (Set.singleton SpliceLevel,)) home_plugins)
- modDepsElts = Set.fromList . installedModuleEnvElts
+ modDepsElts_source :: Ord a => InstalledModuleEnv a -> Set.Set (InstalledModule, a)
+ modDepsElts_source = Set.fromList . installedModuleEnvElts
-- It's OK to use nonDetEltsUFM here because sorting by module names
-- restores determinism
- direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))
+ modDepsElts :: Ord a => InstalledModuleEnv (Set.Set ImportLevel, a) -> Set.Set (IfaceImportLevel, UnitId, a)
+ modDepsElts e = Set.fromList [ (IfaceImportLevel s, moduleUnit im, a) | (im, (ss,a)) <- installedModuleEnvElts e, s <- Set.toList ss]
+
+ direct_mods = modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))
-- M.hi-boot can be in the imp_dep_mods, but we must remove
-- it before recording the modules on which this one depends!
-- (We want to retain M.hi-boot in imp_dep_mods so that
@@ -174,7 +199,7 @@ mkDependencies home_unit mod imports plugin_mods =
-- We must also remove self-references from imp_orphs. See
-- Note [Module self-dependency]
- direct_pkgs = imp_dep_direct_pkgs imports
+ direct_pkgs = Set.map (\(lvl, uid) -> (IfaceImportLevel lvl, uid)) (imp_dep_direct_pkgs imports)
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [Tracking Trust Transitively] in GHC.Rename.Names
@@ -182,7 +207,7 @@ mkDependencies home_unit mod imports plugin_mods =
-- If there's a non-boot import, then it shadows the boot import
-- coming from the dependencies
- source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports)
+ source_mods = first moduleUnit `Set.map` modDepsElts_source (imp_boot_mods imports)
sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports
@@ -271,8 +296,8 @@ pprDeps unit_state (Deps { dep_direct_mods_ = dmods
text "family instance modules:" <+> fsep (map ppr finsts)
]
where
- ppr_mod (uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]"
- ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod
+ ppr_mod (_, uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]"
+ ppr_mod (lvl, uid, (GWIB mod NotBoot)) = ppr lvl <+> ppr uid <> colon <> ppr mod
ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc
ppr_set w = fsep . fmap w . Set.toAscList
@@ -605,10 +630,10 @@ data ImportAvails
-- different packages. (currently not the case, but might be in the
-- future).
- imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot,
+ imp_direct_dep_mods :: InstalledModuleEnv (Set.Set ImportLevel, ModuleNameWithIsBoot),
-- ^ Home-package modules directly imported by the module being compiled.
- imp_dep_direct_pkgs :: Set UnitId,
+ imp_dep_direct_pkgs :: Set (ImportLevel, UnitId),
-- ^ Packages directly needed by the module being compiled
imp_trust_own_pkg :: Bool,
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index 322fabd2f13..b9b86362272 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -39,6 +39,10 @@ module GHC.Unit.Module.Graph
, mgNodeIsModule
, mgNodeUnitId
+ , ModuleNodeEdge(..)
+ , mkModuleEdge
+ , mkNormalEdge
+
, ModuleNodeInfo(..)
, moduleNodeInfoModule
, moduleNodeInfoUnitId
@@ -64,6 +68,7 @@ module GHC.Unit.Module.Graph
, mgModSummaries
, mgLookupModule
, mgHasHoles
+ , showModMsg
-- ** Reachability queries
--
@@ -74,7 +79,10 @@ module GHC.Unit.Module.Graph
, mgReachable
, mgReachableLoop
, mgQuery
+ , ZeroScopeKey(..)
+ , mgQueryZero
, mgQueryMany
+ , mgQueryManyZero
, mgMember
-- ** Other operations
@@ -93,6 +101,11 @@ module GHC.Unit.Module.Graph
-- hptInstancesBelow is re-doing that work every
-- time it's called.
, filterToposortToModules
+ , moduleGraphNodesZero
+ , StageSummaryNode
+ , stageSummaryNodeSummary
+ , stageSummaryNodeKey
+ , mkStageDeps
-- * Keys into the 'ModuleGraph'
, NodeKey(..)
@@ -110,6 +123,8 @@ module GHC.Unit.Module.Graph
, mnKey
, miKey
+ , ImportLevel(..)
+
-- ** Internal node representation
--
-- | 'SummaryNode' is the internal representation for each node stored in
@@ -118,8 +133,6 @@ module GHC.Unit.Module.Graph
, summaryNodeSummary
, summaryNodeKey
- -- * Utilities
- , showModMsg
)
where
@@ -135,12 +148,13 @@ import GHC.Driver.Backend
import GHC.Driver.DynFlags
import GHC.Types.SourceFile ( hscSourceString, isHsigFile, HscSource(..))
+import GHC.Types.Basic
import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
import GHC.Utils.Outputable
import GHC.Unit.Module.ModIface
-import GHC.Utils.Misc ( partitionWith )
+import GHC.Utils.Misc ( partitionWith, HasCallStack )
import System.FilePath
import qualified Data.Map as Map
@@ -149,6 +163,7 @@ import qualified Data.Set as Set
import Data.Set (Set)
import GHC.Unit.Module
import GHC.Unit.Module.ModNodeKey
+import GHC.Unit.Module.Stage
import GHC.Linker.Static.Utils
import Data.Bifunctor
@@ -157,6 +172,7 @@ import Data.List (sort)
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad
+import qualified GHC.LanguageExtensions as LangExt
-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See
-- '@ModuleGraphNode@' for information about the nodes.
@@ -173,6 +189,7 @@ data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
, mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
+ , mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
-- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations
-- so that a lot of work is not repeated whenever the transitive
@@ -192,7 +209,10 @@ data ModuleGraph = ModuleGraph
-- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) False
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
+ (graphReachability emptyGraph, const Nothing)
+ (graphReachability emptyGraph, const Nothing)
+ False
-- | Construct a module graph. This function should be the only entry point for
-- building a 'ModuleGraph', since it is supposed to be built once and never modified.
@@ -229,13 +249,31 @@ data ModuleGraphNode
-- - Fixed modules are not compiled, the artifacts are just loaded from disk.
-- It is up to your to make sure the artifacts are up to date and available.
-- - Compile modules are compiled from source if needed.
- | ModuleNode [NodeKey] ModuleNodeInfo
+ | ModuleNode [ModuleNodeEdge] ModuleNodeInfo
-- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
| LinkNode [NodeKey] UnitId
-- | Package dependency
| UnitNode [UnitId] UnitId
+data ModuleNodeEdge = ModuleNodeEdge { edgeLevel :: ImportLevel
+ , edgeTargetKey :: NodeKey }
+
+mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge
+mkModuleEdge level key = ModuleNodeEdge level key
+
+-- | A 'normal' edge in the graph which isn't offset by an import stage.
+mkNormalEdge :: NodeKey -> ModuleNodeEdge
+mkNormalEdge = mkModuleEdge NormalLevel
+
+instance Outputable ModuleNodeEdge where
+ ppr (ModuleNodeEdge level key) =
+ let level_str = case level of
+ NormalLevel -> ""
+ SpliceLevel -> "(S)"
+ QuoteLevel -> "(Q)"
+ in text level_str <> ppr key
+
data ModuleGraphInvariantError =
FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey]
| DuplicateModuleNodeKey NodeKey
@@ -308,7 +346,7 @@ checkFixedModuleInvariant node_types node = case node of
-- Dependency is not fixed
Just (Left MN_Compile) -> Just dep
_ -> Nothing
- bad_deps = mapMaybe check_node deps
+ bad_deps = mapMaybe check_node (map edgeTargetKey deps)
in if null bad_deps
then Nothing
else Just (FixedNodeDependsOnCompileNode key bad_deps)
@@ -394,7 +432,7 @@ mgNodeDependencies drop_hs_boot_nodes = \case
[ NodeKey_Module (ModNodeKeyWithUid (GWIB mod NotBoot) uid) | mod <- uniqDSetToList (instUnitHoles iuid) ]
++ [ NodeKey_ExternalUnit (instUnitInstanceOf iuid) ]
ModuleNode deps _ms ->
- map drop_hs_boot deps
+ map (drop_hs_boot . edgeTargetKey) deps
UnitNode deps _ -> map NodeKey_ExternalUnit deps
where
-- Drop hs-boot nodes by using HsSrcFile as the key
@@ -434,7 +472,6 @@ instance Ord ModuleGraphNode where
--------------------------------------------------------------------------------
-- * Module Graph operations
--------------------------------------------------------------------------------
-
-- | Returns the number of nodes in a 'ModuleGraph'
lengthMG :: ModuleGraph -> Int
lengthMG = length . mg_mss
@@ -469,12 +506,14 @@ mgMapM f mg@ModuleGraph{..} = do
UnitNode deps uid -> pure $ UnitNode deps uid
return $ mg { mg_mss = mss' }
+
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ]
-- | Look up a non-boot ModSummary in the ModuleGraph.
--
-- Careful: Linear in the size of the module graph
+-- MP: This should probably be level aware
mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo
mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
where
@@ -512,6 +551,19 @@ mgReachableLoop mg nk = map summaryNodeSummary modules_below where
modules_below =
allReachableMany td_map (mapMaybe lookup_node nk)
+
+-- | @'mgQueryZero' g root b@ answers the question: can we reach @b@ from @root@
+-- in the module graph @g@, only using normal (level 0) imports?
+mgQueryZero :: HasCallStack => ModuleGraph
+ -> ZeroScopeKey
+ -> ZeroScopeKey
+ -> Bool
+mgQueryZero mg nka nkb = pprTrace "mgQueryZero" (ppr nka <+> ppr nkb) $ isReachable td_map na nb where
+ (td_map, lookup_node) = mg_zero_graph mg
+ na = expectJust $ pprTrace "lookup_node nka" (ppr (reachabilityIndexMembers td_map) <+> ppr nka) $ lookup_node nka
+ nb = expectJust $ lookup_node nkb
+
+
-- | Reachability Query.
--
-- @mgQuery(g, a, b)@ asks:
@@ -542,6 +594,21 @@ mgQueryMany mg roots nkb = isReachableMany td_map nroots nb where
nroots = mapMaybe lookup_node roots
nb = expectJust $ lookup_node nkb
+-- | Many roots reachability Query.
+--
+-- @mgQuery(g, roots, b)@ asks:
+-- Can we reach @b@ from any of the @roots@ in graph @g@, only using normal (level 0) imports?
+--
+-- Node @b@ must be in @g@.
+mgQueryManyZero :: ModuleGraph -- ^ @g@
+ -> [ZeroScopeKey] -- ^ @roots@
+ -> ZeroScopeKey -- ^ @b@
+ -> Bool -- ^ @b@ is reachable from @roots@
+mgQueryManyZero mg roots nkb = isReachableMany td_map nroots nb where
+ (td_map, lookup_node) = mg_zero_graph mg
+ nroots = mapMaybe lookup_node roots
+ nb = expectJust $ lookup_node (pprTrace "mg" (ppr nkb) nkb)
+
--------------------------------------------------------------------------------
-- ** Other operations (read haddocks on export list)
--------------------------------------------------------------------------------
@@ -598,12 +665,13 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
+
-- | This function returns all the modules belonging to the home-unit that can
-- be reached by following the given dependencies. Additionally, if both the
-- boot module and the non-boot module can be reached, it only returns the
-- non-boot one.
moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below ]
+moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below]
where
modules_below = maybe [] (map mkNodeKey) (mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid)))
filtered_mods = Set.fromDistinctAscList . filter_mods . sort
@@ -767,12 +835,191 @@ moduleNodeInfoBootString mn@(ModuleNodeFixed {}) =
newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
deriving (Functor, Traversable, Foldable)
+-- | Transitive dependencies, including SOURCE edges
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
+-- | Transitive dependencies, ignoring SOURCE edges
mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransLoopDeps = first cyclicGraphReachability . moduleGraphNodes True
+-- | Transitive dependencies, but only following "normal" level 0 imports.
+-- This graph can be used to query what the transitive dependencies of a particular
+-- level are within a module.
+mkTransZeroDeps :: [ModuleGraphNode] -> (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
+mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodesZero
+
+-- | Transitive dependencies, but with the stage that each module is required at.
+mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
+mkStageDeps = first graphReachability . moduleGraphNodesStages
+
+type ZeroSummaryNode = Node Int ZeroScopeKey
+
+zeroSummaryNodeKey :: ZeroSummaryNode -> Int
+zeroSummaryNodeKey = node_key
+
+zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey
+zeroSummaryNodeSummary = node_payload
+
+-- | The 'ZeroScopeKey' indicates the different scopes which we can refer to in a zero-scope query.
+data ZeroScopeKey = ModuleScope ModNodeKeyWithUid ImportLevel | UnitScope UnitId
+ deriving (Eq, Ord)
+
+instance Outputable ZeroScopeKey where
+ ppr (ModuleScope mk il) = text "ModuleScope" <+> ppr mk <+> ppr il
+ ppr (UnitScope uid) = text "UnitScope" <+> ppr uid
+
+-- | Turn a list of graph nodes into an efficient queriable graph.
+-- This graph only has edges between level-0 imports
+--
+-- This query answers the question. If I am looking at level n in module M then which
+-- modules are visible?
+--
+-- If you are looking at level -1 then the reachable modules are those imported at splice and
+-- then any modules those modules import at zero. (Ie the zero scope for those modules)
+moduleGraphNodesZero ::
+ [ModuleGraphNode]
+ -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
+moduleGraphNodesZero summaries =
+ (graphFromEdgedVerticesUniq nodes, lookup_node)
+ where
+ nodes = mapMaybe go numbered_summaries
+
+ where
+ go :: (((ModuleGraphNode, ImportLevel)), Int) -> Maybe ZeroSummaryNode
+ go (((ModuleNode nks ms), s), key) = Just $
+ DigraphNode (ModuleScope (mnKey ms) s) key $ out_edge_keys $
+ mapMaybe (classifyDeps s) nks
+ go (((UnitNode uids uid), _s), key) =
+ Just $ DigraphNode (UnitScope uid) key (mapMaybe lookup_key $ map UnitScope uids)
+ go _ = Nothing
+
+ -- This is the key part, a dependency edge also depends on the NormalLevel scope of an import.
+ classifyDeps s (ModuleNodeEdge il (NodeKey_Module k)) | s == il = Just (ModuleScope k NormalLevel)
+ classifyDeps s (ModuleNodeEdge il (NodeKey_ExternalUnit u)) | s == il = Just (UnitScope u)
+ classifyDeps _ _ = Nothing
+
+ numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)]
+ numbered_summaries = zip (([(s, l) | s <- summaries, l <- [SpliceLevel, QuoteLevel, NormalLevel]])) [0..]
+
+ lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode
+ lookup_node key = Map.lookup key node_map
+
+ lookup_key :: ZeroScopeKey -> Maybe Int
+ lookup_key = fmap zeroSummaryNodeKey . lookup_node
+
+ node_map :: Map.Map ZeroScopeKey ZeroSummaryNode
+ node_map =
+ Map.fromList [ (s, node)
+ | node <- nodes
+ , let s = zeroSummaryNodeSummary node
+ ]
+
+ out_edge_keys :: [ZeroScopeKey] -> [Int]
+ out_edge_keys = mapMaybe lookup_key
+
+type StageSummaryNode = Node Int (NodeKey, ModuleStage)
+
+stageSummaryNodeKey :: StageSummaryNode -> Int
+stageSummaryNodeKey = node_key
+
+stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage)
+stageSummaryNodeSummary = node_payload
+
+-- | Turn a list of graph nodes into an efficient queriable graph.
+-- This graph has edges between modules and the stage they are required at.
+--
+-- This graph can be used to answer the query, if I am compiling a module at stage
+-- S, then what modules do I need at which stages for that?
+-- Used by 'downsweep' in order to determine which modules need code generation if you
+-- are using 'TemplateHaskell'.
+--
+-- The rules for this query can be read in more detail in the Explicit Level Imports proposal.
+-- Briefly:
+-- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage
+-- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages.
+-- * Otherwise, an imported module is just needed at the normal stage.
+--
+-- * A module using TemplateHaskellQuotes required at C stage is also required at R
+-- stage.
+moduleGraphNodesStages ::
+ [ModuleGraphNode]
+ -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
+moduleGraphNodesStages summaries =
+ (graphFromEdgedVerticesUniq nodes, lookup_node)
+ where
+ nodes = map go numbered_summaries
+
+ where
+ go :: (((ModuleGraphNode, ModuleStage)), Int) -> StageSummaryNode
+ go (s, key) = normal_case s
+ where
+ normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode
+ normal_case ((m@(ModuleNode nks ms), s)) =
+ DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $
+ selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks
+ normal_case (m, s) =
+ DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m)
+
+ isExplicitStageMS :: ModSummary -> Bool
+ isExplicitStageMS ms = not (xopt LangExt.ImplicitStagePersistence (ms_hspp_opts ms))
+
+ isTemplateHaskellQuotesMS :: ModSummary -> Bool
+ isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms)
+
+ -- Accounting for persistence within a module.
+ -- If a module is required @ C and it persists an idenfifier, it's also required
+ -- at R.
+ selfEdges (ModuleNodeCompile ms) s self_key
+ | not (isExplicitStageMS ms)
+ && (isTemplateHaskellQuotesMS ms
+ || isTemplateHaskellOrQQNonBoot ms)
+ = [(self_key, s') | s' <- onlyFutureStages s]
+ selfEdges _ _ _ = []
+
+ -- Case 1. No implicit stage persistnce is enabled
+ classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k)
+ | isExplicitStageMS ms = case il of
+ SpliceLevel -> [(k, decModuleStage s)]
+ NormalLevel -> [(k, s)]
+ QuoteLevel -> [(k, incModuleStage s)]
+ -- Case 2a. TemplateHaskellQuotes case (section 5.6 in the paper)
+ classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge _ k)
+ | not (isExplicitStageMS ms)
+ , not (isTemplateHaskellOrQQNonBoot ms)
+ , isTemplateHaskellQuotesMS ms
+ = [(k, s') | s' <- nowAndFutureStages s]
+ -- Case 2b. Template haskell is enabled, with implicit stage persistence
+ classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k)
+ | isTemplateHaskellOrQQNonBoot ms
+ , not (isExplicitStageMS ms) =
+ [(k, s) | s <- allStages]
+ -- Case 3. No template haskell, therefore no additional dependencies.
+ classifyDeps _ s (ModuleNodeEdge _ k) = [(k, s)]
+
+
+ numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]
+ numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..]
+
+ lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode
+ lookup_node key = Map.lookup key node_map
+
+ lookup_key :: (NodeKey, ModuleStage) -> Maybe Int
+ lookup_key = fmap stageSummaryNodeKey . lookup_node
+
+ node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode
+ node_map =
+ Map.fromList [ (s, node)
+ | node <- nodes
+ , let s = stageSummaryNodeSummary node
+ ]
+
+ out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int]
+ out_edge_keys = mapMaybe lookup_key
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- IsBoot; else False
+
+
-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
@@ -781,5 +1028,7 @@ extendMG ModuleGraph{..} node =
{ mg_mss = node : mg_mss
, mg_graph = mkTransDeps (node : mg_mss)
, mg_loop_graph = mkTransLoopDeps (node : mg_mss)
+ , mg_zero_graph = mkTransZeroDeps (node : mg_mss)
, mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node)
}
+
diff --git a/compiler/GHC/Unit/Module/Imported.hs b/compiler/GHC/Unit/Module/Imported.hs
index 71baeeea934..94cbdc9a9e9 100644
--- a/compiler/GHC/Unit/Module/Imported.hs
+++ b/compiler/GHC/Unit/Module/Imported.hs
@@ -43,6 +43,9 @@ data ImportedModsVal = ImportedModsVal
, imv_is_safe :: IsSafeImport
-- ^ whether this is a safe import
+ , imv_is_level :: ImportLevel
+ -- ^ the level the module is imported at (splice, quote, or normal)
+
, imv_is_hiding :: Bool
-- ^ whether this is an "hiding" import
diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs
index c01c70ecc8c..fcde5f50889 100644
--- a/compiler/GHC/Unit/Module/ModSummary.hs
+++ b/compiler/GHC/Unit/Module/ModSummary.hs
@@ -43,6 +43,7 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceString )
import GHC.Types.SrcLoc
import GHC.Types.Target
import GHC.Types.PkgQual
+import GHC.Types.Basic
import GHC.Data.Maybe
import GHC.Data.OsPath (OsPath)
@@ -79,9 +80,9 @@ data ModSummary
-- See Note [When source is considered modified] and #9243
ms_hie_date :: Maybe UTCTime,
-- ^ Timestamp of hie file, if we have one
- ms_srcimps :: [(PkgQual, Located ModuleName)], -- FIXME: source imports are never from an external package, why do we allow PkgQual?
+ ms_srcimps :: [Located ModuleName],
-- ^ Source imports of the module
- ms_textual_imps :: [(PkgQual, Located ModuleName)],
+ ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)],
-- ^ Non-source imports of the module from the module *text*
ms_parsed_mod :: Maybe HsParsedModule,
-- ^ The parsed, nonrenamed source, if we have it. This is also
@@ -105,34 +106,36 @@ ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = moduleName . ms_mod
-- | Textual imports, plus plugin imports but not SOURCE imports.
-ms_imps :: ModSummary -> [(PkgQual, Located ModuleName)]
+ms_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)]
ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms
-- | Plugin imports
-ms_plugin_imps :: ModSummary -> [(PkgQual, Located ModuleName)]
-ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms))
+ms_plugin_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)]
+ms_plugin_imps ms = map ((SpliceLevel, NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms))
-- | All of the (possibly) home module imports from the given list that is to
-- say, each of these module names could be a home import if an appropriately
-- named file existed. (This is in contrast to package qualified imports, which
-- are guaranteed not to be home imports.)
-home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)]
-home_imps imps = filter (maybe_home . fst) imps
+home_imps :: [(ImportLevel, PkgQual, Located ModuleName)] -> [(ImportLevel, PkgQual, Located ModuleName)]
+home_imps imps = filter (maybe_home . pq) imps
where maybe_home NoPkgQual = True
maybe_home (ThisPkg _) = True
maybe_home (OtherPkg _) = False
+ pq (_, p, _) = p
+
-- | Like 'ms_home_imps', but for SOURCE imports.
ms_home_srcimps :: ModSummary -> ([Located ModuleName])
-- [] here because source imports can only refer to the current package.
-ms_home_srcimps = map snd . home_imps . ms_srcimps
+ms_home_srcimps = ms_srcimps
-- | All of the (possibly) home module imports from a
-- 'ModSummary'; that is to say, each of these module names
-- could be a home import if an appropriately named file
-- existed. (This is in contrast to package qualified
-- imports, which are guaranteed not to be home imports.)
-ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)])
+ms_home_imps :: ModSummary -> ([(ImportLevel, PkgQual, Located ModuleName)])
ms_home_imps = home_imps . ms_imps
-- The ModLocation contains both the original source filename and the
@@ -173,15 +176,14 @@ ms_mnwib :: ModSummary -> ModuleNameWithIsBoot
ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms)
-- | Returns the dependencies of the ModSummary s.
-msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))])
-msDeps s =
- [ (NoPkgQual, d)
+msDeps :: ModSummary -> ([(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))])
+msDeps s = [ (NormalLevel, NoPkgQual, d) -- Source imports are always NormalLevel
| m <- ms_home_srcimps s
, d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
]
]
- ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))
- | (pkg, m) <- ms_imps s
+ ++ [ (stage, pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))
+ | (stage, pkg, m) <- ms_imps s
]
instance Outputable ModSummary where
diff --git a/compiler/GHC/Unit/Module/Stage.hs b/compiler/GHC/Unit/Module/Stage.hs
new file mode 100644
index 00000000000..0ad63fa37dc
--- /dev/null
+++ b/compiler/GHC/Unit/Module/Stage.hs
@@ -0,0 +1,85 @@
+module GHC.Unit.Module.Stage ( ModuleStage(..)
+ , allStages
+ , nowAndFutureStages
+ , onlyFutureStages
+ , minStage
+ , maxStage
+ , zeroStage
+ , decModuleStage
+ , incModuleStage
+ ) where
+
+import GHC.Prelude
+import GHC.Utils.Outputable
+
+{- Note [Stage vs Level]
+~~~~~~~~~~~~~~~~~~~~~~~~
+
+Modules are compiled at a specific stage. Levels within a module are interpreted
+as offsets to the specific stage at which the module is being compiled.
+
+* A **level** is a typechecking concept. The type checker performs level checking
+ to ensure that the evaluation can proceed in a well-staged manner.
+* A **stage** is an operational construct. The execution of the program happens
+ in stages.
+
+GHC at the moment knows about two stages, a module is either compiled for
+compile time (*C*) or runtime (*R*), with *C* before *R*. Then:
+
+* The main module is compiled for `R`.
+
+* A normal import does not shift the stage at which the dependent module is required.
+
+* If a module `M` splice imports module `A`, then compiling `M` at stage
+ *R* requires compiling module `A` at stage *C*.
+
+* If a module `N` quote imports module `B`, then compiling `N` at stage
+ *C* requires compiling module `B` at stage *R*.
+
+The compiler can then choose appropiately how modules needed at `C` are compiled
+and how modules needed at `R` are compiled.
+
+For example:
+
+* In `-fno-code` mode, `C` modules may be compiled in dynamic way, but `R` modules
+ are not compiled at all.
+* When using a profiled GHC. `C` modules must be compiled in profiled way but `R` modules
+ will be compiled in static way.
+
+Further structure as needed by cross-compilation settings may require more stages.
+
+-}
+
+-- The order of these constructors is important for definitions such as
+-- 'futureStages'.
+data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded)
+
+allStages :: [ModuleStage]
+allStages = [minBound .. maxBound]
+
+nowAndFutureStages :: ModuleStage -> [ModuleStage]
+nowAndFutureStages cur_st = [cur_st .. ]
+
+onlyFutureStages :: ModuleStage -> [ModuleStage]
+onlyFutureStages cur_st | cur_st == maxBound = []
+onlyFutureStages cur_st = [succ cur_st .. ]
+
+minStage :: ModuleStage
+minStage = minBound
+
+maxStage :: ModuleStage
+maxStage = maxBound
+
+instance Outputable ModuleStage where
+ ppr CompileStage = text "compile"
+ ppr RunStage = text "run"
+
+zeroStage :: ModuleStage
+zeroStage = RunStage
+
+decModuleStage, incModuleStage :: ModuleStage -> ModuleStage
+incModuleStage RunStage = RunStage
+incModuleStage CompileStage = RunStage
+
+decModuleStage RunStage = CompileStage
+decModuleStage CompileStage = RunStage
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index 4554faa9e2f..5d3f43063b0 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface
+{-# OPTIONS_GHC -Wno-orphans #-} -- instance Data ModuleName
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
@@ -117,6 +117,7 @@ data GenModule unit = Module
}
deriving (Eq,Ord,Data,Functor)
+-- TODO: should be moved back into Language.Haskell.Syntax.Module.Name
instance Data ModuleName where
-- don't traverse?
toConstr _ = abstractConstr "ModuleName"
@@ -684,17 +685,6 @@ the WiringMap, and that's why 'wiredInUnitIds' no longer includes
-- modules in opposition to boot interfaces. Instead, one should use
-- 'DriverPhases.HscSource'. See Note [HscSource types].
-instance Binary IsBootInterface where
- put_ bh ib = put_ bh $
- case ib of
- NotBoot -> False
- IsBoot -> True
- get bh = do
- b <- get bh
- return $ case b of
- False -> NotBoot
- True -> IsBoot
-
-- | This data type just pairs a value 'mod' with an IsBootInterface flag. In
-- practice, 'mod' is usually a @Module@ or @ModuleName@'.
data GenWithIsBoot mod = GWIB
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 30d89de7334..97a2b1d1f5d 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -2,6 +2,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
@@ -75,6 +77,9 @@ module GHC.Utils.Binary
lazyGetMaybe,
lazyPutMaybe,
+ -- * EnumBinary
+ EnumBinary(..),
+
-- * User data
ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData,
WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData,
@@ -115,6 +120,7 @@ module GHC.Utils.Binary
import GHC.Prelude
import Language.Haskell.Syntax.Module.Name (ModuleName(..))
+import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
@@ -1064,6 +1070,22 @@ instance Binary JoinPointHood where
0 -> return NotJoinPoint
_ -> do { ar <- get bh; return (JoinPoint ar) }
+newtype EnumBinary a = EnumBinary { unEnumBinary :: a }
+instance Enum a => Binary (EnumBinary a) where
+ put_ bh (EnumBinary x) = put_ bh (fromEnum x)
+ get bh = do x <- get bh
+ return $ EnumBinary (toEnum x)
+
+
+instance Binary IsBootInterface where
+ put_ bh ib = put_ bh (case ib of
+ IsBoot -> True
+ NotBoot -> False)
+ get bh = do x <- get bh
+ return $ case x of
+ True -> IsBoot
+ False -> NotBoot
+
{-
Finally - a reasonable portable Integer instance.
@@ -2140,4 +2162,4 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
- = rnf fp `seq` rnf mflags `seq` ()
\ No newline at end of file
+ = rnf fp `seq` rnf mflags `seq` ()
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 668bb8f7015..770b4c980ce 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -33,7 +33,7 @@ module GHC.Utils.Outputable (
docToSDoc,
interppSP, interpp'SP, interpp'SP',
pprQuotedList, pprWithCommas, pprWithSemis,
- unquotedListWith,
+ unquotedListWith, pprUnquotedSet,
quotedListWithOr, quotedListWithNor, quotedListWithAnd,
pprWithBars,
spaceIfSingleQuote,
@@ -51,7 +51,7 @@ module GHC.Utils.Outputable (
cat, fcat,
hang, hangNotEmpty, punctuate, punctuateFinal,
ppWhen, ppUnless, ppWhenOption, ppUnlessOption,
- speakNth, speakN, speakNOf, plural, singular,
+ speakNth, speakN, speakNOf, plural, singular, pluralSet,
isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,
itOrThey,
unicodeSyntax,
@@ -1080,6 +1080,7 @@ instance Outputable Extension where
instance Outputable ModuleName where
ppr = pprModuleName
+
pprModuleName :: IsLine doc => ModuleName -> doc
pprModuleName (ModuleName nm) =
docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm)
@@ -1436,6 +1437,15 @@ interpp'SP' f xs = sep (punctuate comma (map f xs))
pprQuotedList :: Outputable a => [a] -> SDoc
pprQuotedList = quotedList . map ppr
+
+pprUnquotedSet :: Outputable a => Set.Set a -> SDoc
+pprUnquotedSet set =
+ case Set.toList set of
+ [] -> braces empty
+ [x] -> ppr x
+ xs -> braces (fsep (punctuate comma (map ppr xs)))
+
+
quotedList :: [SDoc] -> SDoc
quotedList xs = fsep (punctuate comma (map quotes xs))
@@ -1540,6 +1550,10 @@ plural :: [a] -> SDoc
plural [_] = empty -- a bit frightening, but there you are
plural _ = char 's'
+-- | Like 'plural', but for sets.
+pluralSet :: Set.Set a -> SDoc
+pluralSet set = plural (Set.toList set)
+
-- | Determines the singular verb suffix appropriate for the length of a list:
--
-- > singular [] = empty
diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs b/compiler/Language/Haskell/Syntax/ImpExp.hs
index a929676f813..e1e012a096c 100644
--- a/compiler/Language/Haskell/Syntax/ImpExp.hs
+++ b/compiler/Language/Haskell/Syntax/ImpExp.hs
@@ -1,13 +1,12 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
-module Language.Haskell.Syntax.ImpExp where
+module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Module.Name
+import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) )
import Data.Eq (Eq)
-import Data.Ord (Ord)
-import Text.Show (Show)
import Data.Data (Data)
import Data.Bool (Bool)
import Data.Maybe (Maybe)
@@ -15,7 +14,6 @@ import Data.String (String)
import Data.Int (Int)
import Control.DeepSeq
-
import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST
{-
@@ -38,15 +36,13 @@ data ImportDeclQualifiedStyle
| NotQualified -- ^ Not qualified.
deriving (Eq, Data)
--- | Indicates whether a module name is referring to a boot interface (hs-boot
--- file) or regular module (hs file). We need to treat boot modules specially
--- when building compilation graphs, since they break cycles. Regular source
--- files and signature files are treated equivalently.
-data IsBootInterface = NotBoot | IsBoot
- deriving (Eq, Ord, Show, Data)
+data ImportDeclLevelStyle
+ = LevelStylePre ImportDeclLevel -- ^ 'splice' or 'quote' appears in prepositive position.
+ | LevelStylePost ImportDeclLevel -- ^ 'splice' or 'quote' appears in postpositive position.
+ | NotLevelled -- ^ Not levelled.
+ deriving (Eq, Data)
-instance NFData IsBootInterface where
- rnf = rwhnf
+data ImportDeclLevel = ImportDeclQuote | ImportDeclSplice deriving (Eq, Data)
-- | Import Declaration
--
@@ -57,6 +53,7 @@ data ImportDecl pass
ideclName :: XRec pass ModuleName, -- ^ Module name.
ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier.
ideclSource :: IsBootInterface, -- ^ IsBoot \<=> {-\# SOURCE \#-} import
+ ideclLevelSpec :: ImportDeclLevelStyle,
ideclSafe :: Bool, -- ^ True => safe import
ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.
ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module
diff --git a/compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs b/compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs
new file mode 100644
index 00000000000..020dc2ccc20
--- /dev/null
+++ b/compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs
@@ -0,0 +1,15 @@
+module Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) where
+
+import Prelude (Eq, Ord, Show)
+import Data.Data (Data)
+import Control.DeepSeq (NFData(..), rwhnf)
+
+-- | Indicates whether a module name is referring to a boot interface (hs-boot
+-- file) or regular module (hs file). We need to treat boot modules specially
+-- when building compilation graphs, since they break cycles. Regular source
+-- files and signature files are treated equivalently.
+data IsBootInterface = NotBoot | IsBoot
+ deriving (Eq, Ord, Show, Data)
+
+instance NFData IsBootInterface where
+ rnf = rwhnf
\ No newline at end of file
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index b0c9edb79cb..eb32425accb 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -903,6 +903,7 @@ Library
GHC.Types.HpcInfo
GHC.Types.Id
GHC.Types.IPE
+ GHC.Types.ThLevelIndex
GHC.Types.Id.Info
GHC.Types.Id.Make
GHC.Types.Literal
@@ -957,6 +958,7 @@ Library
GHC.Unit.Module.Env
GHC.Unit.Module.Graph
GHC.Unit.Module.ModNodeKey
+ GHC.Unit.Module.Stage
GHC.Unit.Module.Imported
GHC.Unit.Module.Location
GHC.Unit.Module.ModDetails
@@ -1017,6 +1019,7 @@ Library
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
Language.Haskell.Syntax.ImpExp
+ Language.Haskell.Syntax.ImpExp.IsBoot
Language.Haskell.Syntax.Lit
Language.Haskell.Syntax.Module.Name
Language.Haskell.Syntax.Pat
diff --git a/docs/users_guide/exts/control.rst b/docs/users_guide/exts/control.rst
index b5b8383a079..bb7d4e2d80e 100644
--- a/docs/users_guide/exts/control.rst
+++ b/docs/users_guide/exts/control.rst
@@ -120,6 +120,7 @@ Similarly, language extensions can be controlled (either enabled or disabled):
* :extension:`TypeApplications`
* :extension:`TypeOperators`
* :extension:`TypeSynonymInstances`
+ * :extension:`ImplicitStagePersistence`
.. extension:: GHC2021
:shortdesc: Use GHC’s set of default language extensions from 2021
@@ -189,6 +190,7 @@ Similarly, language extensions can be controlled (either enabled or disabled):
* :extension:`TypeOperators`
* :extension:`TypeSynonymInstances`
* :extension:`NoExplicitNamespaces <ExplicitNamespaces>`
+ * :extension:`ImplicitStagePersistence`
.. extension:: Haskell2010
@@ -216,6 +218,7 @@ Similarly, language extensions can be controlled (either enabled or disabled):
* :extension:`RelaxedPolyRec`
* :extension:`StarIsType`
* :extension:`TraditionalRecordSyntax`
+ * :extension:`ImplicitStagePersistence`
.. extension:: Haskell98
@@ -240,6 +243,7 @@ Similarly, language extensions can be controlled (either enabled or disabled):
* :extension:`NondecreasingIndentation`
* :extension:`StarIsType`
* :extension:`TraditionalRecordSyntax`
+ * :extension:`ImplicitStagePersistence`
diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst
index b8153909990..16a41bbde84 100644
--- a/docs/users_guide/exts/template_haskell.rst
+++ b/docs/users_guide/exts/template_haskell.rst
@@ -6,24 +6,11 @@ Template Haskell
Template Haskell allows you to do compile-time meta-programming in
Haskell. The background to the main technical innovations is discussed
in "`Template Meta-programming for
-Haskell <https://research.microsoft.com/~simonpj/papers/meta-haskell/>`__"
+Haskell <https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/meta-haskell.pdf>`__"
(Proc Haskell Workshop 2002).
-
-The `Template Haskell <https://www.haskell.org/haskellwiki/Template_Haskell>`__
-page on the GHC Wiki has a wealth of information. You may also consult the
-Haddock reference documentation :th-ref:`Language.Haskell.TH.`.
-Many changes to the original
-design are described in `Notes on Template Haskell version
-2 <https://www.haskell.org/ghc/docs/papers/th2.ps>`__.
-Not all of these changes are in GHC, however.
-
The first example from that paper is set out below (:ref:`th-example`)
as a worked example to help get you started.
-The documentation here describes the realisation of Template Haskell in
-GHC. It is not detailed enough to understand Template Haskell; see the
-`Wiki page <https://haskell.org/haskellwiki/Template_Haskell>`__.
-
.. _th-syntax:
Syntax
@@ -48,14 +35,30 @@ Template Haskell has the following new syntactic constructions. You need to use
the extension :extension:`TemplateHaskell` to switch these syntactic extensions on.
Alternatively, the :extension:`TemplateHaskellQuotes` extension can be used to
enable the quotation subset of Template Haskell (i.e. without top-level splices).
-The :extension:`TemplateHaskellQuotes` extension is considered safe under
-:ref:`safe-haskell` while :extension:`TemplateHaskell` is not.
+
+- A expression quotation is written in Oxford brackets, thus:
+
+ - ``[| ... |]``, or ``[e| ... |]``, where the "..." is an
+ expression; the quotation has type ``Quote m => m Exp``.
+
+ - ``[d| ... |]``, where the "..." is a list of top-level
+ declarations; the quotation has type ``Quote m => m [Dec]``.
+
+ - ``[t| ... |]``, where the "..." is a type; the quotation has type
+ ``Quote m => m Type``.
+
+ - ``[p| ... |]``, where the "..." is a pattern; the quotation has
+ type ``Quote m => m Pat``.
+
+ The ``Quote`` type class (:th-ref:`Language.Haskell.TH.Syntax.Quote`) is
+ the minimal interface necessary to implement the desugaring of quotations.
+ The ``Q`` monad is an instance of ``Quote`` but contains many more
+ operations which are not needed for defining quotations.
+
+ See :ref:`pts-where` for using partial type signatures in quotations.
- A splice is written ``$x``, where ``x`` is an arbitrary expression.
There must be no space between the "$" and the expression.
- This use of ``$`` overrides its meaning as an infix operator, just as ``M.x``
- overrides the meaning of ``.`` as an infix operator. If you want the
- infix operator, put spaces around it.
A top-level splice can occur in place of
@@ -68,35 +71,17 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
- a list of declarations at top level; the spliced expression must
have type ``Q [Dec]``
- Inside a splice you can only call functions defined in imported
- modules, not functions defined elsewhere in the same module. Note
- that declaration splices are not allowed anywhere except at top level
+ Note that declaration splices are not allowed anywhere except at top level
(outside any other declarations).
The ``Q`` monad is a monad defined in :th-ref:`Language.Haskell.TH.Syntax.` which
supports several useful operations during code generation such as reporting
errors or looking up identifiers in the environment.
-- A expression quotation is written in Oxford brackets, thus:
-
- - ``[| ... |]``, or ``[e| ... |]``, where the "..." is an
- expression; the quotation has type ``Quote m => m Exp``.
-
- - ``[d| ... |]``, where the "..." is a list of top-level
- declarations; the quotation has type ``Quote m => m [Dec]``.
-
- - ``[t| ... |]``, where the "..." is a type; the quotation has type
- ``Quote m => m Type``.
-
- - ``[p| ... |]``, where the "..." is a pattern; the quotation has
- type ``Quote m => m Pat``.
-
- The ``Quote`` type class (:th-ref:`Language.Haskell.TH.Syntax.Quote`) is
- the minimal interface necessary to implement the desugaring of quotations.
- The ``Q`` monad is an instance of ``Quote`` but contains many more
- operations which are not needed for defining quotations.
+ This use of ``$`` overrides its meaning as an infix operator, just as ``M.x``
+ overrides the meaning of ``.`` as an infix operator. If you want the
+ infix operator, put spaces around it.
- See :ref:`pts-where` for using partial type signatures in quotations.
- Splices can be nested inside quotation brackets. For example the fragment
representing ``1 + 2`` can be constructed using nested splices::
@@ -108,24 +93,13 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
plusC = [| $oneC + $twoC |]
-- The precise type of a quotation depends on the types of the nested splices inside it::
-
- -- Add a redundant constraint to demonstrate that constraints on the
- -- monad used to build the representation are propagated when using nested
- -- splices.
- f :: (Quote m, C m) => m Exp
- f = [| 5 | ]
-
- -- f is used in a nested splice so the constraint on f, namely C, is propagated
- -- to a constraint on the whole representation.
- g :: (Quote m, C m) => m Exp
- g = [| $f + $f |]
-
- Remember, a top-level splice still requires its argument to be of type ``Q Exp``.
- So then splicing in ``g`` will cause ``m`` to be instantiated to ``Q``::
+- A *typed* expression quotation is written as ``[|| ... ||]``, or
+ ``[e|| ... ||]``, where the "..." is an expression; if the "..."
+ expression has type ``a``, then the quotation has type
+ ``Quote m => Code m a``.
- h :: Int
- h = $(g) -- m ~ Q
+ It is possible to extract a value of type ``m Exp`` from ``Code m a``
+ using the ``unTypeCode :: Code m a -> m Exp`` function.
- A *typed* expression splice is written ``$$x``, where ``x`` is
is an arbitrary expression.
@@ -136,13 +110,6 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
**NOTE**: Currently typed splices may inhibit the unused identifier warning for
identifiers in scope. See :ghc-ticket:`16524`.
-- A *typed* expression quotation is written as ``[|| ... ||]``, or
- ``[e|| ... ||]``, where the "..." is an expression; if the "..."
- expression has type ``a``, then the quotation has type
- ``Quote m => Code m a``.
-
- It is possible to extract a value of type ``m Exp`` from ``Code m a``
- using the ``unTypeCode :: Code m a -> m Exp`` function.
- A quasi-quotation can appear in a pattern, type, expression, or
declaration context and is also written in Oxford brackets:
@@ -174,30 +141,111 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
expressions, patterns, declarations etc. They may also be given as an
argument to the ``reify`` function.
-- It is possible for a splice to expand to an expression that contain
- names which are not in scope at the site of the splice. As an
- example, consider the following code: ::
+- The precise type of a quotation depends on the types of the nested splices inside it::
- module Bar where
+ -- Add a redundant constraint to demonstrate that constraints on the
+ -- monad used to build the representation are propagated when using nested
+ -- splices.
+ f :: (Quote m, C m) => m Exp
+ f = [| 5 | ]
- import Language.Haskell.TH
+ -- f is used in a nested splice so the constraint on f, namely C, is propagated
+ -- to a constraint on the whole representation.
+ g :: (Quote m, C m) => m Exp
+ g = [| $f + $f |]
+
+ Remember, a top-level splice still requires its argument to be of type ``Q Exp``.
+ So then splicing in ``g`` will cause ``m`` to be instantiated to ``Q``::
+
+ h :: Int
+ h = $(g) -- m ~ Q
- add1 :: Quote m => Int -> m Exp
- add1 x = [| x + 1 |]
+Levels and Stages
+------------------
- Now consider a splice using ``add1`` in a separate
- module: ::
+Template Haskell executes code at both compile time and runtime, which requires
+understanding two key concepts: **levels** and **stages**.
- module Foo where
+**Levels** are a concept the typechecker uses to ensure that code is well-staged -
+that is, the compiler can execute compile-time operations before runtime operations.
+**Stages** are the actual moments when code is compiled and executed. Levels are a semantic
+concept used by the typechecker, whilst stages are operational, a property of evaluation.
- import Bar
+Understanding Levels
+~~~~~~~~~~~~~~~~~~~~
+
+Every expression in a program exists at a specific integer level:
+
+* Level 0: Normal top-level declarations in a module
+* Level -1: Code inside a top-level splice (code that runs at compile time)
+* Level 1: Code inside a quotation (code that is quoted for runtime)
+
+The level changes when entering quotes and splices:
+
+* Inside a quote ``[| e |]``, the level increases by 1
+* Inside a splice ``$( e )``, the level decreases by 1
+
+Thus, the level can be calculated as the number of surrounding quotes minus the
+number of surrounding splices. For example:
+
+.. code-block:: haskell
+
+ -- foo is at level 0
+ foo = $(let
+ -- bar is at level -1
+ bar = $(let
+ -- baz is at level -2
+ baz = [|
+ -- qux is at level -1
+ qux = [|
+ -- quux is at level 0
+ quux = [|
+ -- quuz is at level 1
+ quuz = 0
+ |]
+ |]
+ |]
+ in baz)
+ in bar)
+
+Top-level splices (which define where compile-time evaluation happens) are
+characterized by having their body at a negative level.
+
+* Top-level declarations introduce variables at level 1.
+* Imports introduce variables at level 1.
+* Local variables are introduced at the level of their expression. For example,
+ the ``x`` in [| let x = 0 in ... |] is at level 2.
+
+
+Cross-Stage Persistence
+~~~~~~~~~~~~~~~~~~~~~~~
+
+In normal Template Haskell, **cross-stage persistence (CSP)** allows identifiers
+to be used at levels different from where they were defined. There are two
+mechanisms for this:
+
+1. **Path-based persistence**: This allows a global definition at one level to be
+ used at a different level in two cases:
+
+ * Any global identifier can be used at a later level (i.e. inside a quotation).
+ * An imported identifier can be used at an earlier level (i.e. in a splice)
+
+ The :extension:`ImplicitStagePersistence` extension controls whether
+ path-based persistence is enabled. It is enabled by default in all current
+ language editions.
+
+2. **Serialisation-based persistence**: This allows locally-bound variables to be
+ used at higher levels through the ``Lift`` typeclass:
+
+ .. code-block:: haskell
- two :: Int
- two = $(add1 1)
+ tardy x = [| x |] -- This is elaborated to [| $(lift x) |]
- Template Haskell cannot know what the argument to ``add1`` will be at the
- function's definition site, so a lifting mechanism is used to promote
- ``x`` into a value of type ``Quote m => m Exp``. This functionality is exposed to the
+ When the compiler sees a level error where a variable used one level higher than
+ it is defined, it will automatically insert a ``lift`` to serialise the variable
+ at the required level.
+
+ This functionality is exposed to the
user as the ``Lift`` typeclass in the ``Language.Haskell.TH.Syntax``
module. If a type has a ``Lift`` instance, then any of its values can be
lifted to a Template Haskell expression: ::
@@ -206,21 +254,229 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
lift :: Quote m => t -> m Exp
liftTyped :: Quote m => t -> Code m t
- In general, if GHC sees an expression within Oxford brackets (e.g., ``[|
- foo bar |]``, then GHC looks up each name within the brackets. If a name
- is global (e.g., suppose ``foo`` comes from an import or a top-level
- declaration), then the fully qualified name is used directly in the
- quotation. If the name is local (e.g., suppose ``bar`` is bound locally in
- the function definition ``mkFoo bar = [| foo bar |]``), then GHC uses
- ``lift`` on it (so GHC pretends ``[| foo bar |]`` actually contains ``[|
- foo $(lift bar) |]``). Local names, which are not in scope at splice
- locations, are actually evaluated when the quotation is processed.
-
- The ``template-haskell`` library provides ``Lift`` instances for many
- common data types. Furthermore, it is possible to derive ``Lift``
- instances automatically by using the :extension:`DeriveLift` language extension.
+
+ ``Lift`` is defined for most built-in types and can be
+ derived using the :extension:`DeriveLift` extension.
See :ref:`deriving-lift` for more information.
+Path-based persistence explains why this code works:
+
+.. code-block:: haskell
+
+ module M where
+
+ suc :: Int -> Int
+ suc = (+1)
+
+ one :: Q Exp
+ one = [| \x -> suc x |] -- suc is used at level 1, defined at level 0
+
+ two = $(one) -- one is used at level -1, defined at level 0
+
+With :extension:`ExplicitLevelImports` and :extension:`NoImplicitStagePersistence`,
+path-based persistence is disabled, requiring explicit indication of which
+identifiers can be used at which levels.
+
+Stages and Compilation
+~~~~~~~~~~~~~~~~~~~~~~
+
+While levels are a typechecker concept, **stages** refer to the actual moments
+when modules are compiled and executed:
+
+* Stage C (Compile time): Code that runs during compilation
+* Stage R (Runtime): Code that runs when the compiled program is executed
+
+The compiler may need to compile code differently depending on the stage.
+For example, if you are using :ghc-flag:`-fno-code`, no code is needed for the R stage
+but code generation will be needed for the C stage. If your compiler is dynamically
+linked then the C stage code will need to be dynamically linked, but the R stage
+may be statically linked.
+
+The cross-stage persistence rules admitted by a language arise from assumptions
+made about the stage structure. For GHC, with :extension:`ImplicitStagePersistence`,
+it must be assumed that a module will be available at all stages. This is a strong
+requirement.
+
+Declaration Groups
+------------------
+
+Top-level declaration splices break up a source file into
+*declaration groups*. A *declaration group* is the group of
+declarations created by a top-level declaration splice, plus those
+following it, down to but not including the next top-level
+declaration splice. N.B. only top-level splices delimit declaration
+groups, not expression splices. The first declaration group in a module
+includes all top-level definitions down to but not including the first
+top-level declaration splice.
+
+Each group is compiled just like a separately compiled module. That is:
+
+- Later groups can "see" declarations, and instance declarations, from
+ earlier groups;
+
+- But earlier groups cannot "see" declarations, or instance declarations,
+ from later groups.
+
+Each declaration group is mutually recursive only within the group.
+Declaration groups can refer to definitions within previous groups,
+but not later ones.
+
+Accordingly, the type environment seen by ``reify`` includes all the
+top-level declarations up to the end of the immediately preceding
+declaration group, but no more.
+
+Unlike normal declaration splices, declaration quasiquoters do not
+cause a break. These quasiquoters are expanded before the rest of the
+declaration group is processed, and the declarations they generate
+are merged into the surrounding declaration group. Consequently, the
+type environment seen by ``reify`` from a declaration quasiquoter
+will not include anything from the quasiquoter's declaration group.
+
+Concretely, consider the following code ::
+
+ module M where
+
+ import ...
+
+ f x = x
+
+ $(th1 4)
+
+ h y = k y y $(blah1)
+
+ [qq|blah|]
+
+ k x y z = x + y + z
+
+ $(th2 10)
+
+ w z = $(blah2)
+
+In this example, a ``reify`` inside...
+
+1. The splice ``$(th1 ...)`` would see the definition of ``f`` - the
+ splice is top-level and thus all definitions in the previous
+ declaration group are visible (that is, all definitions in the module
+ up-to, but not including, the splice itself).
+
+2. The splice ``$(blah1)`` cannot refer to the function ``w`` - ``w`` is
+ part of a later declaration group, and thus invisible, similarly,
+ ``$(blah1)`` cannot see the definition of ``h`` (since it is part of
+ the same declaration group as ``$(blah1)``. However, the splice
+ ``$(blah1)`` can see the definition of ``f`` (since it is in the
+ immediately preceding declaration group).
+
+3. The splice ``$(th2 ...)`` would see the definition of ``f``, all the
+ bindings created by ``$(th1 ...)``, the definition of ``h`` and all
+ bindings created by ``[qq|blah|]`` (they are all in previous
+ declaration groups).
+
+4. The body of ``h`` *can* refer to the function ``k`` appearing on the
+ other side of the declaration quasiquoter, as quasiquoters do not
+ cause a declaration group to be broken up.
+
+5. The ``qq`` quasiquoter would be able to see the definition of ``f``
+ from the preceding declaration group, but not the definitions of
+ ``h`` or ``k``, or any definitions from subsequent declaration
+ groups.
+
+6. The splice ``$(blah2)`` would see the same definitions as the splice
+ ``$(th2 ...)`` (but *not* any bindings it creates).
+
+Note that since an expression splice is unable to refer to declarations
+in the same declaration group, we can introduce a top-level (empty)
+splice to break up the declaration group ::
+
+ module M where
+
+ data D = C1 | C2
+
+ f1 = $(th1 ...)
+
+ $(return [])
+
+ f2 = $(th2 ...)
+
+Here
+
+1. The splice ``$(th1 ...)`` *cannot* refer to ``D`` - it is in the same
+ declaration group.
+2. The declaration group containing ``D`` is terminated by the empty
+ top-level declaration splice ``$(return [])`` (recall, ``Q`` is a
+ Monad, so we may simply ``return`` the empty list of declarations).
+3. Since the declaration group containing ``D`` is in the previous
+ declaration group, the splice ``$(th2 ...)`` *can* refer to ``D``.
+
+Note that in some cases, the presence or absence of top-level declaration
+splices can affect the *runtime* behavior of the surrounding code, because
+the resolution of instances may differ depending on their visiblity. One
+case where this arises is with
+:ref:`incoherent instances <instance-overlap>` ::
+
+ module Main where
+
+ main :: IO ()
+ main = do
+ let i :: Int
+ i = 42
+ putStrLn (m1 i)
+ putStrLn (m2 i)
+
+ class C1 a where
+ m1 :: a -> String
+
+ instance {-# INCOHERENT #-} C1 a where
+ m1 _ = "C1 incoherent"
+
+ instance C1 Int where
+ m1 = show
+
+ class C2 a where
+ m2 :: a -> String
+
+ instance {-# INCOHERENT #-} C2 a where
+ m2 _ = "C2 incoherent"
+
+ $(return [])
+
+ instance C2 Int where
+ m2 = show
+
+Here, ``C1`` and ``C2`` are the same classes with nearly identical
+instances. The only significant differences between ``C1`` and ``C2``, aside
+from the minor name change, is that all of ``C1``'s instances are defined
+within the same declaration group, whereas the ``C2 Int`` instance is put in
+a separate declaration group from the incoherent ``C2 a`` instance. This has
+an impact on the runtime behavior of the ``main`` function ::
+
+ $ runghc Main.hs
+ 42
+ C2 incoherent
+
+Note that ``m1 i`` returns ``"42"``, but ``m2 i`` returns
+``"C2 incoherent"``. When each of these expressions are typechecked, GHC
+must figure out which ``C1 Int`` and ``C2 Int`` instances to use:
+
+1. When resolving the ``C1 Int`` instance, GHC discovers two possible
+ instances in the same declaration group: the incoherent ``C1 a`` instance
+ and the non-incoherent ``C1 Int`` instance. According to the instance
+ search rules described in :ref:`instance-overlap`, because there is
+ exactly one non-incoherent instance to pick, GHC will choose the
+ ``C1 Int`` instance. As a result, ``m1 i`` will be equivalent to
+ ``show i`` (i.e., ``"42"``).
+2. When resolving the ``C2 Int`` instance, GHC only discovers one instance
+ in the same declaration group: the incoherent ``C2 a`` instance. Note
+ that GHC does *not* see the ``C2 Int`` instance, as that is in a later
+ declaration group that is made separate by the intervening declaration
+ splice. As a result, GHC will choose the ``C2 a`` instance, making
+ ``m2 i`` equivalent to ``"C2 incoherent"``.
+
+Miscellaneous other features
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In this section the other features and issues of Template Haskell are
+discussed.
+
- You may omit the ``$(...)`` in a top-level declaration splice. Simply
writing an expression (rather than a declaration) implies a splice.
For example, you can write ::
@@ -275,199 +531,224 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
f :: Int -> Int -> Int
f n = \ [haskell|y|] -> y+n
-- Top-level declaration splices break up a source file into
- *declaration groups*. A *declaration group* is the group of
- declarations created by a top-level declaration splice, plus those
- following it, down to but not including the next top-level
- declaration splice. N.B. only top-level splices delimit declaration
- groups, not expression splices. The first declaration group in a module
- includes all top-level definitions down to but not including the first
- top-level declaration splice.
- Each group is compiled just like a separately compiled module. That is:
- - Later groups can "see" declarations, and instance declarations, from
- earlier groups;
+- The :extension:`TemplateHaskellQuotes` extension is considered safe under
+ :ref:`safe-haskell` while :extension:`TemplateHaskell` is not.
+
+- Expression quotations accept most Haskell language constructs.
+ However, there are some GHC-specific extensions which expression
+ quotations currently do not support, including
+
+ - Type holes in typed splices (see :ghc-ticket:`10945` and
+ :ghc-ticket:`10946`)
+
+(Compared to the original paper, there are many differences of detail.
+The syntax for a declaration splice uses "``$``" not "``splice``". The type of
+the enclosed expression must be ``Quote m => m [Dec]``, not ``[Q Dec]``. Typed expression
+splices and quotations are supported.)
+
+.. ghc-flag:: -fenable-th-splice-warnings
+ :shortdesc: Generate warnings for Template Haskell splices
+ :type: dynamic
+ :reverse: -fno-enable-th-splice-warnings
+ :category: warnings
- - But earlier groups cannot "see" declarations, or instance declarations,
- from later groups.
+ Template Haskell splices won't be checked for warnings, because the code
+ causing the warning might originate from a third-party library and possibly
+ was not written by the user. If you want to have warnings for splices
+ anyway, pass :ghc-flag:`-fenable-th-splice-warnings`.
- Each declaration group is mutually recursive only within the group.
- Declaration groups can refer to definitions within previous groups,
- but not later ones.
+Explicit Level Imports
+----------------------
- Accordingly, the type environment seen by ``reify`` includes all the
- top-level declarations up to the end of the immediately preceding
- declaration group, but no more.
+The :extension:`ExplicitLevelImports` extension, along with
+:extension:`ImplicitStagePersistence`, gives programmers fine-grained control
+over which modules are needed at each stage of execution.
- Unlike normal declaration splices, declaration quasiquoters do not
- cause a break. These quasiquoters are expanded before the rest of the
- declaration group is processed, and the declarations they generate
- are merged into the surrounding declaration group. Consequently, the
- type environment seen by ``reify`` from a declaration quasiquoter
- will not include anything from the quasiquoter's declaration group.
+For a detailed description of the extension, see the paper
+`Explicit Level Imports <https://mpickering.github.io/papers/explicit-level-imports.pdf>`_.
- Concretely, consider the following code ::
+.. extension:: ExplicitLevelImports
+ :shortdesc: Allow explicit level imports in Template Haskell.
- module M where
+ :implies: :extension:`NoImplicitStagePersistence`
+ :since: 9.14.1
- import ...
+ Enable explicit level imports for Template Haskell, allowing programmers to
+ specify which modules are needed at which level.
- f x = x
+ This introduces the ``splice`` and ``quote`` import modifiers which allow
+ a user to precisely express the level of identifiers introduced by an import.
- $(th1 4)
+.. extension:: ImplicitStagePersistence
+ :shortdesc: Allow identifiers to be used at different levels from where they are defined.
- h y = k y y $(blah1)
+ :default: on
+ :since: 9.14.1
- [qq|blah|]
+ Allow identifiers to be used at different levels than where they're defined,
+ using path-based persistence.
- k x y z = x + y + z
+Syntax and Usage
+~~~~~~~~~~~~~~~~
- $(th2 10)
+:extension:`ExplicitLevelImports` adds two new import modifiers:
- w z = $(blah2)
+* ``import splice M (...)`` - imports identifiers at level -1 (for use in splices)
+* ``import quote M (...)`` - imports identifiers at level 1 (for use in quotations)
+* ``import M (...)`` - imports identifiers at level 0 (normal code)
- In this example, a ``reify`` inside...
+The syntax supports both options for placement of the level keywords:
- 1. The splice ``$(th1 ...)`` would see the definition of ``f`` - the
- splice is top-level and thus all definitions in the previous
- declaration group are visible (that is, all definitions in the module
- up-to, but not including, the splice itself).
+.. code-block:: haskell
- 2. The splice ``$(blah1)`` cannot refer to the function ``w`` - ``w`` is
- part of a later declaration group, and thus invisible, similarly,
- ``$(blah1)`` cannot see the definition of ``h`` (since it is part of
- the same declaration group as ``$(blah1)``. However, the splice
- ``$(blah1)`` can see the definition of ``f`` (since it is in the
- immediately preceding declaration group).
+ import splice M -- before the module name
+ import M splice -- after the module name
+ import splice qualified M as MB -- with qualified
+ import splice M qualified as MB -- with -XImportQualifiedPost
+ import M splice qualified as MB -- with -XImportQualifiedPost
- 3. The splice ``$(th2 ...)`` would see the definition of ``f``, all the
- bindings created by ``$(th1 ...)``, the definition of ``h`` and all
- bindings created by ``[qq|blah|]`` (they are all in previous
- declaration groups).
+Basic Examples
+~~~~~~~~~~~~~~
- 4. The body of ``h`` *can* refer to the function ``k`` appearing on the
- other side of the declaration quasiquoter, as quasiquoters do not
- cause a declaration group to be broken up.
+Explicit level imports allow you to be more precise about which modules are needed at which level.
- 5. The ``qq`` quasiquoter would be able to see the definition of ``f``
- from the preceding declaration group, but not the definitions of
- ``h`` or ``k``, or any definitions from subsequent declaration
- groups.
+.. code-block:: haskell
- 6. The splice ``$(blah2)`` would see the same definitions as the splice
- ``$(th2 ...)`` (but *not* any bindings it creates).
+ {-# LANGUAGE TemplateHaskell #-}
+ module Main where
- Note that since an expression splice is unable to refer to declarations
- in the same declaration group, we can introduce a top-level (empty)
- splice to break up the declaration group ::
+ import Control.Lens.TH (makeLenses)
+ import OtherModule (someFunction)
- module M where
+ data User = User { _name :: String, _age :: Int }
- data D = C1 | C2
+ $(makeLenses ''User)
- f1 = $(th1 ...)
+ main = print (someFunction (User "John" 30))
- $(return [])
+In this version, both ``Control.Lens.TH`` and ``OtherModule`` are imported
+normally. GHC must compile both modules before it can start type-checking Main,
+because it can't tell in advance which imports might be needed when evaluating
+the ``makeLenses`` splice. Even though only ``makeLenses`` is actually used in
+the splice, GHC must assume that any imported identifier might be needed.
- f2 = $(th2 ...)
+If you use :extension:`ExplicitLevelImports`, you can be more precise about which
+modules are needed at which level. For example, ::
- Here
+.. code-block:: haskell
- 1. The splice ``$(th1 ...)`` *cannot* refer to ``D`` - it is in the same
- declaration group.
- 2. The declaration group containing ``D`` is terminated by the empty
- top-level declaration splice ``$(return [])`` (recall, ``Q`` is a
- Monad, so we may simply ``return`` the empty list of declarations).
- 3. Since the declaration group containing ``D`` is in the previous
- declaration group, the splice ``$(th2 ...)`` *can* refer to ``D``.
+ {-# LANGUAGE TemplateHaskell, ExplicitLevelImports #-}
+ module Main where
- Note that in some cases, the presence or absence of top-level declaration
- splices can affect the *runtime* behavior of the surrounding code, because
- the resolution of instances may differ depending on their visiblity. One
- case where this arises is with
- :ref:`incoherent instances <instance-overlap>` ::
+ import splice Control.Lens.TH (makeLenses)
+ import OtherModule (someFunction)
- module Main where
+ data User = User { _name :: String, _age :: Int }
- main :: IO ()
- main = do
- let i :: Int
- i = 42
- putStrLn (m1 i)
- putStrLn (m2 i)
+ $(makeLenses ''User)
- class C1 a where
- m1 :: a -> String
+ main = print (someFunction (User "John" 30))
- instance {-# INCOHERENT #-} C1 a where
- m1 _ = "C1 incoherent"
+With explicit level imports, we've marked ``Control.Lens.TH`` with the
+``splice`` keyword, which tells GHC that this module is needed at compile-time
+for evaluating splices. This provides GHC with crucial information:
- instance C1 Int where
- m1 = show
+1. ``Control.Lens.TH`` must be compiled to object code before type-checking ``Main``
+2. ``OtherModule`` only needs to be type-checked before ``Main``, with code generation potentially happening in parallel
+3. ``Control.Lens.TH`` won't be needed at runtime (assuming there are no other references to it)
- class C2 a where
- m2 :: a -> String
+This distinction brings several benefits:
- instance {-# INCOHERENT #-} C2 a where
- m2 _ = "C2 incoherent"
+* GHC doesn't need to wait for ``OtherModule`` to be fully compiled before starting on ``Main``
+* ``Control.Lens.TH`` won't be linked into the final executable since it's only needed at compile-time
+* The staging structure of the program is more explicit
- $(return [])
+Another example showing different import levels:
- instance C2 Int where
- m2 = show
+.. code-block:: haskell
- Here, ``C1`` and ``C2`` are the same classes with nearly identical
- instances. The only significant differences between ``C1`` and ``C2``, aside
- from the minor name change, is that all of ``C1``'s instances are defined
- within the same declaration group, whereas the ``C2 Int`` instance is put in
- a separate declaration group from the incoherent ``C2 a`` instance. This has
- an impact on the runtime behavior of the ``main`` function ::
+ {-# LANGUAGE TemplateHaskell, ExplicitLevelImports #-}
+ module Advanced where
- $ runghc Main.hs
- 42
- C2 incoherent
+ import splice A (makeFunction) -- Used in splices (level -1)
+ import B (normalFunction) -- Used in normal code (level 0)
+ import quote C (runtimeValue) -- Used in quotes (level 1)
- Note that ``m1 i`` returns ``"42"``, but ``m2 i`` returns
- ``"C2 incoherent"``. When each of these expressions are typechecked, GHC
- must figure out which ``C1 Int`` and ``C2 Int`` instances to use:
+ -- This generates a function at compile time
+ $(makeFunction "generatedFunction")
- 1. When resolving the ``C1 Int`` instance, GHC discovers two possible
- instances in the same declaration group: the incoherent ``C1 a`` instance
- and the non-incoherent ``C1 Int`` instance. According to the instance
- search rules described in :ref:`instance-overlap`, because there is
- exactly one non-incoherent instance to pick, GHC will choose the
- ``C1 Int`` instance. As a result, ``m1 i`` will be equivalent to
- ``show i`` (i.e., ``"42"``).
- 2. When resolving the ``C2 Int`` instance, GHC only discovers one instance
- in the same declaration group: the incoherent ``C2 a`` instance. Note
- that GHC does *not* see the ``C2 Int`` instance, as that is in a later
- declaration group that is made separate by the intervening declaration
- splice. As a result, GHC will choose the ``C2 a`` instance, making
- ``m2 i`` equivalent to ``"C2 incoherent"``.
+ -- This uses a normal function at runtime
+ result = normalFunction 42
-- Expression quotations accept most Haskell language constructs.
- However, there are some GHC-specific extensions which expression
- quotations currently do not support, including
+ -- This creates a quotation containing code that will use runtimeValue
+ quotation = [| runtimeValue * 2 |]
- - Type holes in typed splices (see :ghc-ticket:`10945` and
- :ghc-ticket:`10946`)
+In this example, we're explicitly marking each import with its intended level:
+* ``A`` provides code that runs at compile time (in splices)
+* ``B`` provides code that runs at normal runtime
+* ``C`` provides values that will be referenced in quoted code
-(Compared to the original paper, there are many differences of detail.
-The syntax for a declaration splice uses "``$``" not "``splice``". The type of
-the enclosed expression must be ``Quote m => m [Dec]``, not ``[Q Dec]``. Typed expression
-splices and quotations are supported.)
+Level Rules and Errors
+~~~~~~~~~~~~~~~~~~~~~~
-.. ghc-flag:: -fenable-th-splice-warnings
- :shortdesc: Generate warnings for Template Haskell splices
- :type: dynamic
- :reverse: -fno-enable-th-splice-warnings
- :category: warnings
+With :extension:`NoImplicitStagePersistence`:
- Template Haskell splices won't be checked for warnings, because the code
- causing the warning might originate from a third-party library and possibly
- was not written by the user. If you want to have warnings for splices
- anyway, pass :ghc-flag:`-fenable-th-splice-warnings`.
+* Functions imported at level 0 can only be used at level 0
+* Functions imported with ``splice`` can only be used inside top-level splices
+* Functions imported with ``quote`` can only be used inside quotes
+
+Errors will occur if you use an identifier at the wrong level:
+
+.. code-block:: haskell
+
+ import splice A (foo) -- foo at level -1
+ import B (bar) -- bar at level 0
+ import quote C (baz) -- baz at level 1
+
+ x = $(foo 42) -- OK: foo used at level -1
+ y = $(bar 42) -- Error: bar imported at level 0 but used at level -1
+ z = [| baz 42 |] -- OK: baz used at level 1
+ w = [| bar 42 |] -- Error: bar imported at level 0 but used at level 1
+
+Class Instances and Levels
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Class instances are also subject to level checking. Instances must be available at the level where they're used:
+
+* Instances from the current module are at level 0
+* Instances from normally imported modules are at level 0
+* Instances from splice-imported modules are at level -1
+* Instances from quote-imported modules are at level 1
+
+Since classes are imported transitively, the typechecker ensures that there is a
+well-levelled path to access any instance. For example, if an instance is needed
+at level -1, then the instance must come from the transitive closure of splice
+imported modules.
+
+Prelude Imports
+~~~~~~~~~~~~~~~
+
+The implicit ``Prelude`` import only brings identifiers into scope at level 0.
+If you need ``Prelude`` functions in splices or quotes, you must explicitly
+import them:
+
+.. code-block:: haskell
+
+ import splice Prelude (map, filter) -- Use these in splices
+ import quote Prelude (show, (+)) -- Use these in quotes
+
+Notes and Limitations
+~~~~~~~~~~~~~~~~~~~~~
+
+* Local definitions (those defined in the same module) are still subject to
+ level rules - you can't use a function in a splice if it's defined in the
+ same module
+* :extension:`ExplicitLevelImports` works best when most Template Haskell
+ usage is isolated to a few modules
+* Defining ``Lift`` instances requires special handling since the datatype must
+ be available at both compile-time and runtime
.. _th-usage:
@@ -477,11 +758,6 @@ Using Template Haskell
- The data types and monadic constructor functions for Template Haskell
are in the library :th-ref:`Language.Haskell.TH.Syntax.`.
-- You can only run a function at compile time if it is imported from
- another module. That is, you can't define a function in a module, and
- call it from within a splice in the same module. (It would make sense
- to do so, but it's hard to implement.)
-
- You can only run a function at compile time if it is imported from
another module *that is not part of a mutually-recursive group of
modules that includes the module currently being compiled*.
@@ -502,10 +778,6 @@ Using Template Haskell
compiles produces results whose representations are identical to
those of the compiler itself.
-Template Haskell works in any mode (:ghc-flag:`--make`,
-:ghc-flag:`--interactive`, or file-at-a-time). There used to be a restriction to
-the former two, but that restriction has been lifted.
-
.. _th-view-gen-code:
Viewing Template Haskell generated code
@@ -791,7 +1063,7 @@ single parser of type ``String -> a`` to generate both an expression
parser that returns a value of type ``Q Exp`` and a pattern parser that
returns a value of type ``Q Pat``.
-Quasiquoters must obey the same stage restrictions as Template Haskell,
+Quasiquoters must obey the same level restrictions as Template Haskell,
e.g., in the example, ``expr`` cannot be defined in ``Main.hs`` where it
is used, but must be imported.
@@ -867,3 +1139,4 @@ Run "main" and here is your output:
1
+
diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst
index e8d4badff69..468d317cb3d 100644
--- a/docs/users_guide/phases.rst
+++ b/docs/users_guide/phases.rst
@@ -679,6 +679,11 @@ Options affecting code generation
object files are generated, but if ghc-flag:`-fprefer-byte-code` is enabled,
byte-code will be generated instead.
+ Code generation is only turned on for modules needed for evaluation during compilation.
+ A programmer can be more precise about which exact modules those are by using
+ the :extension:`ExplicitLevelImports` extension.
+
+
.. ghc-flag:: -fwrite-interface
:shortdesc: Always write interface files
:type: dynamic
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 3b705e5b8ab..b7d44a97a0a 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -78,7 +78,7 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Wgadt-mono-local-binds`
* :ghc-flag:`-Wtype-equality-requires-operators`
* :ghc-flag:`-Wtype-equality-out-of-scope`
- * :ghc-flag:`-Wbadly-staged-types`
+ * :ghc-flag:`-Wbadly-levelled-types`
* :ghc-flag:`-Winconsistent-flags`
* :ghc-flag:`-Wnoncanonical-monoid-instances`
* :ghc-flag:`-Wnoncanonical-monad-instances`
@@ -2554,23 +2554,33 @@ of ``-W(no-)*``.
When :ghc-flag:`-Wincomplete-export-warnings` is enabled, GHC warns about exports
that are not deprecating a name that is deprecated with another export in that module.
-.. ghc-flag:: -Wbadly-staged-types
- :shortdesc: warn when type binding is used at the wrong TH stage.
+.. ghc-flag:: -Wbadly-levelled-types
+ :shortdesc: warn when type binding is used at the wrong Template Haskell level.
:type: dynamic
- :reverse: -Wno-badly-staged-types
+ :reverse: -Wno-badly-levelled-types
- :since: 9.10.1
+ :since: 9.14.1
Consider an example: ::
tardy :: forall a. Proxy a -> IO Type
tardy _ = [t| a |]
- The type binding ``a`` is bound at stage 1 but used on stage 2.
+ The type binding ``a`` is bound at level 0 but used at level 1.
- This is badly staged program, and the ``tardy (Proxy @Int)`` won't produce
+ This is a badly levelled program, and the ``tardy (Proxy @Int)`` won't produce
a type representation of ``Int``, but rather a local name ``a``.
+.. ghc-flag:: -Wbadly-staged-types
+ :shortdesc: A deprecated alias for :ghc-flag:`-Wbadly-levelled-types`
+ :type: dynamic
+ :reverse: -Wno-badly-staged-types
+
+ :since: 9.10.1
+
+ A deprecated alias for :ghc-flag:`-Wbadly-levelled-types`
+
+
.. ghc-flag:: -Winconsistent-flags
:shortdesc: warn when command line options are inconsistent in some way.
:type: dynamic
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index d99b21ea461..634892d8f10 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -2928,6 +2928,7 @@ iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
= unLoc (ideclName d1) == unLoc (ideclName d2)
&& ideclAs d1 == ideclAs d2
+ && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2)
&& (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))
&& (ideclImportList d1 `hidingSubsumes` ideclImportList d2)
where
diff --git a/libraries/base/tests/IO/Makefile b/libraries/base/tests/IO/Makefile
index d1a94027500..45a22cf1a48 100644
--- a/libraries/base/tests/IO/Makefile
+++ b/libraries/base/tests/IO/Makefile
@@ -7,11 +7,11 @@ include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
test.concio001:
- "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 concio001 -o concio001
+ "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 concio001 -o concio001
(sleep 1; echo x) | ./concio001
test.concio001.thr:
- "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 -threaded concio001 -o concio001
+ "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 -threaded concio001 -o concio001
(sleep 1; echo x) | ./concio001
# NB. utf8-test should *not* have a final newline. The last char should be 'X'.
@@ -40,11 +40,11 @@ hSetEncoding001.in : latin1 utf8-test utf16le-test utf16be-test utf16-test utf32
cat >$@ latin1 utf8-test utf16le-test utf16be-test utf16-test utf32-test utf32le-test utf32be-test utf8-bom-test
environment001-test:
- "$(TEST_HC)" --make -fforce-recomp -v0 environment001.hs -o environment001
+ "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 environment001.hs -o environment001
GHC_TEST=马克斯 ./environment001 说
T3307-test:
- "$(TEST_HC)" --make -fforce-recomp -v0 T3307.hs -o T3307
+ "$(TEST_HC)" $(TEST_HC_OPTS) --make -fforce-recomp -v0 T3307.hs -o T3307
echo Ni hao > chinese-file-å°è¯´
echo chinese-file-å°è¯´ > chinese-name
# The tests are run in whatever the default locale is. This is almost always UTF-8,
diff --git a/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs b/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
index 44f53d6cefe..2e35a47412a 100644
--- a/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
@@ -165,6 +165,8 @@ data Extension
| ExtendedLiterals
| ListTuplePuns
| MultilineStrings
+ | ExplicitLevelImports
+ | ImplicitStagePersistence
deriving (Eq, Enum, Show, Generic, Bounded)
-- 'Ord' and 'Bounded' are provided for GHC API users (see discussions
-- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
diff --git a/testsuite/tests/ado/ado004.stderr b/testsuite/tests/ado/ado004.stderr
index 61b8cee9120..9da5b244b66 100644
--- a/testsuite/tests/ado/ado004.stderr
+++ b/testsuite/tests/ado/ado004.stderr
@@ -44,4 +44,4 @@ TYPE SIGNATURES
(Monad m, Num (m a)) =>
(m a -> m (m a)) -> p -> m a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/annotations/should_fail/annfail03.stderr b/testsuite/tests/annotations/should_fail/annfail03.stderr
index 77362f800ee..5c030b2e579 100644
--- a/testsuite/tests/annotations/should_fail/annfail03.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail03.stderr
@@ -1,6 +1,18 @@
+annfail03.hs:12:16: error: [GHC-28914]
+ • Level error: ‘InModule’ is bound at level 0 but used at level -1
+ Hint: quoting [| InModule |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN module InModule #-}
+
+annfail03.hs:14:18: error: [GHC-28914]
+ • Level error: ‘InModule’ is bound at level 0 but used at level -1
+ Hint: quoting [| InModule |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN type Foo InModule #-}
+
+annfail03.hs:17:11: error: [GHC-28914]
+ • Level error: ‘InModule’ is bound at level 0 but used at level -1
+ Hint: quoting [| InModule |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN f InModule #-}
-annfail03.hs:17:11: [GHC-18157]
- GHC stage restriction:
- ‘InModule’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the annotation: {-# ANN f InModule #-}
diff --git a/testsuite/tests/annotations/should_fail/annfail04.stderr b/testsuite/tests/annotations/should_fail/annfail04.stderr
index 4130717a1e5..59429420252 100644
--- a/testsuite/tests/annotations/should_fail/annfail04.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail04.stderr
@@ -1,7 +1,5 @@
+annfail04.hs:14:12: error: [GHC-28914]
+ • Level error: instance for ‘Thing Int’ is bound at level 0
+ but used at level -1
+ • In the annotation: {-# ANN f (thing :: Int) #-}
-annfail04.hs:14:12: [GHC-18157]
- GHC stage restriction:
- instance for ‘Thing
- Int’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the annotation: {-# ANN f (thing :: Int) #-}
diff --git a/testsuite/tests/annotations/should_fail/annfail06.stderr b/testsuite/tests/annotations/should_fail/annfail06.stderr
index 8c17b71103d..bbb925cbb8c 100644
--- a/testsuite/tests/annotations/should_fail/annfail06.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail06.stderr
@@ -1,7 +1,5 @@
+annfail06.hs:22:1: error: [GHC-28914]
+ • Level error: instance for ‘Data InstancesInWrongModule’
+ is bound at level 0 but used at level -1
+ • In the annotation: {-# ANN f InstancesInWrongModule #-}
-annfail06.hs:22:1: [GHC-18157]
- GHC stage restriction:
- instance for ‘Data
- InstancesInWrongModule’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the annotation: {-# ANN f InstancesInWrongModule #-}
diff --git a/testsuite/tests/annotations/should_fail/annfail09.stderr b/testsuite/tests/annotations/should_fail/annfail09.stderr
index 22fe13193eb..b5a4292952e 100644
--- a/testsuite/tests/annotations/should_fail/annfail09.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail09.stderr
@@ -1,6 +1,18 @@
+annfail09.hs:6:16: error: [GHC-28914]
+ • Level error: ‘g’ is bound at level 0 but used at level -1
+ Hint: quoting [| g |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN module g #-}
+
+annfail09.hs:8:18: error: [GHC-28914]
+ • Level error: ‘g’ is bound at level 0 but used at level -1
+ Hint: quoting [| g |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN type Foo g #-}
+
+annfail09.hs:11:11: error: [GHC-28914]
+ • Level error: ‘g’ is bound at level 0 but used at level -1
+ Hint: quoting [| g |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the annotation: {-# ANN f g #-}
-annfail09.hs:11:11: [GHC-18157]
- GHC stage restriction:
- ‘g’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the annotation: {-# ANN f g #-}
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index aa31346b996..07e9ec1245b 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -181,6 +181,7 @@ GHC.Types.SourceFile
GHC.Types.SourceText
GHC.Types.SptEntry
GHC.Types.SrcLoc
+GHC.Types.ThLevelIndex
GHC.Types.Tickish
GHC.Types.TyThing
GHC.Types.Unique
@@ -244,6 +245,7 @@ Language.Haskell.Syntax.Decls
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
Language.Haskell.Syntax.ImpExp
+Language.Haskell.Syntax.ImpExp.IsBoot
Language.Haskell.Syntax.Lit
Language.Haskell.Syntax.Module.Name
Language.Haskell.Syntax.Pat
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 1a06587d8c3..73e7399b31a 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -205,6 +205,7 @@ GHC.Types.SourceText
GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Target
+GHC.Types.ThLevelIndex
GHC.Types.Tickish
GHC.Types.TyThing
GHC.Types.Unique
@@ -231,6 +232,7 @@ GHC.Unit.Module.Location
GHC.Unit.Module.ModIface
GHC.Unit.Module.ModNodeKey
GHC.Unit.Module.ModSummary
+GHC.Unit.Module.Stage
GHC.Unit.Module.Warnings
GHC.Unit.Module.WholeCoreBindings
GHC.Unit.Parser
@@ -272,6 +274,7 @@ Language.Haskell.Syntax.Decls
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
Language.Haskell.Syntax.ImpExp
+Language.Haskell.Syntax.ImpExp.IsBoot
Language.Haskell.Syntax.Lit
Language.Haskell.Syntax.Module.Name
Language.Haskell.Syntax.Pat
diff --git a/testsuite/tests/dependent/should_compile/T14729.stderr b/testsuite/tests/dependent/should_compile/T14729.stderr
index 6af2d223807..21bf9ff434f 100644
--- a/testsuite/tests/dependent/should_compile/T14729.stderr
+++ b/testsuite/tests/dependent/should_compile/T14729.stderr
@@ -11,4 +11,4 @@ COERCION AXIOMS
FAMILY INSTANCES
type instance F Int = Bool -- Defined at T14729.hs:10:15
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/dependent/should_compile/T15743.stderr b/testsuite/tests/dependent/should_compile/T15743.stderr
index 5f457e7a939..bcd96e93f24 100644
--- a/testsuite/tests/dependent/should_compile/T15743.stderr
+++ b/testsuite/tests/dependent/should_compile/T15743.stderr
@@ -3,4 +3,4 @@ TYPE CONSTRUCTORS
forall {k1} k2 (k3 :: k2). Proxy k3 -> k1 -> k2 -> *
roles nominal nominal nominal phantom phantom phantom
Dependent modules: []
-Dependent packages: [base-4.19.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/dependent/should_compile/T15743e.stderr b/testsuite/tests/dependent/should_compile/T15743e.stderr
index 5653d37a8c0..7c423229fff 100644
--- a/testsuite/tests/dependent/should_compile/T15743e.stderr
+++ b/testsuite/tests/dependent/should_compile/T15743e.stderr
@@ -54,4 +54,4 @@ DATA CONSTRUCTORS
(d :: Proxy k5) (e :: Proxy k7).
f c -> T k8 a b f c d e
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 3649c2e1bd2..351ede6c4f6 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -15,14 +15,18 @@ Derived class instances:
instance GHC.Internal.TH.Lift.Lift T14682.Foo where
GHC.Internal.TH.Lift.lift (T14682.Foo a1 a2)
- = [| T14682.Foo
- $(GHC.Internal.TH.Lift.lift a1) $(GHC.Internal.TH.Lift.lift a2) |]
- pending(rn) [<spn, GHC.Internal.TH.Lift.lift a2>,
- <spn, GHC.Internal.TH.Lift.lift a1>]
+ = GHC.Internal.TH.Lib.appE
+ (GHC.Internal.TH.Lib.appE
+ (GHC.Internal.TH.Lib.conE 'T14682.Foo)
+ (GHC.Internal.TH.Lift.lift a1))
+ (GHC.Internal.TH.Lift.lift a2)
GHC.Internal.TH.Lift.liftTyped (T14682.Foo a1 a2)
- = [|| T14682.Foo
- $$(GHC.Internal.TH.Lift.liftTyped a1)
- $$(GHC.Internal.TH.Lift.liftTyped a2) ||]
+ = GHC.Internal.TH.Syntax.unsafeCodeCoerce
+ (GHC.Internal.TH.Lib.appE
+ (GHC.Internal.TH.Lib.appE
+ (GHC.Internal.TH.Lib.conE 'T14682.Foo)
+ (GHC.Internal.TH.Lift.lift a1))
+ (GHC.Internal.TH.Lift.lift a2))
instance GHC.Internal.Data.Data.Data T14682.Foo where
GHC.Internal.Data.Data.gfoldl k z (T14682.Foo a1 a2)
diff --git a/testsuite/tests/determinism/determ021/determ021.stdout b/testsuite/tests/determinism/determ021/determ021.stdout
index 3141769f687..f6f095d6d63 100644
--- a/testsuite/tests/determinism/determ021/determ021.stdout
+++ b/testsuite/tests/determinism/determ021/determ021.stdout
@@ -5,7 +5,7 @@ TYPE SIGNATURES
(Applicative f, Num t, Num b) =>
(t -> f b) -> f b
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
[1 of 1] Compiling A ( A.hs, A.o )
TYPE SIGNATURES
test2 ::
@@ -13,4 +13,4 @@ TYPE SIGNATURES
(Applicative f, Num t, Num b) =>
(t -> f b) -> f b
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/driver/T4437.stdout b/testsuite/tests/driver/T4437.stdout
new file mode 100644
index 00000000000..7a67dedacd9
--- /dev/null
+++ b/testsuite/tests/driver/T4437.stdout
@@ -0,0 +1,6 @@
+GHC-only flags: Unexpected flags
+-----
+ExplicitLevelImports
+ImplicitStagePersistence
+-----
+
diff --git a/testsuite/tests/driver/json2.stderr b/testsuite/tests/driver/json2.stderr
index 51e20faa0e0..376c3b94c5a 100644
--- a/testsuite/tests/driver/json2.stderr
+++ b/testsuite/tests/driver/json2.stderr
@@ -1,2 +1,2 @@
{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [base-4.19.0.0]","messageClass":"MCOutput"}
+{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"}
diff --git a/testsuite/tests/gadt/T19847a.stderr b/testsuite/tests/gadt/T19847a.stderr
index 29c720d320f..79cac15bb94 100644
--- a/testsuite/tests/gadt/T19847a.stderr
+++ b/testsuite/tests/gadt/T19847a.stderr
@@ -9,4 +9,4 @@ DATA CONSTRUCTORS
(x ~ y, c ~ [x], Ord x) =>
x -> y -> T (x, y) b c
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs b/testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
index fccbd3c249c..76655edff65 100644
--- a/testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
+++ b/testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
@@ -97,7 +97,7 @@ main = do
msC <- getModSummaryFromTarget "T1C.hs"
-- Get file paths and create locations for our modules
- let findImports modName = case modName of
+ let findImports modName = map mkNormalEdge $ case modName of
"T1A" -> []
"T1B" -> [NodeKey_Module (msKey msA)]
"T1C" -> [NodeKey_Module (msKey msA), NodeKey_Module (msKey msB)]
diff --git a/testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs b/testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
index 5b892bec1e1..10819d9470b 100644
--- a/testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
+++ b/testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
@@ -80,6 +80,10 @@ main = do
keyB = NodeKey_Module (msKey msB)
keyC = NodeKey_Module (msKey msC)
+ edgeA = mkNormalEdge keyA
+ edgeB = mkNormalEdge keyB
+ edgeC = mkNormalEdge keyC
+
-- Define ModuleNodeInfos
let infoA_compile = ModuleNodeCompile msA
infoB_compile = ModuleNodeCompile msB
@@ -91,12 +95,12 @@ main = do
-- Define the complete nodes
let nodeA_compile = ModuleNode [] infoA_compile
- nodeB_compile = ModuleNode [keyA] infoB_compile
- nodeC_compile = ModuleNode [keyA, keyB] infoC_compile
+ nodeB_compile = ModuleNode [edgeA] infoB_compile
+ nodeC_compile = ModuleNode [edgeA, edgeB] infoC_compile
nodeA_fixed = ModuleNode [] infoA_fixed
- nodeB_fixed = ModuleNode [keyA] infoB_fixed
- nodeC_fixed = ModuleNode [keyA, keyB] infoC_fixed
+ nodeB_fixed = ModuleNode [edgeA] infoB_fixed
+ nodeC_fixed = ModuleNode [edgeA, edgeB] infoC_fixed
-- Test 1: Valid graph with all compile nodes
let validGraph = mkModuleGraph [nodeA_compile, nodeB_compile, nodeC_compile]
@@ -118,7 +122,7 @@ main = do
-- Test 5: Invalid - Missing dependency
let nodeB_noDepends = ModuleNode [] infoB_compile
- nodeC_missingDep = ModuleNode [keyA] infoC_compile
+ nodeC_missingDep = ModuleNode [edgeA] infoC_compile
missingDepGraph = mkModuleGraph [nodeB_noDepends, nodeC_missingDep]
testModuleGraph "Missing dependency" missingDepGraph
[DependencyNotInGraph keyC [keyA]]
diff --git a/testsuite/tests/indexed-types/should_compile/T15711.stderr b/testsuite/tests/indexed-types/should_compile/T15711.stderr
index 4815ee04960..f03821c92aa 100644
--- a/testsuite/tests/indexed-types/should_compile/T15711.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T15711.stderr
@@ -3,4 +3,4 @@ TYPE CONSTRUCTORS
associated type family F{2} :: forall a. Maybe a -> *
roles nominal nominal
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/indexed-types/should_compile/T15852.stderr b/testsuite/tests/indexed-types/should_compile/T15852.stderr
index 706f6e0bd8a..ef0434760da 100644
--- a/testsuite/tests/indexed-types/should_compile/T15852.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T15852.stderr
@@ -9,4 +9,4 @@ FAMILY INSTANCES
data instance forall {k1} {k2} {j :: k1} {c :: k2}.
DF (Proxy c) -- Defined at T15852.hs:10:15
Dependent modules: []
-Dependent packages: [base-4.19.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr
index be4b88943ea..75765793f0e 100644
--- a/testsuite/tests/indexed-types/should_compile/T3017.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr
@@ -20,4 +20,4 @@ CLASS INSTANCES
FAMILY INSTANCES
type instance Elem (ListColl a) = a -- Defined at T3017.hs:13:9
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/interface-stability/template-haskell-exports.stdout b/testsuite/tests/interface-stability/template-haskell-exports.stdout
index 2c86ec38f78..75bcdbdef70 100644
--- a/testsuite/tests/interface-stability/template-haskell-exports.stdout
+++ b/testsuite/tests/interface-stability/template-haskell-exports.stdout
@@ -265,6 +265,8 @@ module Language.Haskell.TH where
| ExtendedLiterals
| ListTuplePuns
| MultilineStrings
+ | ExplicitLevelImports
+ | ImplicitStagePersistence
type FamilyResultSig :: *
data FamilyResultSig = NoSig | KindSig Kind | TyVarSig (TyVarBndr ())
type FamilyResultSigQ :: *
@@ -871,6 +873,8 @@ module Language.Haskell.TH.LanguageExtensions where
| ExtendedLiterals
| ListTuplePuns
| MultilineStrings
+ | ExplicitLevelImports
+ | ImplicitStagePersistence
module Language.Haskell.TH.Lib where
-- Safety: Safe
@@ -1610,6 +1614,8 @@ module Language.Haskell.TH.Syntax where
| ExtendedLiterals
| ListTuplePuns
| MultilineStrings
+ | ExplicitLevelImports
+ | ImplicitStagePersistence
type FamilyResultSig :: *
data FamilyResultSig = NoSig | KindSig Kind | TyVarSig (TyVarBndr ())
type FieldExp :: *
diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr
index 7a1f59d930c..c8176af7ec9 100644
--- a/testsuite/tests/module/mod185.stderr
+++ b/testsuite/tests/module/mod185.stderr
@@ -42,6 +42,7 @@
(EpaSpan { mod185.hs:3:1-6 }))
(Nothing)
(Nothing)
+ (Nothing)
(Just
(EpTok
(EpaSpan { mod185.hs:3:16-24 })))
@@ -61,6 +62,7 @@
{ModuleName: Prelude})
(NoRawPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(QualifiedPost)
(Nothing)
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 75195135c70..5255eea0f42 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -54,6 +54,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -69,6 +70,7 @@
{ModuleName: Data.Kind})
(NoRawPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 46dcb94141a..0e47eed7485 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -2648,6 +2648,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -2663,6 +2664,7 @@
{ModuleName: Prelude})
(NoPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
@@ -2685,6 +2687,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -2700,6 +2703,7 @@
{ModuleName: Data.Kind})
(NoPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
@@ -2722,6 +2726,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -2737,6 +2742,7 @@
{ModuleName: Data.Kind})
(NoPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr
index 61a053f1a48..bd22e1f01f5 100644
--- a/testsuite/tests/parser/should_compile/DumpSemis.stderr
+++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr
@@ -79,6 +79,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -94,6 +95,7 @@
{ModuleName: Data.List})
(NoRawPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
@@ -144,6 +146,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -159,6 +162,7 @@
{ModuleName: Data.Kind})
(NoRawPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index b2b1dcf8344..e496ba0fefd 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -54,6 +54,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -69,6 +70,7 @@
{ModuleName: Data.Kind})
(NoRawPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 948eaa69499..d2aba9af3b5 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -262,6 +262,7 @@
(Nothing)
(Nothing)
(Nothing)
+ (Nothing)
(Nothing))
(EpaComments
[]))
@@ -277,6 +278,7 @@
{ModuleName: Prelude})
(NoPkgQual)
(NotBoot)
+ (NotLevelled)
(False)
(NotQualified)
(Nothing)
diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr
index 6db1e3d1a15..7f9527da11e 100644
--- a/testsuite/tests/partial-sigs/should_compile/ADT.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr
@@ -5,4 +5,4 @@ TYPE CONSTRUCTORS
DATA CONSTRUCTORS
Foo :: forall x y z. x -> y -> z -> Foo x y z
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr
index 127b6fc9d15..4b1a12b0298 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr1 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr
index b17d8479c22..4c4d9a96bcd 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr2 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr
index 588a4f002cf..64a7f4316cc 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr3 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr
index e258ab7ed29..8e01cdddafd 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr4 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr
index 81e3a08f0ae..561fbcb4f07 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr5 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr
index abceb2441ea..39001538689 100644
--- a/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
addAndOr6 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr b/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr
index da12cce48b3..61155f444ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
index 7e8648e9cdc..10a12938ce7 100644
--- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
@@ -15,4 +15,4 @@ DATA CONSTRUCTORS
FAMILY INSTANCES
data instance Sing _ -- Defined at DataFamilyInstanceLHS.hs:8:15
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr
index 288432e39aa..3a935ccef2f 100644
--- a/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
alpha :: Integer
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr
index 549c00050f0..93a0857c1af 100644
--- a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bravo :: forall {w}. Num w => w
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr
index 549c00050f0..93a0857c1af 100644
--- a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bravo :: forall {w}. Num w => w
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Either.stderr b/testsuite/tests/partial-sigs/should_compile/Either.stderr
index 806f23e5059..982f6ce4f4f 100644
--- a/testsuite/tests/partial-sigs/should_compile/Either.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Either.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
barry :: forall {w}. w -> (Either String w, Either String w)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr
index b0e10c980ea..15b31159223 100644
--- a/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: forall a. (a ~ Bool) => (a, Bool)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Every.stderr b/testsuite/tests/partial-sigs/should_compile/Every.stderr
index a7806d6e39b..48ce715392d 100644
--- a/testsuite/tests/partial-sigs/should_compile/Every.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Every.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
every :: forall {t}. (t -> Bool) -> [t] -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr
index 55b3d61f9e3..09d84ec47b9 100644
--- a/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
every :: forall {w}. (w -> Bool) -> [w] -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr
index da12cce48b3..61155f444ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr
index da12cce48b3..61155f444ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr
index 3c64c81f34f..2561b6b02c0 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr
@@ -5,4 +5,4 @@ TYPE SIGNATURES
arbitCs4 :: forall a. (Eq a, Show a, Enum a) => a -> String
arbitCs5 :: forall a. (Eq a, Enum a, Show a) => a -> String
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr
index 4b5e8d26931..3678de3362d 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: String
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
index 85fcc04b19e..f3fd05f5425 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
@@ -236,4 +236,4 @@ TYPE SIGNATURES
(a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
(||) :: Bool -> Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr
index 424ceda0e06..a0de662f463 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: forall a. Num a => a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr
index 424ceda0e06..a0de662f463 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: forall a. Num a => a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Forall1.stderr b/testsuite/tests/partial-sigs/should_compile/Forall1.stderr
index edaf392fcc7..9421fbdbd6d 100644
--- a/testsuite/tests/partial-sigs/should_compile/Forall1.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Forall1.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
fall :: forall a. a -> a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr b/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr
index da12cce48b3..61155f444ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr b/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr
index 78309d688f2..912e2209b45 100644
--- a/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: (forall a. [a] -> [a]) -> ([Bool], [Char])
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr b/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr
index 78309d688f2..912e2209b45 100644
--- a/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: (forall a. [a] -> [a]) -> ([Bool], [Char])
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr
index c6d7b5cfa52..125e0e2a9f5 100644
--- a/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
monoLoc :: forall a. a -> ((a, String), (a, String))
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
index 916a898fa5c..c6a4c483632 100644
--- a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
@@ -12,4 +12,4 @@ CLASS INSTANCES
-- Defined at Meltdown.hs:12:10
instance Monad (NukeMonad a b) -- Defined at Meltdown.hs:16:10
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr
index c6d7b5cfa52..125e0e2a9f5 100644
--- a/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
monoLoc :: forall a. a -> ((a, String), (a, String))
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr
index b21d99f8b26..a4fd11cb39f 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: forall b a. (a, b) -> (a, b)
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
index 837a82a207f..ac59491c8c3 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
@@ -14,4 +14,4 @@ FAMILY INSTANCES
data instance Sing _a
-- Defined at NamedWildcardInDataFamilyInstanceLHS.hs:8:15
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
index 0718bd597f0..82216b5684e 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
@@ -4,4 +4,4 @@ TYPE CONSTRUCTORS
COERCION AXIOMS
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F :: F _t = Int
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr
index f7a9e34a0e7..c06b7707134 100644
--- a/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
f :: forall a. Eq a => a -> a -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind.stderr b/testsuite/tests/partial-sigs/should_compile/PatBind.stderr
index a795dcd27c2..aa21f838bcf 100644
--- a/testsuite/tests/partial-sigs/should_compile/PatBind.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/PatBind.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: forall {a}. a -> a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr b/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr
index 49852a17582..bab0e864766 100644
--- a/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr b/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr
index da12cce48b3..61155f444ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Recursive.stderr b/testsuite/tests/partial-sigs/should_compile/Recursive.stderr
index af7fde6f8eb..e2e4121dc0a 100644
--- a/testsuite/tests/partial-sigs/should_compile/Recursive.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Recursive.stderr
@@ -3,4 +3,4 @@ TYPE SIGNATURES
g :: Bool
orr :: forall a. a -> a -> a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr
index a7cd75974c9..6347fbeed93 100644
--- a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
test3 :: Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr
index ed05ffce9d1..dd9a103653a 100644
--- a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
foo :: Bool -> Char
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr b/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr
index 31d4fe1430e..ce1d24bdaf9 100644
--- a/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
showTwo :: forall {a}. Show a => a -> String
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr
index 02aa357eb9b..f23def9c005 100644
--- a/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
bar :: forall {w}. w -> Bool
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
index a611448bc5f..87a5b749fe1 100644
--- a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
@@ -8,4 +8,4 @@ TYPE CONSTRUCTORS
DATA CONSTRUCTORS
GenParser :: forall tok st a. tok -> st -> a -> GenParser tok st a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr
index 0007d47579b..0381c93d5d6 100644
--- a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr
@@ -1,8 +1,7 @@
TYPE SIGNATURES
somethingShowable :: Show Bool => Bool -> String
Dependent modules: []
-Dependent packages: [base-4.19.0.0]
-
+Dependent packages: [(normal, base-4.21.0.0)]
SomethingShowable.hs:5:1: warning: [GHC-62412] [-Wsimplifiable-class-constraints (in -Wdefault)]
• The constraint ‘Show Bool’ matches
instance Show Bool -- Defined in ‘GHC.Internal.Show’
@@ -10,3 +9,4 @@ SomethingShowable.hs:5:1: warning: [GHC-62412] [-Wsimplifiable-class-constraints
either use MonoLocalBinds, or simplify it using the instance
• When checking the inferred type
somethingShowable :: Show Bool => Bool -> String
+
diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
index aa43444c9b3..0965b104b10 100644
--- a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
@@ -12,4 +12,4 @@ FAMILY INSTANCES
type instance F Bool _ = Bool
-- Defined at TypeFamilyInstanceLHS.hs:8:15
Dependent modules: []
-Dependent packages: [base-4.19.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr
index 8f6c2fb215a..07582f583a3 100644
--- a/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
unc :: forall {w1} {w2} {w3}. (w1 -> w2 -> w3) -> (w1, w2) -> w3
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr
index 8f6c2fb215a..07582f583a3 100644
--- a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr
@@ -1,4 +1,4 @@
TYPE SIGNATURES
unc :: forall {w1} {w2} {w3}. (w1 -> w2 -> w3) -> (w1, w2) -> w3
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
index 16a82f7aba5..6db7ec693e5 100644
--- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
@@ -2,8 +2,7 @@ TYPE SIGNATURES
bar :: forall {t} {w}. t -> (t -> w) -> w
foo :: forall {a}. (Show a, Enum a) => a -> String
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
-
+Dependent packages: [(normal, base-4.21.0.0)]
WarningWildcardInstantiations.hs:5:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_a’ standing for ‘a’
Where: ‘a’ is a rigid type variable bound by
@@ -42,3 +41,4 @@ WarningWildcardInstantiations.hs:8:18: warning: [GHC-88464] [-Wpartial-type-sign
the inferred type of bar :: t -> (t -> w) -> w
at WarningWildcardInstantiations.hs:9:1-13
• In the type signature: bar :: _ -> _ -> _
+
diff --git a/testsuite/tests/polykinds/T15592.stderr b/testsuite/tests/polykinds/T15592.stderr
index 8ac2d3e1856..4a9824198de 100644
--- a/testsuite/tests/polykinds/T15592.stderr
+++ b/testsuite/tests/polykinds/T15592.stderr
@@ -5,4 +5,4 @@ DATA CONSTRUCTORS
MkT :: forall {k} k1 (f :: k1 -> k -> *) (a :: k1) (b :: k).
f a b -> T f a b -> T f a b
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/polykinds/T15592b.stderr b/testsuite/tests/polykinds/T15592b.stderr
index 4695648e606..48224aa40d4 100644
--- a/testsuite/tests/polykinds/T15592b.stderr
+++ b/testsuite/tests/polykinds/T15592b.stderr
@@ -4,4 +4,4 @@ TYPE CONSTRUCTORS
forall k (f :: k -> *) (a :: k). f a -> *
roles nominal nominal nominal nominal
Dependent modules: []
-Dependent packages: [base-4.19.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/printer/T18052a.stderr b/testsuite/tests/printer/T18052a.stderr
index 5a369107f94..01ff6768ae5 100644
--- a/testsuite/tests/printer/T18052a.stderr
+++ b/testsuite/tests/printer/T18052a.stderr
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
PATTERN SYNONYMS
(:||:) :: forall {a} {b}. a -> b -> (a, b)
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Tidy Core ====================
Result size of Tidy Core
diff --git a/testsuite/tests/quasiquotation/qq001/qq001.stderr b/testsuite/tests/quasiquotation/qq001/qq001.stderr
index d1fdbdf62e1..45648bd02df 100644
--- a/testsuite/tests/quasiquotation/qq001/qq001.stderr
+++ b/testsuite/tests/quasiquotation/qq001/qq001.stderr
@@ -1,6 +1,6 @@
+qq001.hs:7:16: error: [GHC-28914]
+ • Level error: ‘parse’ is bound at level 0 but used at level -1
+ Hint: quoting [| parse |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the quasi-quotation: [parse||]
-qq001.hs:7:16: [GHC-18157]
- GHC stage restriction:
- ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the quasi-quotation: [parse||]
diff --git a/testsuite/tests/quasiquotation/qq002/qq002.stderr b/testsuite/tests/quasiquotation/qq002/qq002.stderr
index 984ce452725..2c0399fc784 100644
--- a/testsuite/tests/quasiquotation/qq002/qq002.stderr
+++ b/testsuite/tests/quasiquotation/qq002/qq002.stderr
@@ -1,6 +1,6 @@
+qq002.hs:8:10: error: [GHC-28914]
+ • Level error: ‘parse’ is bound at level 0 but used at level -1
+ Hint: quoting [| parse |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the quasi-quotation: [parse||]
-qq002.hs:8:10: [GHC-18157]
- GHC stage restriction:
- ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the quasi-quotation: [parse||]
diff --git a/testsuite/tests/quasiquotation/qq003/qq003.stderr b/testsuite/tests/quasiquotation/qq003/qq003.stderr
index ad6972ada46..48d5b3dbc6e 100644
--- a/testsuite/tests/quasiquotation/qq003/qq003.stderr
+++ b/testsuite/tests/quasiquotation/qq003/qq003.stderr
@@ -1,6 +1,6 @@
+qq003.hs:5:26: error: [GHC-28914]
+ • Level error: ‘parse’ is bound at level 0 but used at level -1
+ Hint: quoting [| parse |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the quasi-quotation: [parse||]
-qq003.hs:5:26: [GHC-18157]
- GHC stage restriction:
- ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the quasi-quotation: [parse||]
diff --git a/testsuite/tests/quasiquotation/qq004/qq004.stderr b/testsuite/tests/quasiquotation/qq004/qq004.stderr
index 97a0bb0b1aa..ffe7978ead1 100644
--- a/testsuite/tests/quasiquotation/qq004/qq004.stderr
+++ b/testsuite/tests/quasiquotation/qq004/qq004.stderr
@@ -1,6 +1,6 @@
+qq004.hs:8:21: error: [GHC-28914]
+ • Level error: ‘parse’ is bound at level 0 but used at level -1
+ Hint: quoting [| parse |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the quasi-quotation: [parse||]
-qq004.hs:8:21: [GHC-18157]
- GHC stage restriction:
- ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
- In the quasi-quotation: [parse||]
diff --git a/testsuite/tests/quotes/T5721.stderr b/testsuite/tests/quotes/T5721.stderr
new file mode 100644
index 00000000000..942bb493004
--- /dev/null
+++ b/testsuite/tests/quotes/T5721.stderr
@@ -0,0 +1,3 @@
+T5721.hs:7:14: warning: [GHC-86357] [-Wbadly-levelled-types (in -Wdefault)]
+ Badly levelled type: a is bound at level 0 but used at level 1
+
diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr
index e1c7cac4b90..4a39998830d 100644
--- a/testsuite/tests/roles/should_compile/Roles1.stderr
+++ b/testsuite/tests/roles/should_compile/Roles1.stderr
@@ -20,7 +20,7 @@ DATA CONSTRUCTORS
K2 :: forall a. a -> T2 a
K1 :: forall a. a -> T1 a
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Roles1.$tcT7
diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr
index 0a0a44a6ef1..263aa5a8389 100644
--- a/testsuite/tests/roles/should_compile/Roles14.stderr
+++ b/testsuite/tests/roles/should_compile/Roles14.stderr
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
COERCION AXIOMS
axiom Roles12.N:C2 :: C2 a = a -> a
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Roles12.$tcC2
diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr
index 4b9bad4f154..20b80417656 100644
--- a/testsuite/tests/roles/should_compile/Roles2.stderr
+++ b/testsuite/tests/roles/should_compile/Roles2.stderr
@@ -6,7 +6,7 @@ DATA CONSTRUCTORS
K2 :: forall a. FunPtr a -> T2 a
K1 :: forall a. IO a -> T1 a
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Roles2.$tcT2
diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr
index be8bad252f3..eb714c8752d 100644
--- a/testsuite/tests/roles/should_compile/Roles3.stderr
+++ b/testsuite/tests/roles/should_compile/Roles3.stderr
@@ -21,7 +21,7 @@ COERCION AXIOMS
axiom Roles3.N:C3 :: C3 a b = a -> F3 b -> F3 b
axiom Roles3.N:C4 :: C4 a b = a -> F4 b -> F4 b
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Roles3.$tcC4
diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr
index d2000ca827b..bf637edc294 100644
--- a/testsuite/tests/roles/should_compile/Roles4.stderr
+++ b/testsuite/tests/roles/should_compile/Roles4.stderr
@@ -9,7 +9,7 @@ COERCION AXIOMS
axiom Roles4.N:C1 :: C1 a = a -> a
axiom Roles4.N:C3 :: C3 a = a -> Syn1 a
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Roles4.$tcC3
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index 0ad3fff7efa..539ba47cd5a 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -18,7 +18,7 @@ CLASS INSTANCES
instance [incoherent] Representational a
-- Defined at T8958.hs:11:10
Dependent modules: []
-Dependent packages: [base-4.21.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
T8958.$tcMap
diff --git a/testsuite/tests/showIface/DocsInHiFile1.stdout b/testsuite/tests/showIface/DocsInHiFile1.stdout
index db22b6d4330..d6b615a31b1 100644
--- a/testsuite/tests/showIface/DocsInHiFile1.stdout
+++ b/testsuite/tests/showIface/DocsInHiFile1.stdout
@@ -147,5 +147,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/DocsInHiFileTH.stdout b/testsuite/tests/showIface/DocsInHiFileTH.stdout
index 58f75a58468..0255ff57c07 100644
--- a/testsuite/tests/showIface/DocsInHiFileTH.stdout
+++ b/testsuite/tests/showIface/DocsInHiFileTH.stdout
@@ -289,5 +289,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/HaddockIssue849.stdout b/testsuite/tests/showIface/HaddockIssue849.stdout
index 494470407ac..c2cee9ca229 100644
--- a/testsuite/tests/showIface/HaddockIssue849.stdout
+++ b/testsuite/tests/showIface/HaddockIssue849.stdout
@@ -70,5 +70,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/HaddockOpts.stdout b/testsuite/tests/showIface/HaddockOpts.stdout
index 9af90477e25..c6024e76878 100644
--- a/testsuite/tests/showIface/HaddockOpts.stdout
+++ b/testsuite/tests/showIface/HaddockOpts.stdout
@@ -61,5 +61,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/HaddockSpanIssueT24378.stdout b/testsuite/tests/showIface/HaddockSpanIssueT24378.stdout
index 90b301a9c60..0ac1f67fb90 100644
--- a/testsuite/tests/showIface/HaddockSpanIssueT24378.stdout
+++ b/testsuite/tests/showIface/HaddockSpanIssueT24378.stdout
@@ -83,5 +83,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/LanguageExts.stdout b/testsuite/tests/showIface/LanguageExts.stdout
index 9e3ebc0d6a2..852e1ba3f0f 100644
--- a/testsuite/tests/showIface/LanguageExts.stdout
+++ b/testsuite/tests/showIface/LanguageExts.stdout
@@ -25,5 +25,6 @@ docs:
CUSKs
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/MagicHashInHaddocks.stdout b/testsuite/tests/showIface/MagicHashInHaddocks.stdout
index 076828ae269..88d53770de4 100644
--- a/testsuite/tests/showIface/MagicHashInHaddocks.stdout
+++ b/testsuite/tests/showIface/MagicHashInHaddocks.stdout
@@ -71,5 +71,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/NoExportList.stdout b/testsuite/tests/showIface/NoExportList.stdout
index aed34318ebb..eb5f15a4e6c 100644
--- a/testsuite/tests/showIface/NoExportList.stdout
+++ b/testsuite/tests/showIface/NoExportList.stdout
@@ -97,5 +97,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/PragmaDocs.stdout b/testsuite/tests/showIface/PragmaDocs.stdout
index 1a86336cb19..c219cd61f4a 100644
--- a/testsuite/tests/showIface/PragmaDocs.stdout
+++ b/testsuite/tests/showIface/PragmaDocs.stdout
@@ -69,5 +69,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/showIface/ReExports.stdout b/testsuite/tests/showIface/ReExports.stdout
index c60a6bcdfa7..2d19171a740 100644
--- a/testsuite/tests/showIface/ReExports.stdout
+++ b/testsuite/tests/showIface/ReExports.stdout
@@ -68,5 +68,6 @@ docs:
StandaloneKindSignatures
FieldSelectors
ListTuplePuns
+ ImplicitStagePersistence
extensible fields:
diff --git a/testsuite/tests/splice-imports/ClassA.hs b/testsuite/tests/splice-imports/ClassA.hs
new file mode 100644
index 00000000000..1d847c5b18f
--- /dev/null
+++ b/testsuite/tests/splice-imports/ClassA.hs
@@ -0,0 +1,8 @@
+module ClassA where
+
+data X = X
+
+vx = X
+
+class C a where
+ x :: a -> a
diff --git a/testsuite/tests/splice-imports/InstanceA.hs b/testsuite/tests/splice-imports/InstanceA.hs
new file mode 100644
index 00000000000..1ec2383e1fc
--- /dev/null
+++ b/testsuite/tests/splice-imports/InstanceA.hs
@@ -0,0 +1,6 @@
+module InstanceA where
+
+import ClassA
+
+instance C X where
+ x = id
diff --git a/testsuite/tests/splice-imports/Makefile b/testsuite/tests/splice-imports/Makefile
new file mode 100644
index 00000000000..c59b522b2c2
--- /dev/null
+++ b/testsuite/tests/splice-imports/Makefile
@@ -0,0 +1,28 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Makefile for oneshot mode compilation tests
+
+.PHONY: SI08_oneshot SI09_oneshot SI10_oneshot clean
+
+# For SI08_oneshot (expected to fail)
+SI08_oneshot:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c ClassA.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c InstanceA.hs
+ ! "$(TEST_HC)" $(TEST_HC_OPTS) -c SI08.hs
+
+# For SI09_oneshot (expected to succeed)
+SI09_oneshot:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcThWayFlags) -c ClassA.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcThWayFlags) -c InstanceA.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcThWayFlags) -c SI09.hs
+
+# For SI10_oneshot (expected to succeed)
+SI10_oneshot:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c ClassA.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c InstanceA.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c SI10.hs
+
+clean:
+ rm -f *.o *.hi
diff --git a/testsuite/tests/splice-imports/SI01.hs b/testsuite/tests/splice-imports/SI01.hs
new file mode 100644
index 00000000000..8ae6b8d2a47
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI01.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI01 where
+
+-- Using a splice imported thing, inside an untyped and typed splice works
+import splice SI01A
+
+main :: IO ()
+main = $( sid [| pure () |]) >> $$( sid [|| pure () ||])
diff --git a/testsuite/tests/splice-imports/SI01A.hs b/testsuite/tests/splice-imports/SI01A.hs
new file mode 100644
index 00000000000..a1cf7bfd9f2
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI01A.hs
@@ -0,0 +1,3 @@
+module SI01A where
+
+sid = id
diff --git a/testsuite/tests/splice-imports/SI02.hs b/testsuite/tests/splice-imports/SI02.hs
new file mode 100644
index 00000000000..5ddd9e3fc82
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI02.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI02 where
+
+-- Splice importing a package module works
+import splice Prelude
+import Prelude
+
+main :: IO ()
+main = $(id [| pure () |])
diff --git a/testsuite/tests/splice-imports/SI03.hs b/testsuite/tests/splice-imports/SI03.hs
new file mode 100644
index 00000000000..aa2a873bf6e
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI03.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI03 where
+
+import SI01A
+
+-- You get an error message if you don't splice import `sid`.
+
+main :: IO ()
+main = $( sid [| pure () |]) >> $$( sid [|| pure () ||])
diff --git a/testsuite/tests/splice-imports/SI03.stderr b/testsuite/tests/splice-imports/SI03.stderr
new file mode 100644
index 00000000000..b097aef3ad0
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI03.stderr
@@ -0,0 +1,7 @@
+SI03.hs:10:11: error: [GHC-28914]
+ • Level error: ‘sid’ is bound at level 0 but used at level -1
+ Hint: quoting [| sid |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘SI01A’ at SI03.hs:5:1-12}
+ • In the untyped splice: $(sid [| pure () |])
+
diff --git a/testsuite/tests/splice-imports/SI04.hs b/testsuite/tests/splice-imports/SI04.hs
new file mode 100644
index 00000000000..9110f510138
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI04.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI04 where
+
+-- Importing `sid` twice at different levels works.
+import SI01A
+import splice SI01A
+
+main :: IO ()
+main = $( sid [| pure () |]) >> $$( sid [|| pure () ||])
diff --git a/testsuite/tests/splice-imports/SI05.hs b/testsuite/tests/splice-imports/SI05.hs
new file mode 100644
index 00000000000..0194aad323f
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI05.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI04 where
+
+-- Importing 'sid' from different places is ambiguous (even if it's not level ambiguous)
+import SI01A
+import splice SI05A
+
+main :: IO ()
+main = $( sid [| pure () |]) >> $$( sid [|| pure () ||])
diff --git a/testsuite/tests/splice-imports/SI05.stderr b/testsuite/tests/splice-imports/SI05.stderr
new file mode 100644
index 00000000000..d28cc78cc7d
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI05.stderr
@@ -0,0 +1,18 @@
+SI05.hs:10:11: error: [GHC-28914]
+ • Level error: ‘SI01A.sid’ is bound at level 0 but used at level -1
+ Hint: quoting [| SI01A.sid |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘SI01A’ at SI05.hs:6:1-12}
+ • In the untyped splice: $(sid [| pure () |])
+
+SI05.hs:10:11: error: [GHC-87543]
+ • Ambiguous occurrence ‘sid’.
+ It could refer to
+ either ‘SI01A.sid’,
+ imported from ‘SI01A’ at SI05.hs:6:1-12
+ (and originally defined at SI01A.hs:3:1-3),
+ or ‘SI05A.sid’,
+ imported from ‘SI05A’ at -1 at SI05.hs:7:1-19
+ (and originally defined at SI05A.hs:3:1-3).
+ • In the untyped splice: $(sid [| pure () |])
+
diff --git a/testsuite/tests/splice-imports/SI05A.hs b/testsuite/tests/splice-imports/SI05A.hs
new file mode 100644
index 00000000000..5f5c4a3ba6a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI05A.hs
@@ -0,0 +1,3 @@
+module SI05A where
+
+sid = id
diff --git a/testsuite/tests/splice-imports/SI06.hs b/testsuite/tests/splice-imports/SI06.hs
new file mode 100644
index 00000000000..cff3091bf15
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI06.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI06 where
+
+-- Splice imports work without TemplateHaskell
+import splice SI01A
+
+x = 5
diff --git a/testsuite/tests/splice-imports/SI07.hs b/testsuite/tests/splice-imports/SI07.hs
new file mode 100644
index 00000000000..94d007f3d0b
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI07.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI07 where
+
+-- --make mode, -fno-code, we need object code for SI05A but not for SI07A
+import SI07A
+import splice SI05A
+
+main :: IO ()
+main = $( sid [| pure () |]) >> $$( sid [|| pure () ||])
diff --git a/testsuite/tests/splice-imports/SI07.stderr b/testsuite/tests/splice-imports/SI07.stderr
new file mode 100644
index 00000000000..89690a63d51
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI07.stderr
@@ -0,0 +1,3 @@
+[1 of 3] Compiling SI05A ( SI05A.hs, SI05A.o, SI05A.dyn_o )
+[2 of 3] Compiling SI07A ( SI07A.hs, nothing )
+[3 of 3] Compiling SI07 ( SI07.hs, nothing )
diff --git a/testsuite/tests/splice-imports/SI07A.hs b/testsuite/tests/splice-imports/SI07A.hs
new file mode 100644
index 00000000000..6b93bac0224
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI07A.hs
@@ -0,0 +1 @@
+module SI07A where
diff --git a/testsuite/tests/splice-imports/SI08.hs b/testsuite/tests/splice-imports/SI08.hs
new file mode 100644
index 00000000000..7f2e5383093
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI08.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI08 where
+
+-- Instance is only available at level 0
+import InstanceA ()
+import splice ClassA
+import ClassA
+import splice Prelude (const)
+
+e :: X
+-- Uses a non-splice imported instance
+-- Used at levels 1 and 0
+e = $(const [| x vx |] (x vx))
diff --git a/testsuite/tests/splice-imports/SI08.stderr b/testsuite/tests/splice-imports/SI08.stderr
new file mode 100644
index 00000000000..d06f79012d7
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI08.stderr
@@ -0,0 +1,7 @@
+SI08.hs:14:25: error: [GHC-28914]
+ • Level error: instance for ‘C X’ is bound at level 0
+ but used at level -1
+ • In the second argument of ‘const’, namely ‘(x vx)’
+ In the expression: const [| x vx |] (x vx)
+ In the untyped splice: $(const [| x vx |] (x vx))
+
diff --git a/testsuite/tests/splice-imports/SI08_oneshot.stderr b/testsuite/tests/splice-imports/SI08_oneshot.stderr
new file mode 100644
index 00000000000..d06f79012d7
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI08_oneshot.stderr
@@ -0,0 +1,7 @@
+SI08.hs:14:25: error: [GHC-28914]
+ • Level error: instance for ‘C X’ is bound at level 0
+ but used at level -1
+ • In the second argument of ‘const’, namely ‘(x vx)’
+ In the expression: const [| x vx |] (x vx)
+ In the untyped splice: $(const [| x vx |] (x vx))
+
diff --git a/testsuite/tests/splice-imports/SI09.hs b/testsuite/tests/splice-imports/SI09.hs
new file mode 100644
index 00000000000..5f5fb5a0515
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI09.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI09 where
+
+import splice InstanceA ()
+import splice ClassA
+import splice Prelude
+
+e :: IO ()
+-- Using the instance only in a splice, and it's splice imported should work
+e = $(const [| pure () |] (x vx))
diff --git a/testsuite/tests/splice-imports/SI10.hs b/testsuite/tests/splice-imports/SI10.hs
new file mode 100644
index 00000000000..776a6e49032
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI10.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI09 where
+
+import InstanceA ()
+import splice ClassA
+import ClassA
+import splice Prelude
+
+e :: X
+-- Using the instance only at the normal level should work
+e = $(const [| x vx |] ())
diff --git a/testsuite/tests/splice-imports/SI13.hs b/testsuite/tests/splice-imports/SI13.hs
new file mode 100644
index 00000000000..fce4c996e6f
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI13.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI13 where
+
+import Language.Haskell.TH
+import quote Prelude
+
+-- A quote import allows usage of id inside the quote
+
+x :: Q Exp
+x = [| id |]
+
+
+
+
diff --git a/testsuite/tests/splice-imports/SI14.hs b/testsuite/tests/splice-imports/SI14.hs
new file mode 100644
index 00000000000..ba18e361c04
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI14.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI14 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+-- Deriving Lift doesn't work with ExplicitLevelImports
+
+data A = A deriving Lift
diff --git a/testsuite/tests/splice-imports/SI14.stderr b/testsuite/tests/splice-imports/SI14.stderr
new file mode 100644
index 00000000000..0b36f83e803
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI14.stderr
@@ -0,0 +1,5 @@
+SI14.hs:9:21: error: [GHC-86639]
+ • Can't make a derived instance of ‘Lift A’:
+ You need ImplicitStagePersistence to derive an instance for this class
+ • In the data type declaration for ‘A’
+
diff --git a/testsuite/tests/splice-imports/SI15.hs b/testsuite/tests/splice-imports/SI15.hs
new file mode 100644
index 00000000000..2abf519799b
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI15.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE NoImplicitStagePersistence #-}
+module SI15 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+-- Deriving Lift doesn't work with NoImplicitStagePersistence
+
+data A = A deriving Lift
+
diff --git a/testsuite/tests/splice-imports/SI15.stderr b/testsuite/tests/splice-imports/SI15.stderr
new file mode 100644
index 00000000000..c66d3b68a69
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI15.stderr
@@ -0,0 +1,5 @@
+SI15.hs:9:21: error: [GHC-86639]
+ • Can't make a derived instance of ‘Lift A’:
+ You need ImplicitStagePersistence to derive an instance for this class
+ • In the data type declaration for ‘A’
+
diff --git a/testsuite/tests/splice-imports/SI16.hs b/testsuite/tests/splice-imports/SI16.hs
new file mode 100644
index 00000000000..3bd2d626b0a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI16.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoImplicitStagePersistence #-}
+module SI16 where
+
+x = ()
+
+-- Testing variable quotes for top-level local definitions, disallowed with
+-- NoImplicitStagePersistnece
+
+foo = 'x
+
+
diff --git a/testsuite/tests/splice-imports/SI16.stderr b/testsuite/tests/splice-imports/SI16.stderr
new file mode 100644
index 00000000000..c958109b085
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI16.stderr
@@ -0,0 +1,6 @@
+SI16.hs:10:7: error: [GHC-28914]
+ • Level error: ‘x’ is bound at level 0 but used at level 1
+ Hint: quoting [| x |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the Template Haskell quotation: 'x
+
diff --git a/testsuite/tests/splice-imports/SI17.hs b/testsuite/tests/splice-imports/SI17.hs
new file mode 100644
index 00000000000..bf3453bfa9a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI17.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE NoImplicitStagePersistence #-}
+module SI17 where
+
+-- Testing a level correct program is accepted (variable quotes and expression quotes)
+boo = [| \a -> $(const [| a |] 'a) |]
diff --git a/testsuite/tests/splice-imports/SI18.hs b/testsuite/tests/splice-imports/SI18.hs
new file mode 100644
index 00000000000..dfe0e660eef
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI18.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE NoImplicitStagePersistence #-}
+module SI18 where
+
+-- Variable quotes for a locally bound identifier fails
+boo a = 'a
diff --git a/testsuite/tests/splice-imports/SI18.stderr b/testsuite/tests/splice-imports/SI18.stderr
new file mode 100644
index 00000000000..11252638252
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI18.stderr
@@ -0,0 +1,6 @@
+SI18.hs:7:9: error: [GHC-28914]
+ • Level error: ‘a’ is bound at level 0 but used at level 1
+ Hint: quoting [| a |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ • In the Template Haskell quotation: 'a
+
diff --git a/testsuite/tests/splice-imports/SI19.hs b/testsuite/tests/splice-imports/SI19.hs
new file mode 100644
index 00000000000..32f80e0284d
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI19.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI19 where
+
+import quote SI19A
+
+-- Quote imports work for variable quotes
+
+boo = 'foo
diff --git a/testsuite/tests/splice-imports/SI19A.hs b/testsuite/tests/splice-imports/SI19A.hs
new file mode 100644
index 00000000000..eeca48ed51f
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI19A.hs
@@ -0,0 +1,3 @@
+module SI19A where
+
+foo = ()
diff --git a/testsuite/tests/splice-imports/SI20.hs b/testsuite/tests/splice-imports/SI20.hs
new file mode 100644
index 00000000000..6c6c29c09cd
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI20.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI20 where
+
+import SI19A
+import splice SI19A
+
+boo = 'foo
diff --git a/testsuite/tests/splice-imports/SI20.stderr b/testsuite/tests/splice-imports/SI20.stderr
new file mode 100644
index 00000000000..88a8dcd3f23
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI20.stderr
@@ -0,0 +1,8 @@
+SI20.hs:9:7: error: [GHC-28914]
+ • Level error: ‘foo’ is bound at levels {-1, 0} but used at level 1
+ Hint: quoting [| foo |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘SI19A’ at -1 at SI20.hs:7:1-19,
+ imported from ‘SI19A’ at SI20.hs:6:1-12}
+ • In the Template Haskell quotation: 'foo
+
diff --git a/testsuite/tests/splice-imports/SI21.hs b/testsuite/tests/splice-imports/SI21.hs
new file mode 100644
index 00000000000..7a425d51ab1
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI21.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI21 where
+
+-- a is unbound, and apparently that should carry on working.
+boo = 'a
diff --git a/testsuite/tests/splice-imports/SI21.stderr b/testsuite/tests/splice-imports/SI21.stderr
new file mode 100644
index 00000000000..0d467fe7227
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI21.stderr
@@ -0,0 +1,4 @@
+SI21.hs:7:7: error: [GHC-76037]
+ • Not in scope: ‘a’
+ • In the Template Haskell quotation: 'a
+
diff --git a/testsuite/tests/splice-imports/SI22.hs b/testsuite/tests/splice-imports/SI22.hs
new file mode 100644
index 00000000000..20fa17adcac
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI22.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI22 where
+
+-- Self import causes a cycle error
+import splice SI22
diff --git a/testsuite/tests/splice-imports/SI22.stderr b/testsuite/tests/splice-imports/SI22.stderr
new file mode 100644
index 00000000000..19dde3acb8a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI22.stderr
@@ -0,0 +1,4 @@
+SI22.hs: error: [GHC-92213]
+ Module graph contains a cycle:
+ module ‘main:SI22’ (SI22.hs) imports itself
+
diff --git a/testsuite/tests/splice-imports/SI23.hs b/testsuite/tests/splice-imports/SI23.hs
new file mode 100644
index 00000000000..4277254af05
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI23.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI23 where
+
+import splice SI23A
+import splice Language.Haskell.TH.Syntax
+import SI23A
+
+main = print $(lift B)
diff --git a/testsuite/tests/splice-imports/SI23A.hs b/testsuite/tests/splice-imports/SI23A.hs
new file mode 100644
index 00000000000..5d7fca3cf27
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI23A.hs
@@ -0,0 +1,5 @@
+module SI23A where
+
+import Language.Haskell.TH.Syntax
+
+data B = B deriving (Lift, Show)
diff --git a/testsuite/tests/splice-imports/SI24.hs b/testsuite/tests/splice-imports/SI24.hs
new file mode 100644
index 00000000000..dfa0afeb4c7
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI24.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI24 where
+
+-- Identifiers can be used in variables
+
+splice = quote
+
+quote = splice
diff --git a/testsuite/tests/splice-imports/SI25.hs b/testsuite/tests/splice-imports/SI25.hs
new file mode 100644
index 00000000000..48355d76a4a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI25.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+module SI25 where
+
+-- Import specifically splice
+import splice SI25Helper
+import Language.Haskell.TH
+
+-- Test simple explicit level import with a splice
+test1 :: Q Exp
+test1 = $(nestedCode "hello")
+
+-- Test nested splices with explicit level imports
+-- This should fail, as nestedCode is only available at level -1
+test2 :: String
+test2 = $($(nestedCode "nested"))
diff --git a/testsuite/tests/splice-imports/SI25.stderr b/testsuite/tests/splice-imports/SI25.stderr
new file mode 100644
index 00000000000..e5bb8e34251
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI25.stderr
@@ -0,0 +1,9 @@
+SI25.hs:16:13: error: [GHC-28914]
+ • Level error: ‘nestedCode’ is bound at level -1
+ but used at level -2
+ Hint: quoting [| nestedCode |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24}
+ • In the untyped splice: $(nestedCode "nested")
+ In the untyped splice: $($(nestedCode "nested"))
+
diff --git a/testsuite/tests/splice-imports/SI25Helper.hs b/testsuite/tests/splice-imports/SI25Helper.hs
new file mode 100644
index 00000000000..f9d6dc08268
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI25Helper.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module SI25Helper where
+
+import Language.Haskell.TH
+
+genCode :: String -> Q Exp
+genCode s = [| s ++ " from helper" |]
+
+-- Function that will be used in an inner splice
+nestedCode :: String -> Q Exp
+nestedCode s = [| genCode s |]
diff --git a/testsuite/tests/splice-imports/SI26.hs b/testsuite/tests/splice-imports/SI26.hs
new file mode 100644
index 00000000000..0de80d84684
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI26.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+module SI26 where
+
+-- Test using 'quote' as a post-qualifier in imports
+import Prelude quote
+import Prelude quote qualified as P
+import quote Prelude qualified as P2
+
+-- Test using 'splice' as a post-qualifier in imports
+import Language.Haskell.TH.Syntax splice
+
+import splice Language.Haskell.TH.Syntax qualified as TH
+import Language.Haskell.TH.Syntax splice qualified as TH2
+
+-- Use the imported modules
+testQuote = [| id |]
+testQuote2 = [| P.id |]
+testQuote3 = [| P2.id |]
+
+testSplice = $(lift "Hello from splice")
+testSplice2 = $(TH.lift "Hello from splice2")
+testSplice3 = $(TH2.lift "Hello from splice3")
+
diff --git a/testsuite/tests/splice-imports/SI27.hs b/testsuite/tests/splice-imports/SI27.hs
new file mode 100644
index 00000000000..2d344695d42
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI27.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+
+module SI27 where
+
+-- This should fail: 'splice' used in both pre and post positions
+import splice Prelude splice
+import quote Prelude quote
+import splice Prelude quote
+import quote Prelude splice
diff --git a/testsuite/tests/splice-imports/SI27.stderr b/testsuite/tests/splice-imports/SI27.stderr
new file mode 100644
index 00000000000..051cefd46c2
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI27.stderr
@@ -0,0 +1,12 @@
+SI27.hs:7:23: error: [GHC-26105]
+ Multiple occurrences of a splice or quote keyword
+
+SI27.hs:8:22: error: [GHC-26105]
+ Multiple occurrences of a splice or quote keyword
+
+SI27.hs:9:23: error: [GHC-26105]
+ Multiple occurrences of a splice or quote keyword
+
+SI27.hs:10:22: error: [GHC-26105]
+ Multiple occurrences of a splice or quote keyword
+
diff --git a/testsuite/tests/splice-imports/SI28.hs b/testsuite/tests/splice-imports/SI28.hs
new file mode 100644
index 00000000000..2b8559954b3
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI28.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module SI28 where
+
+import quote Prelude -- Introduces Prelude at level 1
+
+main = $([| id |]) -- Used at level 0 (should be an error)
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI28.stderr b/testsuite/tests/splice-imports/SI28.stderr
new file mode 100644
index 00000000000..427e3ed889d
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI28.stderr
@@ -0,0 +1,8 @@
+SI28.hs:8:13: error: [GHC-28914]
+ • Level error: ‘id’ is bound at level 1 but used at level 0
+ Hint: quoting [| id |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘Prelude’ at 1 at SI28.hs:6:1-20}
+ • In the Template Haskell quotation: [| id |]
+ In the untyped splice: $([| id |])
+
diff --git a/testsuite/tests/splice-imports/SI29.hs b/testsuite/tests/splice-imports/SI29.hs
new file mode 100644
index 00000000000..4b4d1d8742a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI29.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module SI29 where
+
+import quote Prelude -- Introduces Prelude at level 1
+import Prelude
+
+-- Interesting case: An instance for a wired-in type, that should always be available
+-- since we don't require level checking for the wired-in type itself.
+main = $([| id |])
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI29.stderr b/testsuite/tests/splice-imports/SI29.stderr
new file mode 100644
index 00000000000..99611ad1525
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI29.stderr
@@ -0,0 +1,8 @@
+SI29.hs:11:10: error: [GHC-28914]
+ • Level error:
+ instance for ‘GHC.Internal.TH.Syntax.Quote
+ GHC.Internal.TH.Syntax.Q’
+ is bound at levels {0, 1} but used at level -1
+ • In the expression: [| id |]
+ In the untyped splice: $([| id |])
+
diff --git a/testsuite/tests/splice-imports/SI30.script b/testsuite/tests/splice-imports/SI30.script
new file mode 100644
index 00000000000..1a5a117eb38
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI30.script
@@ -0,0 +1 @@
+1 + 1
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI30.stdout b/testsuite/tests/splice-imports/SI30.stdout
new file mode 100644
index 00000000000..0cfbf08886f
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI30.stdout
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/splice-imports/SI31.script b/testsuite/tests/splice-imports/SI31.script
new file mode 100644
index 00000000000..7068c238c6f
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI31.script
@@ -0,0 +1,2 @@
+-- Failure, since explicit level imports is on
+$(id [| () |])
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI31.stderr b/testsuite/tests/splice-imports/SI31.stderr
new file mode 100644
index 00000000000..99715dc92d1
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI31.stderr
@@ -0,0 +1,7 @@
+<interactive>:2:3: error: [GHC-28914]
+ • Level error: ‘id’ is bound at level 0 but used at level -1
+ Hint: quoting [| id |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘Prelude’}
+ • In the untyped splice: $(id [| () |])
+
diff --git a/testsuite/tests/splice-imports/SI32.script b/testsuite/tests/splice-imports/SI32.script
new file mode 100644
index 00000000000..469afa2ae06
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI32.script
@@ -0,0 +1,5 @@
+-- Success case with explicit level imports
+import Language.Haskell.TH
+import splice Data.Function (id)
+
+$(id [| () |])
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI32.stdout b/testsuite/tests/splice-imports/SI32.stdout
new file mode 100644
index 00000000000..6a452c185a8
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI32.stdout
@@ -0,0 +1 @@
+()
diff --git a/testsuite/tests/splice-imports/SI33.script b/testsuite/tests/splice-imports/SI33.script
new file mode 100644
index 00000000000..76899c8f210
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI33.script
@@ -0,0 +1,8 @@
+-- Test using both normal and splice level imports with Template Haskell
+import Language.Haskell.TH
+-- Using two imports here tests the iiSubsumes function
+import splice Data.Function (id)
+import Data.Function (id)
+
+-- Use the splice-level 'id' in the splice and normal-level 'on' in the quote
+$(id [| id () |])
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI33.stdout b/testsuite/tests/splice-imports/SI33.stdout
new file mode 100644
index 00000000000..6a452c185a8
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI33.stdout
@@ -0,0 +1 @@
+()
diff --git a/testsuite/tests/splice-imports/SI34.hs b/testsuite/tests/splice-imports/SI34.hs
new file mode 100644
index 00000000000..12f0dd40c01
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI34.hs
@@ -0,0 +1,11 @@
+module SI34 where
+
+-- Compiling SI34 @ R, requires SI34M2 @ R, which requires SI34M1 @ R,
+-- but NOT SI34M1 @ C or SI34M2 @ C due to ImplicitStagePersistence + TemplateHaskellQuotes
+import SI34M2
+
+-- Uses the MkT constructor indirectly through SI34M2.makeMkT
+foo = makeMkT 42
+
+-- Uses the wrapper type from SI34M2
+bar = wrapT (makeMkT 100)
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI34.stderr b/testsuite/tests/splice-imports/SI34.stderr
new file mode 100644
index 00000000000..b810dbee6d2
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI34.stderr
@@ -0,0 +1,3 @@
+[1 of 3] Compiling SI34M1 ( SI34M1.hs, nothing )
+[2 of 3] Compiling SI34M2 ( SI34M2.hs, nothing )
+[3 of 3] Compiling SI34 ( SI34.hs, nothing )
diff --git a/testsuite/tests/splice-imports/SI34M1.hs b/testsuite/tests/splice-imports/SI34M1.hs
new file mode 100644
index 00000000000..5576f214341
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI34M1.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE ImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module SI34M1 where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data T = MkT Int
+ deriving Show
+
+instance Lift T where
+ lift (MkT n) = [| MkT $(lift n) |]
+ liftTyped (MkT n) = [|| MkT $$(liftTyped n) ||]
diff --git a/testsuite/tests/splice-imports/SI34M2.hs b/testsuite/tests/splice-imports/SI34M2.hs
new file mode 100644
index 00000000000..60cf42c6c43
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI34M2.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE ImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module SI34M2 (
+ makeMkT,
+ TWrapper(..),
+ wrapT
+) where
+
+import SI34M1
+import Language.Haskell.TH.Syntax
+
+-- A wrapper for T
+data TWrapper = WrapT T
+ deriving Show
+
+-- Create a MkT with the given Int
+makeMkT :: Int -> T
+makeMkT = MkT
+
+-- Wrap a T in a TWrapper
+wrapT :: T -> TWrapper
+wrapT = WrapT
+
+-- Quote functions for TWrapper
+instance Lift TWrapper where
+ lift (WrapT t) = [| WrapT $(lift t) |]
+ liftTyped (WrapT t) = [|| WrapT $$(liftTyped t) ||]
diff --git a/testsuite/tests/splice-imports/SI35.hs b/testsuite/tests/splice-imports/SI35.hs
new file mode 100644
index 00000000000..590601bf30e
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI35.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE RecordWildCards #-}
+module Main where
+
+import GHC
+import GHC.Driver.Session
+import GHC.Driver.Monad
+import GHC.Driver.Make (load', summariseFile)
+import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModSummary
+import GHC.Unit.Types
+import GHC.Unit.Module.ModIface
+import GHC.Unit.Module
+import GHC.Unit.Module.ModNodeKey
+import GHC.Types.SourceFile
+import System.Environment
+import Control.Monad (void, when)
+import Data.Maybe (fromJust)
+import Control.Exception (ExceptionWithContext(..), SomeException)
+import Control.Monad.Catch (handle, throwM)
+import Control.Exception.Context
+import GHC.Utils.Outputable
+import GHC.Unit.Home
+import GHC.Driver.Env
+import Data.List (sort)
+import GHC.Driver.MakeFile
+import GHC.Data.Maybe
+import GHC.Unit.Module.Stage
+import GHC.Data.Graph.Directed.Reachability
+import GHC.Utils.Trace
+import GHC.Unit.Module.Graph
+
+main :: IO ()
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) ->
+ liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do
+
+ -- Set up session
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ hsc_env <- getSession
+ setSession $ hscSetActiveUnitId mainUnitId hsc_env
+
+ -- Get ModSummary for our test module
+ msA <- getModSummaryFromTarget "SI35A.hs"
+
+ -- Define NodeKey
+ let keyA = NodeKey_Module (msKey msA)
+ edgeA = mkNormalEdge keyA
+
+ -- Define ModuleNodeInfo
+ let infoA_compile = ModuleNodeCompile msA
+
+ -- Define the complete node
+ let nodeA_compile = ModuleNode [] infoA_compile
+
+ -- This test checks that a module required at compile stage invokes a
+ -- depedency on the runstage of itself when using TemplateHaskellQuotes.
+
+ -- This is hard to test with a normal compiler invocation as GHC does not
+ -- not distinguish very easily these two stages.
+ let (ri, to_node) = mkStageDeps [nodeA_compile]
+ let reachable = allReachable ri (expectJust $ to_node (keyA, CompileStage))
+ let reachable_nodes = map stageSummaryNodeSummary reachable
+
+ if (keyA, RunStage) `elem` reachable_nodes
+ then return ()
+ else do
+ liftIO $ putStrLn "Test failed -- (keyA, RunStage) not reachable"
+ pprTraceM "reachable_nodes" (ppr reachable_nodes)
+ pprTraceM "reachable" (ppr (reachabilityIndexMembers ri))
+
+ where
+ -- Helper to get ModSummary from a target file
+ getModSummaryFromTarget :: FilePath -> Ghc ModSummary
+ getModSummaryFromTarget file = do
+ hsc_env <- getSession
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ return ms
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI35A.hs b/testsuite/tests/splice-imports/SI35A.hs
new file mode 100644
index 00000000000..d5f705358b7
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI35A.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module SI35A where
+
+-- Define a type for use in Template Haskell
+data T = MkT Int
+
+-- Helper function to construct a T
+mkT :: Int -> T
+mkT = MkT
+
+-- A function that creates a quoted expression using T
+quotedT :: Int -> Q Exp
+quotedT n = [| mkT n |]
+
+-- Another quoted expression function
+quotedAdd :: Q Exp
+quotedAdd = [| \x y -> x + y :: Int |]
+
+-- Show instance
+instance Show T where
+ show (MkT n) = "MkT " ++ show n
\ No newline at end of file
diff --git a/testsuite/tests/splice-imports/SI36.hs b/testsuite/tests/splice-imports/SI36.hs
new file mode 100644
index 00000000000..895898a6a69
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# LANGUAGE TypeApplications #-}
+
+module SI36 where
+
+import Data.Kind ( Constraint )
+
+import SI36_A
+import SI36_C1
+import quote SI36_C2
+import splice SI36_C3
+
+need :: forall (c :: Constraint). c => ()
+need = ()
+
+c1B1, c2B2, c3B3 :: ()
+c1B1 = need @( C1 "B1" ) -- OK: normal import of C1, which normal imports B1 which provides it
+c2B2 = need @( C2 "B2" ) -- } NO: not available at any levels, because modules only export
+c3B3 = need @( C3 "B3" ) -- } instances at level 0
+
+c1C1, c1C2, c1C3 :: ()
+c1C1 = need @( C1 "C1" ) -- OK: available at level 0
+c1C2 = need @( C1 "C2" ) -- NO: only at level 1
+c1C3 = need @( C1 "C3" ) -- NO: only at level -1
+
+c2C1, c2C2, c2C3 :: ()
+c2C1 = need @( C2 "C1" ) -- OK
+c2C2 = need @( C2 "C2" ) -- NO: only at level 1
+c2C3 = need @( C2 "C3" ) -- NO: only at level -1
+
+c3C1, c3C2, c3C3 :: ()
+c3C1 = need @( C3 "C1" ) -- OK
+c3C2 = need @( C3 "C2" ) -- NO: only at level 1
+c3C3 = need @( C3 "C3" ) -- NO: only at level -1
diff --git a/testsuite/tests/splice-imports/SI36.stderr b/testsuite/tests/splice-imports/SI36.stderr
new file mode 100644
index 00000000000..0ba61391ce4
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36.stderr
@@ -0,0 +1,48 @@
+SI36.hs:21:8: error: [GHC-28914]
+ • Level error: instance for ‘C2 "B2"’ is bound at levels {}
+ but used at level 0
+ • In the expression: need @(C2 "B2")
+ In an equation for ‘c2B2’: c2B2 = need @(C2 "B2")
+
+SI36.hs:22:8: error: [GHC-28914]
+ • Level error: instance for ‘C3 "B3"’ is bound at levels {}
+ but used at level 0
+ • In the expression: need @(C3 "B3")
+ In an equation for ‘c3B3’: c3B3 = need @(C3 "B3")
+
+SI36.hs:26:8: error: [GHC-28914]
+ • Level error: instance for ‘C1 "C2"’ is bound at level 1
+ but used at level 0
+ • In the expression: need @(C1 "C2")
+ In an equation for ‘c1C2’: c1C2 = need @(C1 "C2")
+
+SI36.hs:27:8: error: [GHC-28914]
+ • Level error: instance for ‘C1 "C3"’ is bound at level -1
+ but used at level 0
+ • In the expression: need @(C1 "C3")
+ In an equation for ‘c1C3’: c1C3 = need @(C1 "C3")
+
+SI36.hs:31:8: error: [GHC-28914]
+ • Level error: instance for ‘C2 "C2"’ is bound at level 1
+ but used at level 0
+ • In the expression: need @(C2 "C2")
+ In an equation for ‘c2C2’: c2C2 = need @(C2 "C2")
+
+SI36.hs:32:8: error: [GHC-28914]
+ • Level error: instance for ‘C2 "C3"’ is bound at level -1
+ but used at level 0
+ • In the expression: need @(C2 "C3")
+ In an equation for ‘c2C3’: c2C3 = need @(C2 "C3")
+
+SI36.hs:36:8: error: [GHC-28914]
+ • Level error: instance for ‘C3 "C2"’ is bound at level 1
+ but used at level 0
+ • In the expression: need @(C3 "C2")
+ In an equation for ‘c3C2’: c3C2 = need @(C3 "C2")
+
+SI36.hs:37:8: error: [GHC-28914]
+ • Level error: instance for ‘C3 "C3"’ is bound at level -1
+ but used at level 0
+ • In the expression: need @(C3 "C3")
+ In an equation for ‘c3C3’: c3C3 = need @(C3 "C3")
+
diff --git a/testsuite/tests/splice-imports/SI36_A.hs b/testsuite/tests/splice-imports/SI36_A.hs
new file mode 100644
index 00000000000..cb98b21e763
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_A.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+module SI36_A ( C1, C2, C3 ) where
+
+import Data.Kind
+import GHC.TypeLits
+
+type C1 :: Symbol -> Constraint
+class C1 s
+
+type C2 :: Symbol -> Constraint
+class C2 s
+
+type C3 :: Symbol -> Constraint
+class C3 s
diff --git a/testsuite/tests/splice-imports/SI36_B1.hs b/testsuite/tests/splice-imports/SI36_B1.hs
new file mode 100644
index 00000000000..13b52cb7e26
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_B1.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_B1 where
+
+import SI36_A ( C1 )
+
+instance C1 "B1"
diff --git a/testsuite/tests/splice-imports/SI36_B2.hs b/testsuite/tests/splice-imports/SI36_B2.hs
new file mode 100644
index 00000000000..4974f52a1e5
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_B2.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_B2 where
+
+import SI36_A ( C2 )
+
+instance C2 "B2"
diff --git a/testsuite/tests/splice-imports/SI36_B3.hs b/testsuite/tests/splice-imports/SI36_B3.hs
new file mode 100644
index 00000000000..de4789caa01
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_B3.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_B3 where
+
+import SI36_A ( C3 )
+
+instance C3 "B3"
diff --git a/testsuite/tests/splice-imports/SI36_C1.hs b/testsuite/tests/splice-imports/SI36_C1.hs
new file mode 100644
index 00000000000..5541b57dbe4
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_C1.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_C1 where
+
+import SI36_A
+
+import SI36_B1
+import splice SI36_B2
+import quote SI36_B3
+
+instance C1 "C1"
+instance C2 "C1"
+instance C3 "C1"
diff --git a/testsuite/tests/splice-imports/SI36_C2.hs b/testsuite/tests/splice-imports/SI36_C2.hs
new file mode 100644
index 00000000000..72382e7e368
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_C2.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_C2 where
+
+import SI36_A
+
+import SI36_B1
+import splice SI36_B2
+import quote SI36_B3
+
+instance C1 "C2"
+instance C2 "C2"
+instance C3 "C2"
diff --git a/testsuite/tests/splice-imports/SI36_C3.hs b/testsuite/tests/splice-imports/SI36_C3.hs
new file mode 100644
index 00000000000..a9bb7514f7a
--- /dev/null
+++ b/testsuite/tests/splice-imports/SI36_C3.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module SI36_C3 where
+
+import SI36_A
+
+import SI36_B1
+import splice SI36_B2
+import quote SI36_B3
+
+instance C1 "C3"
+instance C2 "C3"
+instance C3 "C3"
diff --git a/testsuite/tests/splice-imports/all.T b/testsuite/tests/splice-imports/all.T
new file mode 100644
index 00000000000..87f4a97caab
--- /dev/null
+++ b/testsuite/tests/splice-imports/all.T
@@ -0,0 +1,48 @@
+def check_nothing(actual_file, normaliser):
+ actual_raw = read_no_crs(actual_file)
+ return ("Nothing" in actual_raw)
+
+
+test('SI01', normal, multimod_compile, ['SI01', '-v0'])
+test('SI02', normal, multimod_compile, ['SI02', '-v0'])
+test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0'])
+test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0'])
+test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0'])
+test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0'])
+test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
+# Instance tests
+test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0'])
+test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0'])
+test('SI10', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI10', '-v0'])
+# Instance tests with oneshot mode
+test('SI08_oneshot', [extra_files(["ClassA.hs", "InstanceA.hs", "SI08.hs"])], makefile_test, [])
+test('SI09_oneshot', [extra_files(["ClassA.hs", "InstanceA.hs", "SI09.hs"])], makefile_test, [])
+test('SI10_oneshot', [extra_files(["ClassA.hs", "InstanceA.hs", "SI10.hs"])], makefile_test, [])
+test('SI13', normal, multimod_compile, ['SI13', '-v0'])
+test('SI14', normal, compile_fail, [''])
+test('SI15', normal, compile_fail, [''])
+test('SI16', normal, compile_fail, [''])
+test('SI17', normal, compile, [''])
+test('SI18', normal, compile_fail, [''])
+test('SI19', extra_files(["SI19A.hs"]), multimod_compile, ['SI19', '-v0'])
+test('SI20', extra_files(["SI19A.hs"]), multimod_compile_fail, ['SI20', '-v0'])
+test('SI21', normal, multimod_compile_fail, ['SI21', '-v0'])
+test('SI22', normal, multimod_compile_fail, ['SI22', '-v0'])
+test('SI23', extra_files(["SI23A.hs"]), multimod_compile, ['SI23', '-v0'])
+test('SI24', normal, compile, [''])
+test('SI25', extra_files(["SI25Helper.hs"]), multimod_compile_fail, ['SI25', '-v0'])
+test('SI26', normal, compile, [''])
+test('SI27', normal, compile_fail, [''])
+test('SI28', normal, compile_fail, [''])
+test('SI29', normal, compile_fail, [''])
+test('SI30', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports")], ghci_script, ['SI30.script'])
+test('SI31', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI31.script'])
+test('SI32', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI32.script'])
+test('SI33', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI33.script'])
+test('SI34', [extra_files(["SI34M1.hs", "SI34M2.hs"])], multimod_compile, ['SI34', '-fno-code'])
+test('SI35',
+ [extra_run_opts(f'"{config.libdir}"'),
+ extra_files(['SI35A.hs'])],
+ compile_and_run,
+ ['-package ghc'])
+test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0'])
diff --git a/testsuite/tests/th/T16976z.stderr b/testsuite/tests/th/T16976z.stderr
index 9226723ee22..6613a979fc0 100644
--- a/testsuite/tests/th/T16976z.stderr
+++ b/testsuite/tests/th/T16976z.stderr
@@ -1,5 +1,6 @@
-T16976z.hs:7:20: error: [GHC-57695]
- • Stage error: the non-top-level quoted name 'str
- must be used at the same stage at which it is bound.
+T16976z.hs:7:20: error: [GHC-28914]
+ • Level error: ‘str’ is bound at level -1 but used at level 0
+ Hint: quoting [| str |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
• In the Template Haskell quotation: 'str
diff --git a/testsuite/tests/th/T17820a.stderr b/testsuite/tests/th/T17820a.stderr
index 81126d1aa52..2e0da0c138a 100644
--- a/testsuite/tests/th/T17820a.stderr
+++ b/testsuite/tests/th/T17820a.stderr
@@ -1,5 +1,5 @@
+T17820a.hs:7:17: error: [GHC-28914]
+ Level error: ‘C’ is bound at level 0 but used at level -1
+ Hint: quoting [| C |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
-T17820a.hs:7:17: error: [GHC-18157]
- GHC stage restriction:
- ‘C’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820b.stderr b/testsuite/tests/th/T17820b.stderr
index 4ebe1f60b98..5b663fd8a94 100644
--- a/testsuite/tests/th/T17820b.stderr
+++ b/testsuite/tests/th/T17820b.stderr
@@ -1,5 +1,5 @@
+T17820b.hs:7:17: error: [GHC-28914]
+ Level error: ‘f’ is bound at level 0 but used at level -1
+ Hint: quoting [| f |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
-T17820b.hs:7:17: error: [GHC-18157]
- GHC stage restriction:
- ‘f’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820c.stderr b/testsuite/tests/th/T17820c.stderr
index d6d0bcd42f7..dd2f6cca4a0 100644
--- a/testsuite/tests/th/T17820c.stderr
+++ b/testsuite/tests/th/T17820c.stderr
@@ -1,5 +1,5 @@
+T17820c.hs:8:18: error: [GHC-28914]
+ Level error: ‘meth’ is bound at level 0 but used at level -1
+ Hint: quoting [| meth |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
-T17820c.hs:8:18: error: [GHC-18157]
- GHC stage restriction:
- ‘meth’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820d.stderr b/testsuite/tests/th/T17820d.stderr
index a75b5d2f237..0a48c703f9b 100644
--- a/testsuite/tests/th/T17820d.stderr
+++ b/testsuite/tests/th/T17820d.stderr
@@ -1,6 +1,7 @@
T17820d.hs:6:38: error: [GHC-28914]
- • Stage error: ‘foo’ is bound at stage 2 but used at stage 1
- Hint: quoting [| foo |] or an enclosing expression would allow the quotation to be used in an earlier stage
+ • Level error: ‘foo’ is bound at level 1 but used at level 0
+ Hint: quoting [| foo |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
• In the untyped splice: $(const [| 0 |] foo)
In the Template Haskell quotation:
[d| data D = MkD {foo :: Int}
diff --git a/testsuite/tests/th/T17820e.stderr b/testsuite/tests/th/T17820e.stderr
index a1984c126a0..6afa14edcc6 100644
--- a/testsuite/tests/th/T17820e.stderr
+++ b/testsuite/tests/th/T17820e.stderr
@@ -1,5 +1,5 @@
+T17820e.hs:9:17: error: [GHC-28914]
+ Level error: ‘C’ is bound at level 0 but used at level -1
+ Hint: quoting [| C |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
-T17820e.hs:9:17: error: [GHC-18157]
- GHC stage restriction:
- ‘C’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
diff --git a/testsuite/tests/th/T21547.stderr b/testsuite/tests/th/T21547.stderr
index 3a72df5810d..0a569095357 100644
--- a/testsuite/tests/th/T21547.stderr
+++ b/testsuite/tests/th/T21547.stderr
@@ -1,8 +1,8 @@
-T21547.hs:9:14: error: [GHC-18157]
- • GHC stage restriction:
- instance for ‘ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable
- T’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
+T21547.hs:9:14: error: [GHC-28914]
+ • Level error:
+ instance for ‘ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable
+ T’
+ is bound at level 0 but used at level -1
• In the expression: foo [|| T () ||]
In the typed Template Haskell splice: $$(foo [|| T () ||])
In the expression: $$(foo [|| T () ||])
diff --git a/testsuite/tests/th/T23829_hasty.stderr b/testsuite/tests/th/T23829_hasty.stderr
index c6d19d2501a..75e4a63ede2 100644
--- a/testsuite/tests/th/T23829_hasty.stderr
+++ b/testsuite/tests/th/T23829_hasty.stderr
@@ -1,6 +1,6 @@
-
-T23829_hasty.hs:8:26: error: [GHC-18157]
- • GHC stage restriction:
- ‘ty’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
+T23829_hasty.hs:8:26: error: [GHC-28914]
+ • Level error: ‘ty’ is bound at level 0 but used at level -1
+ Hint: quoting [| ty |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
• In the untyped splice: $ty
+
diff --git a/testsuite/tests/th/T23829_hasty_b.stderr b/testsuite/tests/th/T23829_hasty_b.stderr
index e1307dd2bef..d6e6a3631a5 100644
--- a/testsuite/tests/th/T23829_hasty_b.stderr
+++ b/testsuite/tests/th/T23829_hasty_b.stderr
@@ -1,6 +1,7 @@
T23829_hasty_b.hs:8:42: error: [GHC-28914]
- • Stage error: ‘ty’ is bound at stage 2 but used at stage 1
- Hint: quoting [t| ty |] or an enclosing expression would allow the quotation to be used in an earlier stage
+ • Level error: ‘ty’ is bound at level 1 but used at level 0
+ Hint: quoting [t| ty |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
• In the untyped splice: $ty
In the Template Haskell quotation:
[t| forall (ty :: TypeQ). Proxy $ty |]
diff --git a/testsuite/tests/th/T23829_tardy.ghc.stderr b/testsuite/tests/th/T23829_tardy.ghc.stderr
index 552fa73b592..f0ad316c1a5 100644
--- a/testsuite/tests/th/T23829_tardy.ghc.stderr
+++ b/testsuite/tests/th/T23829_tardy.ghc.stderr
@@ -1,11 +1,11 @@
[1 of 2] Compiling Main ( T23829_tardy.hs, T23829_tardy.o )
+T23829_tardy.hs:9:15: warning: [GHC-86357] [-Wbadly-levelled-types (in -Wdefault)]
+ Badly levelled type: a is bound at level 0 but used at level 1
-T23829_tardy.hs:9:15: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
- Badly staged type: a is bound at stage 1 but used at stage 2
+T23829_tardy.hs:12:19: warning: [GHC-86357] [-Wbadly-levelled-types (in -Wdefault)]
+ Badly levelled type: a is bound at level 0 but used at level 1
-T23829_tardy.hs:12:19: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
- Badly staged type: a is bound at stage 1 but used at stage 2
+T23829_tardy.hs:15:20: warning: [GHC-86357] [-Wbadly-levelled-types (in -Wdefault)]
+ Badly levelled type: a is bound at level 0 but used at level 1
-T23829_tardy.hs:15:20: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
- Badly staged type: a is bound at stage 1 but used at stage 2
[2 of 2] Linking T23829_tardy
diff --git a/testsuite/tests/th/T5795.stderr b/testsuite/tests/th/T5795.stderr
index bc0dd2ef0f5..afe8aa0bff5 100644
--- a/testsuite/tests/th/T5795.stderr
+++ b/testsuite/tests/th/T5795.stderr
@@ -1,6 +1,6 @@
-
-T5795.hs:9:7: error: [GHC-18157]
- • GHC stage restriction:
- ‘ty’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
+T5795.hs:9:7: error: [GHC-28914]
+ • Level error: ‘ty’ is bound at level 0 but used at level -1
+ Hint: quoting [| ty |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
• In the untyped splice: $ty
+
diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr
index 680e1ac150e..9078f349bef 100644
--- a/testsuite/tests/th/TH_Roles2.stderr
+++ b/testsuite/tests/th/TH_Roles2.stderr
@@ -2,7 +2,8 @@ TYPE CONSTRUCTORS
data type T{2} :: forall k. k -> *
roles nominal representational
Dependent modules: []
-Dependent packages: [base-4.20.0.0, template-haskell-2.22.1.0]
+Dependent packages: [(normal, base-4.21.0.0),
+ (normal, template-haskell-2.23.0.0)]
==================== Typechecker ====================
TH_Roles2.$tcT
diff --git a/testsuite/tests/typecheck/should_compile/T12763.stderr b/testsuite/tests/typecheck/should_compile/T12763.stderr
index 648ebe25f32..13f9a0ced2e 100644
--- a/testsuite/tests/typecheck/should_compile/T12763.stderr
+++ b/testsuite/tests/typecheck/should_compile/T12763.stderr
@@ -8,4 +8,4 @@ COERCION AXIOMS
CLASS INSTANCES
instance C Int -- Defined at T12763.hs:9:10
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/testsuite/tests/typecheck/should_compile/T18406b.stderr b/testsuite/tests/typecheck/should_compile/T18406b.stderr
index 1bc3b20e512..8419beda86f 100644
--- a/testsuite/tests/typecheck/should_compile/T18406b.stderr
+++ b/testsuite/tests/typecheck/should_compile/T18406b.stderr
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
COERCION AXIOMS
axiom Bug.N:C :: forall a b. C a b = a -> a
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Bug.$tcC
diff --git a/testsuite/tests/typecheck/should_compile/T18529.stderr b/testsuite/tests/typecheck/should_compile/T18529.stderr
index 305665c766e..24ec5e1096c 100644
--- a/testsuite/tests/typecheck/should_compile/T18529.stderr
+++ b/testsuite/tests/typecheck/should_compile/T18529.stderr
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
COERCION AXIOMS
axiom Bug.N:C :: forall a b. C a b = a -> b -> ()
Dependent modules: []
-Dependent packages: [base-4.20.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
==================== Typechecker ====================
Bug.$tcC
diff --git a/testsuite/tests/typecheck/should_compile/T21023.stderr b/testsuite/tests/typecheck/should_compile/T21023.stderr
index 5a21342a4e2..02b23d61ace 100644
--- a/testsuite/tests/typecheck/should_compile/T21023.stderr
+++ b/testsuite/tests/typecheck/should_compile/T21023.stderr
@@ -2,4 +2,4 @@ TYPE SIGNATURES
f :: forall {a}. a -> (a, Integer)
x :: Integer
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [(normal, base-4.21.0.0)]
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 6988128ec50..1dfbb0fda9e 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1605,7 +1605,7 @@ instance ExactPrint (ImportDecl GhcPs) where
= (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} }
exact (ImportDecl (XImportDeclPass ann msrc impl)
- modname mpkg src safeflag qualFlag mAs hiding) = do
+ modname mpkg src st safeflag qualFlag mAs hiding) = do
ann0 <- markLensFun' ann limportDeclAnnImport markEpToken
let (EpAnn _anc an _cs) = ann0
@@ -1667,7 +1667,7 @@ instance ExactPrint (ImportDecl GhcPs) where
}
return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl)
- modname' mpkg src safeflag qualFlag mAs' hiding')
+ modname' mpkg src st safeflag qualFlag mAs' hiding')
-- ---------------------------------------------------------------------
diff --git a/utils/count-deps/Main.hs b/utils/count-deps/Main.hs
index 1b249047d58..798fd712e33 100644
--- a/utils/count-deps/Main.hs
+++ b/utils/count-deps/Main.hs
@@ -80,4 +80,4 @@ calcDeps modName libdir =
mkModule ghcUnitId = Module (stringToUnit ghcUnitId)
modDeps :: ModIface -> [ModuleName]
- modDeps mi = map (gwib_mod . snd) $ Set.toList $ dep_direct_mods (mi_deps mi)
+ modDeps mi = map (gwib_mod . (\(_, _, mn) -> mn)) $ Set.toList $ dep_direct_mods (mi_deps mi)
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d5261d6e686..dce0edd1fc6 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -243,6 +243,8 @@ classify tok =
ITsignature -> TkKeyword
ITdependency -> TkKeyword
ITrequires -> TkKeyword
+ ITsplice -> TkKeyword
+ ITquote -> TkKeyword
ITinline_prag{} -> TkPragma
ITopaque_prag{} -> TkPragma
ITspec_prag{} -> TkPragma
--
GitLab