diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 2701cb7aec3cb42419125a614b2afb010b0f26e9..4c5ccd07a06cf9e6827c8e457a1139c1fe56b450 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 a8d76b2a5b609ffc9307f09574b0dcf4a262bc9d..56317aa4af0f3e3aefa7c644403a233e0fc0f82f 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 9a098efec2bfcf8578cdf1f20eab36e3b318614d..ddbd21fd19def5d0ae0ce0a1c3c09e05212a40fe 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 7f55db8e40409671cde28d1af4b143212660cd00..dafe1f834dca1b6b196810836cda4a379e3eeef3 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 c3682314b2000651f2d606b89b4e769b11912545..7973b83ee68bf490c7f53133c1a1077975a6e1cc 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 79ff8de6afc72b3f12baad5d88856780c8b4932b..0efa9b539d717123a016bd5bd4762dfe25ce59b3 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 c3c53f1e85cff93a661ade3f523fdb7106552588..da026b0140008625aa77a9542e17c8dd6e101030 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 9c081d08b072b49aa83082fdc4acdc77c9b79bfc..2b3bbdb7293a1b24495784dd34d5d08376a41ec6 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 ed66fec38480a3e22f7ff0d1b89a2067c10e2fa3..ea01b4e10fce170b88302a08c888f6c78ff8077d 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 afafd55d6d9324764870b46d5d7154f43dba0be2..75244d20bf0cc70177431479d648377c0faa5b1f 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 dcd0a151301e19e770d298f1066b343cecb61652..aeed58acaafaeb6cd02f4cd90f24a657c434274a 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 3db8fe5c617edd5ffea36aaae75755e3595a6486..1f640156b2345db00c9af0d7b47f210b7ff2c41e 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 7d15fb3a590da3fcd8449a1f2c7139354ffdc4c6..a65eb39cbfd4fe29ffb625440c03a806b5d3b15c 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 9553e4544e36324c32d88494a8956e1d736bdcb5..307124fdc950c8484ac18063b9540f5c8fd89c90 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 171a1026f7d75e3bbc8bc26bb4553cf17ae1ade2..58bacbaf0517e504f99de30b39d6f356a65afc60 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 47650862a3e81149515e73a5388cb114d37654fb..8600601fd77123c07cf91b341232e9f958cafb72 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 8419ecebc1a8403e50177585a223b88b1b83b1db..c2241f72d9f6838c06d7bfd72976c805536663ac 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 14357cad6b696aaa6b01e7a107ff940c5b076408..5fd7c748eb03c602922fb5e0bb73b1c4b0f7bd24 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 a5089f3d7c8c5513c702da3873e95518bfe471f4..3a0278bbf830a1cb61ae7ea996ce515797178373 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 5cc3c3f8bf8db6bd2868c99bf155d99df037cbc7..d7b7b6f776657094c968f277fca21781fc624c2d 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 1c3f2f86a7a6f8d905c236a25350f04c5e0d266c..c3cabb5ea9eaebb82fc55c13f05578c0141023c7 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 e92a6f6349065184c770410497033722db6257d0..64412c9e37e90b479d0f744c38347d14998f4e0a 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 12bdfe6c897b1382ae20a6b4ce0ecbaa06764ada..0fcd2c4e5939adca451cc4c6a6f9e6eaa1ee4e21 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 dd1c0a6f1353ab50b989d582933128c685e275cf..6a9be12e600a10cfedec2c3e01c21fcdc9753c9e 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 a0e340250c76ae01bb8321cb5f707bea07bb7142..931824745dc2563d5fcb67a4d5f0274b31b351de 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 dc87141e8c49b00e2818b90cc78b364bc351f113..a7a6fadd669b65eeaad3d49c7e388aa6230d97d3 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 012306bf623b543386774135cfb14431af5885be..a6b236441e4d371d763f74283f5fd50c53e25953 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 c8ca522b04e2884d24b567671bcc7ac204beef2f..7466df924e1a4519ea645af968aeb645cd1b5b13 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 67e7d59bc1d5b7cd24a82aa062e7c45e86bd5d06..d9abd855aee851c180cec63b2f9c2b6ab4d559d4 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 43070e36131304c0b3f2882a7ec6eb4e8ebb59c0..aaa7da3440aed331c14071e37e544a2c3a1889c5 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 c70019d4b76743d9f8dd57d1206ecb8946b2ef06..794659c1a24502e7b1374685a7c6b47b3a7bd12b 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 d3a55393550087a59abb21dd4839051c126a3945..b93683f9b0cc2c475c7f83c297f8cea97b28abf1 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 8231ca0e9e99b06e3b4f0129057775a38701c737..4b46ef978d0cfa21937cff400507b661f5df58f0 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 f01623d1de4c062c69f619b28ae56af5384bc877..4f3ef2010c45a57d4a91470d03b260f3aa4a4265 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 8d4a56fbd2b5ed699a490f71b4f9b7185763fa2c..efede09cdf1ac8949cb0991381944957bb7cadc1 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 7b6dc06ce380d81a472dda53474c941e86f65e8a..abd7da5c5b52447e321bda1606ecc077728b8254 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 6c040969002978274ed41838e881a82c485fc8a0..17b18254b647ba5ebfb2d2c017c8acb234db5626 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 f664527cb132f9b58b2097839ea6fa7d0196e73f..5efc8ef455078055c15e89c52181ec192325f700 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 60fe7a969177d8129d12dd6094dc6502c6ac85c1..d26590136b1081f68d177c579bebcae7db8126a4 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 02f195c3277020bbe12e6c2ead6756ed0e41b1cf..da7ecf0edab4060158e6121c6e3de0ee14ac270b 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 78f5ad51ffa997cbb1c7888625f1364f411f6b1d..6764dc5007f8efa3121a2c8825e8befe3ad820dd 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 2b6f01e8ea466454a23317301473409f1648bdcd..221305584bcfa175f64c993dd0c88884e921fdd9 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 245bf54d28c901e1a6f7effe105c1907905d4236..85caa70bbdc9341d5b2a3671b8661866f16f1b60 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 54af27c6c5ed3494831765b24ed16e432d249787..f778e1f6fb71dae6de5b18bfb47ebe5597a44b17 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 623063ce683bc61c11d38dcfa03cc8820354174c..75ca01bbc79266d0b95b7c8c5caa88290fc2a5fb 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 d110fb2cbba3e6bc9bcb8843d64e3f6b2328407f..a751b290110f8af481e9d7d58a2481826106f285 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 9d41db1355b476d90cc3308fd104d75e182fae11..12528020042e20a93955da27a6f9a090a23bdc4b 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 96e50ecc74a3372f497fe7f9a2597b25b7458846..980f8f4dcb01a5a15862ecfb5c9ad80e9389fba6 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 efe560cb76e4264fefcaa217873963eb68a384d6..faf238b7aeb5e8156f4e56e4b586a256e86ad469 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 1b1296f8dc72e72d3fa4681ab6a2505220464510..f3d477230560aed594772a643cd2185b2775c127 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 7619fc03b4d0455b09d405c0676fc34af977ea6d..5f5b45a1012e0e3630fc8a2724377cc7109bd4a8 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 0000000000000000000000000000000000000000..9db6e4d2cbbd87d4455868d522acb17955c4c07b
--- /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 dd1b8ed0d3ac09db24076e0fa1fd636eeb640613..880270154babc8c6f6ecfab1dcb4130a4cf18e47 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 2980b156a1510052c107e18e6f6c8a1b30f11972..26a87d0a86bb584e49d57e2e78b41cc79a3c5614 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 322fabd2f1349debd42f65727cb6ce00d90dbe5f..b9b86362272b2ed1a7cbbff714fd35716e3e9bd3 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 71baeeea934e9dcd9251dbacba629811e574b613..94cbdc9a9e98626a3fa3be65d418f405c7f27325 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 c01c70ecc8ccfae09eca855e3bbf9ed2ab329d32..fcde5f50889c7031609686d4abe4bb48787889c4 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 0000000000000000000000000000000000000000..0ad63fa37dc8bdb4a4d207de9370c10e80baafab
--- /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 4554faa9e2fdf566026df1c76518eab3f3ccc52b..5d3f43063b00717fa50cf38ba460610998c58891 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 30d89de73342bf4ec08a397d237c062d9aa3f819..97a2b1d1f5df1d8b95b4dc67e3564ec8a84780e7 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 668bb8f7015e2bad39920ba292740227bca5f521..770b4c980ce91c87ffa74f9b1e5576caf43b7260 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 a929676f813285cf928b903546ce3ad5ea1266be..e1e012a096c6bc08139e9abdec8b8740bec8b6a4 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 0000000000000000000000000000000000000000..020dc2ccc20bac00a11062f30eeafc5573669a04
--- /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 b0c9edb79cbde177bc4197709d238d73078b3397..eb32425accb2bbc334f1fb36284c4da945a6b022 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 b5b8383a0792b29aed6896e1db0f3aa778a1c959..bb7d4e2d80e99603eefe91828a409f53ddcc56f4 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 b8153909990d0ac4652a711567bb4c2feed5d493..16a41bbde8426845d6fc60c90f53a073fb873351 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 e8d4badff69a6ffed52460b19e1849ab5f4dae7a..468d317cb3d8b3aaf902a690405698c3af79dddb 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 3b705e5b8ab3ce4f4321226e7f35343fc885636a..b7d44a97a0adf0bb62f57f450f44ccfe351597ae 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 d99b21ea461e795d3631aeff84f9332c4e9fe577..634892d8f1019fb0b5856b0ab724bcd2bb5f5450 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 d1a94027500554818f77ffcd560afd0a287e1397..45a22cf1a4878718ff74f063f8aa6cf39c289a14 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 44f53d6cefe50fd97d2e41a050080e607d17a4ad..2e35a47412ad93d787ef2e1a1077d0f581b0bf15 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 61b8cee91200f9adc312bb0e2c99561512d3f81c..9da5b244b660acd9f2898e1dab6d972021a0c0a4 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 77362f800ee783a4437a6d2ffd0acf8bc5cf5455..5c030b2e579b07af9bfac02a8f2daa99d175521b 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 4130717a1e5f2878f5a9d4790f05f674766f0792..59429420252f8e616a83270224a0c1312ba29d42 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 8c17b71103d8a93039fd48acbe35b7609c93a540..bbb925cbb8c5c85f3f815439dc30c5d77ab74009 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 22fe13193ebcb469839e27f158ef8962460a9819..b5a4292952e5b0590482ba0965b38ddf529045c8 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 aa31346b99610a11946cf24b58deb11447e5ed15..07e9ec1245b984eea48f398e51571d249de899a5 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 1a06587d8c38f40f1fc743f7d1218a444f8d1d60..73e7399b31adcc3e9bf54aad20cedb94f341165f 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 6af2d2238072635224df2f40a6d6a29c57e28a14..21bf9ff434fb20a9e50c55f9dc5166ac642a46ca 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 5f457e7a9395c52f6b6cab3869e3a4caca581ba7..bcd96e93f24e1410cf5db7db7b586b15e247a0f6 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 5653d37a8c0a21690efe2bbd2415225e8ee38a57..7c423229fff9824a99f59968f31f6cc601022770 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 3649c2e1bd26614e7151d67caf2dee7ae487a7ab..351ede6c4f6216e99bf1db08f9ed115176f870e9 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 3141769f6878c744ef91ef466f47de9919f6257e..f6f095d6d635d2d80ec2e2e112b9ff0cab4e6c70 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 0000000000000000000000000000000000000000..7a67dedacd9905bb0de8f0783ba2bbfd29acd123
--- /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 51e20faa0e05f6595ccc038bd00d703cd1b59837..376c3b94c5ae6bcacab7439e6d10a8955218ffc6 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 29c720d320f8a1e8a73e77524624b21547af39ba..79cac15bb9443e383d3b83b19a4c11f20dfa9bb5 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 fccbd3c249c64db8289511fbe521ada2f215fa3f..76655edff6572721365f480cf2baeb74ae413209 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 5b892bec1e14ca4db992e4fe30d925e6a083a194..10819d9470b74e2afefa6244c780103547a6635f 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 4815ee049607f110ae8eae54994c6a7aec75b73e..f03821c92aa8d27668c89c329c923a21cc5ca834 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 706f6e0bd8a51aaf84731f77099be0a1445692c3..ef0434760da3a034ecfaa405326b145deeafe25b 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 be4b88943ea5fa683fa6bd91d4deee21b1767b14..75765793f0efd1618471f7d51e7f9b0574b4c1f7 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 2c86ec38f7884f9a88e54a9edf5990cd22c26712..75bcdbdef7037a5f7d5f7b47c4975b802fbd09cc 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 7a1f59d930c7c9a735117ec4f1e1c1bb6f12e77e..c8176af7ec90348a78dd27a479ed6855b55b8882 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 75195135c7075e6c478896926541089c7cd4d96b..5255eea0f42a1c2d6106005107d8bf96e2be2a15 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 46dcb94141a61f220c0ae013841298029216e464..0e47eed7485b0772d5170bce94c9b3a7b9e3bbcc 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 61a053f1a48efb2bb4ccb82c3988c501b2d9956d..bd22e1f01f58df4f00caac3c0dfef2deb2aef6f5 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 b2b1dcf83443d3e52d34859a394b408d78d6e01b..e496ba0fefd79379aefe789666d1436fe09e5227 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 948eaa69499b456b4136ae86e31ebf1fc3e9ae44..d2aba9af3b529f43315c5b17aa226228aa12e163 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 6db1e3d1a15d80e230f2f03ada4dce97a345a7b7..7f9527da11eaaae1bf1220abae08fbb779b8aa47 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 127b6fc9d159556333585d8b96afb49df4568432..4b1a12b029839aa7f8837793afd6db8f46504796 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 b17d8479c22decf5576c2eed5d41cc6b8b72f33d..4c4d9a96bcdbc9049ec3988ac7bb2b661eed1c2f 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 588a4f002cf8cf41c215733e8d8df2f29d970edd..64a7f4316cc74022e6ef37587bf5e1849ced34b2 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 e258ab7ed29d7033d967e8e23935e48b5429e169..8e01cdddafd6bd3bb28b08d523073547d9589cdf 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 81e3a08f0aea305e0a6c8b92323a9e9e4a31adde..561fbcb4f07ce57559b4c27093a7cdc3943a17f2 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 abceb2441ea6f1ad76d569b354828e55d6e2e677..39001538689028ba9edb75f1a7ca5affe2cab92b 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 da12cce48b3994d548d797157033273b22975850..61155f444edc224eb3c9d2b14d93ba698c5209d4 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 7e8648e9cdc02c43d61ee495ea077dfe4003d2bf..10a12938ce7b985252a88bd4c5f4b589d78eed63 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 288432e39aa9e9fbf5fc388a4dc33fc77668d390..3a935ccef2fc1fd4c97d3a9b3bb5b5d178e492df 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 549c00050f0bece9ed555fdb4f5c25eac794ac78..93a0857c1af70ea380a0594c160dfb8adb4cd9d9 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 549c00050f0bece9ed555fdb4f5c25eac794ac78..93a0857c1af70ea380a0594c160dfb8adb4cd9d9 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 806f23e5059dd1e7f85c1a26010a3984dbd587d6..982f6ce4f4f967d4f48823a8291058c093ac61ed 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 b0e10c980ea8d64b116ea6c1e6986d01893b6bf3..15b311592232e74f31c75445a36f64415447c86a 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 a7806d6e39b98b97ea25c4b9971f27c4f72056cd..48ce715392d61dfc16fd3731e7061758f38fa574 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 55b3d61f9e3fdf7f7d0bfd516de885d7555938ee..09d84ec47b9f1a7e99d520d4e4c3177fa950b0d4 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 da12cce48b3994d548d797157033273b22975850..61155f444edc224eb3c9d2b14d93ba698c5209d4 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 da12cce48b3994d548d797157033273b22975850..61155f444edc224eb3c9d2b14d93ba698c5209d4 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 3c64c81f34f5a0f5fa8396dccf0a9ede78128524..2561b6b02c0b038d438a4c25042b3e08c4f0d8c6 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 4b5e8d269319199f1ac7940ac911d0365f7e5206..3678de3362df3b0edd55e67846648ab85c550372 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 85fcc04b19e16755f6b6224ec482f39a77702d76..f3fd05f5425f6f8f00f50fe5d0e74d7fa03c17c3 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 424ceda0e063117c6071cd8e8090b51dfeb18b23..a0de662f46371062047cb32c6ee154e55e6f698b 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 424ceda0e063117c6071cd8e8090b51dfeb18b23..a0de662f46371062047cb32c6ee154e55e6f698b 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 edaf392fcc765f3d67d6658b1d3761460153b782..9421fbdbd6d0952e1ffda82e3714fd9bf81b0cd8 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 da12cce48b3994d548d797157033273b22975850..61155f444edc224eb3c9d2b14d93ba698c5209d4 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 78309d688f2f25e7a0cd93df09f5deee17125657..912e2209b45a4ff153f9a7ac3712c06aca23267e 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 78309d688f2f25e7a0cd93df09f5deee17125657..912e2209b45a4ff153f9a7ac3712c06aca23267e 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 c6d7b5cfa522886af1db5a220329ff7b9464e6c9..125e0e2a9f5ca06ce987fb73592b00273afe8fb6 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 916a898fa5c196d130e64a519a618535edd32289..c6a4c483632d883d9d7205043872a87c20d9943f 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 c6d7b5cfa522886af1db5a220329ff7b9464e6c9..125e0e2a9f5ca06ce987fb73592b00273afe8fb6 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 b21d99f8b264dcc7324cd083bf3997125a942441..a4fd11cb39f768148cb4df61f0b788f4717698b0 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 837a82a207ffe73a6582543af5ef6af74803f4b2..ac59491c8c3778bb380ae54daf6f0b56840e83eb 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 0718bd597f0a84e026f935e192426391dc015c5b..82216b5684efbb29858955442b49155369f08865 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 f7a9e34a0e77beabae191c79c2fe34a6a6d6f227..c06b7707134259094f7da3fe5f0e39b5f17f5d88 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 a795dcd27c2f94fee99d2f93bf7c8d05380fb59b..aa21f838bcfc331c8b58f11a93a88e0d5e370c0a 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 49852a1758241a20c211b381d3e0560d739796d5..bab0e864766f52bf18795e49b795cc1d9b8b9c99 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 da12cce48b3994d548d797157033273b22975850..61155f444edc224eb3c9d2b14d93ba698c5209d4 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 af7fde6f8eb349e25b749b2ce2541251fe65b829..e2e4121dc0adc35bcd029270dcc719e2d9f92931 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 a7cd75974c94a4b173346ee150f0c19d2ca43b67..6347fbeed93a1c8b85c036cb8e3dd51e2e6c65c2 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 ed05ffce9d15802f2bbb11427b8204891a28c053..dd9a103653a8c9a70f8be1679513e8d1736e9310 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 31d4fe1430eca1a01b48ef43b94fc14406560251..ce1d24bdaf93d9b6c078dc00075e724a5c624a5f 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 02aa357eb9b93453a88fcd30700c9ac751ffe386..f23def9c005c5817ae26920476e6f8bcd3618f4c 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 a611448bc5fbed618708797763fd3686da7eca70..87a5b749fe14bafb31439dd1ce5db992c0f643d2 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 0007d47579b1a781f839f6b16fb1cb36d7e437e2..0381c93d5d6b193543b8f5cb979f2c1e126cf0ce 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 aa43444c9b3b6cefd812307604acb194300a3e0f..0965b104b101ce64c0f0c99f1f67b86a2ae1ff4a 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 8f6c2fb215ab05c8622aa7e6e2c821d7aa332b47..07582f583a3976f6637fad70f5b474284cbc9673 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 8f6c2fb215ab05c8622aa7e6e2c821d7aa332b47..07582f583a3976f6637fad70f5b474284cbc9673 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 16a82f7aba51f4267e0db8ef03880ff7e12ba890..6db7ec693e52b90f26b9df30ba069146f6fe5686 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 8ac2d3e1856e811bbe8db7e87d5f58cc1461c002..4a9824198def66d34d8dd5214970f1e7f78549eb 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 4695648e6064b197d3cc81c586ffd398fd2d9dee..48224aa40d49a7529a4ee59f63f66a32aee3a64c 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 5a369107f9456a55bba28d4bf2298689f00eeec1..01ff6768ae5cc6e223165f7a21fe14a53fe95145 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 d1fdbdf62e1259f0a07e26ddcc3588a0f93e686a..45648bd02df0833ca48367ae6bcef6a2d7762556 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 984ce45272513256f35ff62b66a33d70ff795341..2c0399fc784db62621a90df8531c72222b05d2da 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 ad6972ada468b213afa4010286bacc494857cf14..48d5b3dbc6e0b59e518f199805c5aa218fa6395b 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 97a0bb0b1aa10c2fa59123ec6257d767b9e63790..ffe7978ead1e07e1840ecfb70745208363a183eb 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 0000000000000000000000000000000000000000..942bb49300445d12dea40f29e8885783ba7ca435
--- /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 e1c7cac4b9044d20576e5841dcfa6644459be180..4a39998830d3b6d5ebed6a339271a36805a3e6db 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 0a0a44a6ef1c2b2b0f0b52d40379ced8bb1e549b..263aa5a83893965b117fd688c9696d4faa0c4066 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 4b9bad4f15446157856cb794b778cf0fa1b41cf8..20b8041765610812c484fe0e228be8c0711ae65b 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 be8bad252f36753a21bff79d7f84597364c94731..eb714c8752db9d254794514c0186389a5d52ac3e 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 d2000ca827b0855de761aeb0e5b62b9999478b3f..bf637edc294eb53007ad7b587ce31e9bb08ad3fe 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 0ad3fff7efae0ea4bd8133b53927da074be91354..539ba47cd5a85b4bfe0c8b23100f8a2c79788c8b 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 db22b6d43303085dac3faeab8d40072fec98461d..d6b615a31b1c3ff262279d658985d070ec27ae80 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 58f75a5846889f21f2a7dc527a773ab910e60f03..0255ff57c07eaa5cd9a474fbf8b859110bfacfd5 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 494470407ac9dc75a208004625e78fbb209e119c..c2cee9ca229fa942760f56eb28ed81e07d989d68 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 9af90477e2506f353dd7d7bc8790905011bc76ca..c6024e76878f67f081b6ebb59a94fad4625c31b5 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 90b301a9c60df57d92657ac2d326187f0f04e20b..0ac1f67fb900efca364e808ee5b3abff1cc6bf4d 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 9e3ebc0d6a213c1317ea908134d09cbded266650..852e1ba3f0fd762b1d30ae27ab8bd9e619d57119 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 076828ae2692680d7256596cd89c0f1a64c9257e..88d53770de44da82cd3ab3f614410851e2c873a0 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 aed34318ebb55beb34751ed7f889de0cdc7f31b1..eb5f15a4e6c6098c9d03f3bc802a100bd038b9e9 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 1a86336cb19a8e1b144c50f00147aa39c81600f9..c219cd61f4a8a472ebc5691f2541e56c9d37ba33 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 c60a6bcdfa774088840dd9f9b33b5cb9b46eae13..2d19171a7404001fd2b5564b57af18ff7665c2c0 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 0000000000000000000000000000000000000000..1d847c5b18fac872ec99eb424f79bb3511fd82a9
--- /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 0000000000000000000000000000000000000000..1ec2383e1fc780a9098e79e5404eaa0dd7ba4f48
--- /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 0000000000000000000000000000000000000000..c59b522b2c2fe0727042b53b3b166367cd35e435
--- /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 0000000000000000000000000000000000000000..8ae6b8d2a472377528b80723c3ae674b2de72fc8
--- /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 0000000000000000000000000000000000000000..a1cf7bfd9f201a0ab5df15085f3cc5179340093b
--- /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 0000000000000000000000000000000000000000..5ddd9e3fc823ae9017611255ca413d120a2cb7f0
--- /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 0000000000000000000000000000000000000000..aa2a873bf6e67af62c16d205a023ffcfd179cc8c
--- /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 0000000000000000000000000000000000000000..b097aef3ad08a4cf2ffff8e9adea99b104f56c22
--- /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 0000000000000000000000000000000000000000..9110f510138308f534a960a3cd168d116c7ac5d3
--- /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 0000000000000000000000000000000000000000..0194aad323f799c7eb281b0644f7f2e4b51edb9f
--- /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 0000000000000000000000000000000000000000..d28cc78cc7daf3a5782ebf4900d7c6dcfdab049c
--- /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 0000000000000000000000000000000000000000..5f5c4a3ba6a898a51042cdffdbc57feb20ca9585
--- /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 0000000000000000000000000000000000000000..cff3091bf1555070bf510754a50cb582cdbab4db
--- /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 0000000000000000000000000000000000000000..94d007f3d0bf4f89410ffe075f97ff2915a4824d
--- /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 0000000000000000000000000000000000000000..89690a63d518feca87e2f64af4e07f2682ae1110
--- /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 0000000000000000000000000000000000000000..6b93bac0224cf3268486712082adf57bc0fd0e2e
--- /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 0000000000000000000000000000000000000000..7f2e538309353f012df80a65f1b9badeae865e78
--- /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 0000000000000000000000000000000000000000..d06f79012d7e77953c4cae7470d166f4ebc36e0e
--- /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 0000000000000000000000000000000000000000..d06f79012d7e77953c4cae7470d166f4ebc36e0e
--- /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 0000000000000000000000000000000000000000..5f5fb5a05159e22be6aea2672083d933f94ceb70
--- /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 0000000000000000000000000000000000000000..776a6e49032b98f4a9e7dd7ddd7868901e224ba2
--- /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 0000000000000000000000000000000000000000..fce4c996e6ffe0c9537f777fbb0b801e6c4b0a13
--- /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 0000000000000000000000000000000000000000..ba18e361c04d6d13845761bf123d002416fe7313
--- /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 0000000000000000000000000000000000000000..0b36f83e803df25807a3a4db26c48df1ebfd1fe8
--- /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 0000000000000000000000000000000000000000..2abf519799bb1a02c0269bf5add9bf3d2ae56bfb
--- /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 0000000000000000000000000000000000000000..c66d3b68a698bb8fa19a7250acc542436367d3d0
--- /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 0000000000000000000000000000000000000000..3bd2d626b0a3afb221c2722a4e8ee089969decae
--- /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 0000000000000000000000000000000000000000..c958109b0852ff4e23f587cb14ed5f02bb246b46
--- /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 0000000000000000000000000000000000000000..bf3453bfa9a691d8df2566693f0fbf9098a87097
--- /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 0000000000000000000000000000000000000000..dfe0e660eef44e3292229af5e7189188e085b859
--- /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 0000000000000000000000000000000000000000..11252638252790d9890743ecd9b47af6d56c8c2c
--- /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 0000000000000000000000000000000000000000..32f80e0284d83065f0bc5173cd5373901d15fab1
--- /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 0000000000000000000000000000000000000000..eeca48ed51fb6093002482442fadbc4497105096
--- /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 0000000000000000000000000000000000000000..6c6c29c09cd5c0fe642fb8c51a80070693a8c719
--- /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 0000000000000000000000000000000000000000..88a8dcd3f23d9cd6eb061e4a813fbe40da307d1d
--- /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 0000000000000000000000000000000000000000..7a425d51ab1b07b6eeb3620cf592f2cdb5951801
--- /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 0000000000000000000000000000000000000000..0d467fe722798dae47c6a86595389c78227cc7d9
--- /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 0000000000000000000000000000000000000000..20fa17adcac1a68434d590345949ec436a30da88
--- /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 0000000000000000000000000000000000000000..19dde3acb8a04ea6a42a096872227cdf63ef4d9d
--- /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 0000000000000000000000000000000000000000..4277254af05b08e40bed73f90e656a9f7c625dd2
--- /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 0000000000000000000000000000000000000000..5d7fca3cf2713b2b7ab35f87cc623237d55efaec
--- /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 0000000000000000000000000000000000000000..dfa0afeb4c76f0970e160609f9cf4fa22bfd12bd
--- /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 0000000000000000000000000000000000000000..48355d76a4ae133cb27d6dad6daa64c8fed8618f
--- /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 0000000000000000000000000000000000000000..e5bb8e342517bd627d6c4b983efebe2dd67c0ce1
--- /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 0000000000000000000000000000000000000000..f9d6dc0826838b3dd4fe1d941e4a50147d954754
--- /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 0000000000000000000000000000000000000000..0de80d84684bf3099dcf83ea67223df5b38c0428
--- /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 0000000000000000000000000000000000000000..2d344695d421fe49b40d65d82b7989280558943f
--- /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 0000000000000000000000000000000000000000..051cefd46c25320b174789c07396ea13db325ae4
--- /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 0000000000000000000000000000000000000000..2b8559954b3f206d2b7bcc7c94660baf1216364e
--- /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 0000000000000000000000000000000000000000..427e3ed889d4483861d9e91b1d0f5fa4d330fa69
--- /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 0000000000000000000000000000000000000000..4b4d1d8742a69e90a82e67eb470f9044ea2fa843
--- /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 0000000000000000000000000000000000000000..99611ad1525161f70f608b093ac9f190f79340d0
--- /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 0000000000000000000000000000000000000000..1a5a117eb388fb102059a62191ec2a17c56d721c
--- /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 0000000000000000000000000000000000000000..0cfbf08886fca9a91cb753ec8734c84fcbe52c9f
--- /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 0000000000000000000000000000000000000000..7068c238c6f459aa7cd8cfea23e3f0fbec0f8c4d
--- /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 0000000000000000000000000000000000000000..99715dc92d1c53280af4255c3879aa5d9ec98a08
--- /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 0000000000000000000000000000000000000000..469afa2ae06c845fe703ac83673245913ffa1df7
--- /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 0000000000000000000000000000000000000000..6a452c185a8c94a4e4835a6f6999fe3f78957951
--- /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 0000000000000000000000000000000000000000..76899c8f21020e86fed934fdb4eb2c3f2bc8335a
--- /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 0000000000000000000000000000000000000000..6a452c185a8c94a4e4835a6f6999fe3f78957951
--- /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 0000000000000000000000000000000000000000..12f0dd40c0129143328b1cabb8910928dff827d5
--- /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 0000000000000000000000000000000000000000..b810dbee6d259eef351f0c0d5aebc1f2c6fbf655
--- /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 0000000000000000000000000000000000000000..5576f214341e0c44a5fa53fd8611f5ab1a2854b8
--- /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 0000000000000000000000000000000000000000..60cf42c6c4300861cd94163f87a491e13be60c45
--- /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 0000000000000000000000000000000000000000..590601bf30ed6bbbd0b03fc283d31caa79bdeecf
--- /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 0000000000000000000000000000000000000000..d5f705358b774fd7759cd3c1577f7c11c9480c27
--- /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 0000000000000000000000000000000000000000..895898a6a692c2e365ac5444c0f6754accac6278
--- /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 0000000000000000000000000000000000000000..0ba61391ce49f55422a4337587cc778f1cdba3d4
--- /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 0000000000000000000000000000000000000000..cb98b21e763c1bc896a7a03cf8ee4802e6bb98db
--- /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 0000000000000000000000000000000000000000..13b52cb7e2680f9bac2f63b3573f04f663f1267d
--- /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 0000000000000000000000000000000000000000..4974f52a1e54a28ab7891e5fbc8ab60f513d5914
--- /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 0000000000000000000000000000000000000000..de4789caa0108a759d84915127afeb27bc694893
--- /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 0000000000000000000000000000000000000000..5541b57dbe4dd6e9492f15b7ca08b46466190bf0
--- /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 0000000000000000000000000000000000000000..72382e7e368d346c8b78efeaf37e3fb001c61b5e
--- /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 0000000000000000000000000000000000000000..a9bb7514f7a327420c69099173dcd702b85f2119
--- /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 0000000000000000000000000000000000000000..87f4a97caab9afb18bad7a9f219f07088714687f
--- /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 9226723ee2226234fc2c68ca636965c59ffc43ca..6613a979fc0f883bc5e87d4945f07ec1e9494c25 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 81126d1aa527fd60ab02546c886b45ed232cb22d..2e0da0c138ac803c30a228dd4eded5677206be84 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 4ebe1f60b9855c627ecf6d7d5609c9567920764b..5b663fd8a9447daccae0d6200e10202372419c96 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 d6d0bcd42f7236fdcb7486791fa812503420dfa2..dd2f6cca4a0e432b18e3f498f2362adaebfd71a1 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 a75b5d2f237ee3cab96f6b878f2d55ba84560055..0a48c703f9b103192ec56d46b2d78465436ecc91 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 a1984c126a08f65043854ef8d8e0e5c9ca00490c..6afa14edcc682e4849f35b4549edb78564e87d43 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 3a72df5810d23c90001a9908e6b5df977b24b52f..0a569095357f6d74e8d3255d7740c75c15870467 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 c6d19d2501a0888351423ca21b497f29f22bf1a4..75e4a63ede2f2a83f80979b4b9fa8345431370f0 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 e1307dd2bef04a70aa309094f753acf332d08764..d6e6a3631a5eca0c389b323dd8a1ac4a833b835f 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 552fa73b592aa5f2e0be4d48c48c79485e841c08..f0ad316c1a57fc7387d132cc59d1206961de5c18 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 bc0dd2ef0f5c36d1173c3c4eb85a589069a7f5c5..afe8aa0bff52367061394ac6f148ac2fac5e61e0 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 680e1ac150eaa152208bfe0732fa0cd23ec3ddea..9078f349bef3aa9b7cd39636706c4b44c393f785 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 648ebe25f3218295bde7c298804258e3ca7d3e77..13f9a0ced2e174afa4982fa0f6407dfc4f41534c 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 1bc3b20e5126d4de01eaefcdd5fcbd5d5115bcd3..8419beda86f9898781b82bfc4958223d5ef9af1c 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 305665c766e83dd9a8617f35bd11f3f20d4269d4..24ec5e1096cb9662b4960e1326b5e57463f14731 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 5a21342a4e2ad42ac9a6bc5c126976e0a0ca3562..02b23d61ace3308f0b2b7c929367b0d9d9a7f95b 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 6988128ec5045c37aa6c3ad9f928cfa1c1dbdea3..1dfbb0fda9ebdcbd957a660117ff26ca2c4dcd27 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 1b249047d58a8123044cdbe56c192797c5b76798..798fd712e33c4a662fe391f7fd925528ef0929c3 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 d5261d6e6868d4c9b4e90ecd4b55bb57755b9d2d..dce0edd1fc6b87c15cd114a6023f944f2f0e4727 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