summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Module.hs13
-rw-r--r--compiler/GHC/Tc/TyCl.hs9
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs22
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs12
5 files changed, 32 insertions, 28 deletions
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index d642a15147..8231955063 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -110,7 +110,7 @@ import GHC.Utils.Error
import GHC.Types.Id as Id
import GHC.Types.Id.Info( IdDetails(..) )
import GHC.Types.Var.Env
-import GHC.Unit.Module
+import GHC.Unit
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Types.Name.Env
@@ -181,15 +181,14 @@ tcRnModule hsc_env mod_sum save_rn_syntax
where
hsc_src = ms_hsc_src mod_sum
dflags = hsc_dflags hsc_env
- err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
+ home_unit = mkHomeUnitFromFlags dflags
+ err_msg = mkPlainErrMsg dflags loc $
text "Module does not have a RealSrcSpan:" <+> ppr this_mod
- this_pkg = homeUnit (hsc_dflags hsc_env)
-
pair :: (Module, SrcSpan)
pair@(this_mod,_)
| Just (L mod_loc mod) <- hsmodName this_module
- = (mkModule this_pkg mod, mod_loc)
+ = (mkHomeModule home_unit mod, mod_loc)
| otherwise -- 'module M where' is omitted
= (mAIN, srcLocSpan (srcSpanStart loc))
@@ -2839,12 +2838,12 @@ loadUnqualIfaces hsc_env ictxt
= initIfaceTcRn $ do
mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
where
- this_pkg = homeUnit (hsc_dflags hsc_env)
+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
, let name = gre_name gre
- , nameIsFromExternalPackage this_pkg name
+ , nameIsFromExternalPackage home_unit name
, isTcOcc (nameOccName name) -- Types and classes only
, unQualOK gre ] -- In scope unqualified
doc = text "Need interface for module whose export(s) are in scope unqualified"
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index ccc23c3930..113fadd20d 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -61,8 +61,7 @@ import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
-import GHC.Unit.Module
-import GHC.Unit.State
+import GHC.Unit
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
@@ -174,8 +173,8 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 1.5: Make sure we don't have any type synonym cycles
; traceTc "Starting synonym cycle check" (ppr tyclss)
- ; this_uid <- fmap homeUnit getDynFlags
- ; checkSynCycles this_uid tyclss tyclds
+ ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags
+ ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds
; traceTc "Done synonym cycle check" (ppr tyclss)
-- Step 2: Perform the validity check on those types/classes
@@ -4136,7 +4135,7 @@ checkValidDataCon dflags existential_ok tc con
-- when we actually fill in the abstract type. As such, don't
-- warn in this case (it gives users the wrong idea about whether
-- or not UNPACK on abstract types is supported; it is!)
- , homeUnitIsDefinite dflags
+ , isHomeUnitDefinite (mkHomeUnitFromFlags dflags)
= addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
where
is_strict = case strict_mark of
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index bddda199a8..5dbc90de86 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -21,7 +21,7 @@ module GHC.Tc.Utils.Backpack (
import GHC.Prelude
import GHC.Types.Basic (defaultFixity, TypeOrKind(..))
-import GHC.Unit.State
+import GHC.Unit
import GHC.Tc.Gen.Export
import GHC.Driver.Session
import GHC.Driver.Ppr
@@ -42,7 +42,6 @@ import GHC.Iface.Load
import GHC.Rename.Names
import GHC.Utils.Error
import GHC.Types.Id
-import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
@@ -312,10 +311,11 @@ implicitRequirements' hsc_env normal_imports
forM normal_imports $ \(mb_pkg, L _ imp) -> do
found <- findImportedModule hsc_env imp mb_pkg
case found of
- Found _ mod | not (isHomeModule dflags mod) ->
+ Found _ mod | not (isHomeModule home_unit mod) ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
where dflags = hsc_dflags hsc_env
+ home_unit = mkHomeUnitFromFlags dflags
-- | Given a 'Unit', make sure it is well typed. This is because
-- unit IDs come from Cabal, which does not know if things are well-typed or
@@ -539,6 +539,7 @@ mergeSignatures
inner_mod = tcg_semantic_mod tcg_env
mod_name = moduleName (tcg_mod tcg_env)
pkgstate = unitState dflags
+ home_unit = mkHomeUnitFromFlags dflags
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
@@ -734,7 +735,7 @@ mergeSignatures
-- STEP 4: Rename the interfaces
ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->
tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface
- lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0
+ lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0
let ifaces = lcl_iface : ext_ifaces
-- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
@@ -756,7 +757,7 @@ mergeSignatures
let infos = zip ifaces detailss
-- Test for cycles
- checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) []
+ checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) []
-- NB on type_env: it contains NO dfuns. DFuns are recorded inside
-- detailss, and given a Name that doesn't correspond to anything real. See
@@ -1000,16 +1001,17 @@ instantiateSignature = do
dflags <- getDynFlags
let outer_mod = tcg_mod tcg_env
inner_mod = tcg_semantic_mod tcg_env
+ home_unit = mkHomeUnitFromFlags dflags
+ unit_state = unitState dflags
-- TODO: setup the local RdrEnv so the error messages look a little better.
-- But this information isn't stored anywhere. Should we RETYPECHECK
-- the local one just to get the information? Hmm...
- MASSERT( isHomeModule dflags outer_mod )
- MASSERT( isJust (homeUnitInstanceOfId dflags) )
- let uid = fromJust (homeUnitInstanceOfId dflags)
+ MASSERT( isHomeModule home_unit outer_mod )
+ MASSERT( isHomeUnitInstantiating home_unit)
-- we need to fetch the most recent ppr infos from the unit
-- database because we might have modified it
- uid' = updateIndefUnitId (unitState dflags) uid
+ let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit)
inner_mod `checkImplements`
Module
- (mkInstantiatedUnit uid' (homeUnitInstantiations dflags))
+ (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
(moduleName outer_mod)
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 0b92d7b3d2..ea20808f98 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -106,6 +106,7 @@ import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Unit.Module
+import GHC.Unit.Home
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
@@ -146,7 +147,8 @@ lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
dflags = hsc_dflags hsc_env
- tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+ home_unit = mkHomeUnitFromFlags dflags
+ tcg_semantic_mod = homeModuleInstantiation home_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
then (return
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 47e1ab8a9d..abdd670483 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -241,6 +241,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
th_remote_state_var <- newIORef Nothing ;
let {
dflags = hsc_dflags hsc_env ;
+ home_unit = mkHomeUnitFromFlags dflags ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
@@ -266,8 +267,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_th_remote_state = th_remote_state_var,
tcg_mod = mod,
- tcg_semantic_mod =
- canonicalizeModuleIfHome dflags mod,
+ tcg_semantic_mod = homeModuleInstantiation home_unit mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
@@ -773,7 +773,9 @@ wrapDocLoc doc = do
getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags
= do { rdr_env <- getGlobalRdrEnv
- ; return $ mkPrintUnqualified dflags rdr_env }
+ ; let unit_state = unitState dflags
+ ; let home_unit = mkHomeUnitFromFlags dflags
+ ; return $ mkPrintUnqualified unit_state home_unit rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
@@ -1937,10 +1939,10 @@ initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; dflags <- getDynFlags
; let !mod = tcg_semantic_mod tcg_env
+ home_unit = mkHomeUnitFromFlags dflags
-- When we are instantiating a signature, we DEFINITELY
-- do not want to knot tie.
- is_instantiate = homeUnitIsDefinite dflags &&
- not (null (homeUnitInstantiations dflags))
+ is_instantiate = isHomeUnitInstantiating home_unit
; let { if_env = IfGblEnv {
if_doc = text "initIfaceTcRn",
if_rec_types =
View Lorry Controller Status