diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-08-20 16:55:59 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-08-26 04:50:58 -0400 |
commit | 0b17fa185aec793861364afd9a05aa4219fbc019 (patch) | |
tree | bb668be1d2b290fccfeb2beb982994b553789bb3 /compiler/GHC/Tc | |
parent | b7d98cb2606997e05ad6406929dae3aba746fbb9 (diff) | |
download | haskell-0b17fa185aec793861364afd9a05aa4219fbc019.tar.gz |
Refactor UnitId pretty-printing
When we pretty-print a UnitId for the user, we try to map it back to its
origin package name, version and component to print
"package-version:component" instead of some hash.
The UnitId type doesn't carry these information, so we have to look into
a UnitState to find them. This is why the Outputable instance of
UnitId used `sdocWithDynFlags` in order to access the `unitState` field
of DynFlags.
This is wrong for several reasons:
1. The DynFlags are accessed when the message is printed, not when it is
generated. So we could imagine that the unitState may have changed
in-between. Especially if we want to allow unit unloading.
2. We want GHC to support several independent sessions at once, hence
several UnitState. The current approach supposes there is a unique
UnitState as a UnitId doesn't indicate which UnitState to use.
See the Note [Pretty-printing UnitId] in GHC.Unit for the new approach
implemented by this patch.
One step closer to remove `sdocDynFlags` field from `SDocContext`
(#10143).
Fix #18124.
Also fix some Backpack code to use SDoc instead of String.
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Backpack.hs | 55 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Instantiate.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 10 |
4 files changed, 41 insertions, 35 deletions
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 8231955063..311f87458f 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2866,11 +2866,12 @@ rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDynFlags ; + unit_state <- unitState <$> getDynFlags ; -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) - "" FormatText short_dump) ; + "" FormatText (pprWithUnitState unit_state short_dump)) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 5dbc90de86..b27002bec8 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -234,16 +234,15 @@ check_inst sig_inst = do -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] -requirementMerges pkgstate mod_name = - fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) +requirementMerges unit_state mod_name = + fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext unit_state)) where -- update IndefUnitId ppr info as they may have changed since the -- time the IndefUnitId was created fixupModule (Module iud name) = Module iud' name where - iud' = iud { instUnitInstanceOf = cid' } + iud' = iud { instUnitInstanceOf = cid } cid = instUnitInstanceOf iud - cid' = updateIndefUnitId pkgstate cid -- | For a module @modname@ of type 'HscSource', determine the list -- of extra "imports" of other requirements which should be considered part of @@ -276,8 +275,8 @@ findExtraSigImports' hsc_env HsigFile modname = $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where - pkgstate = unitState (hsc_dflags hsc_env) - reqs = requirementMerges pkgstate modname + unit_state = unitState (hsc_dflags hsc_env) + reqs = requirementMerges unit_state modname findExtraSigImports' _ _ _ = return emptyUniqDSet @@ -535,17 +534,17 @@ mergeSignatures }) $ do tcg_env <- getGblEnv - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - mod_name = moduleName (tcg_mod tcg_env) - pkgstate = unitState dflags - home_unit = mkHomeUnitFromFlags dflags + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + mod_name = moduleName (tcg_mod tcg_env) + unit_state = unitState dflags + home_unit = mkHomeUnitFromFlags dflags -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in. - let reqs = requirementMerges pkgstate mod_name + let reqs = requirementMerges unit_state mod_name - addErrCtxt (merge_msg mod_name reqs) $ do + addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do -- STEP 2: Read in the RAW forms of all of these interfaces ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) -> @@ -572,7 +571,7 @@ mergeSignatures let insts = instUnitInsts iuid isFromSignaturePackage = let inst_uid = instUnitInstanceOf iuid - pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid) + pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid) in null (unitExposedModules pkg) -- 3(a). Rename the exports according to how the dependency -- was instantiated. The resulting export list will be accurate @@ -900,18 +899,21 @@ tcRnInstantiateSignature hsc_env this_mod real_loc = exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map occName . availNames) -impl_msg :: Module -> InstantiatedModule -> SDoc -impl_msg impl_mod (Module req_uid req_mod_name) = - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid +impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc +impl_msg unit_state impl_mod (Module req_uid req_mod_name) + = pprWithUnitState unit_state $ + text "while checking that" <+> ppr impl_mod <+> + text "implements signature" <+> ppr req_mod_name <+> + text "in" <+> ppr req_uid -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(Module uid mod_name) = - addErrCtxt (impl_msg impl_mod req_mod) $ do +checkImplements impl_mod req_mod@(Module uid mod_name) = do + dflags <- getDynFlags + let unit_state = unitState dflags + addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid -- STEP 1: Load the implementing interface, and make a RdrEnv @@ -931,7 +933,6 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") (dep_orphs (mi_deps impl_iface)) - dflags <- getDynFlags let avails = calculateAvails dflags impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) @@ -969,9 +970,8 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of [] -> addErr $ quotes (ppr occ) - <+> text "is exported by the hsig file, but not" - <+> text "exported by the implementing module" - <+> quotes (ppr impl_mod) + <+> text "is exported by the hsig file, but not exported by the implementing module" + <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) _ -> return () failIfErrsM @@ -1002,15 +1002,12 @@ instantiateSignature = do 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 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 - let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit) + let uid = Indefinite (homeUnitInstanceOf home_unit) inner_mod `checkImplements` Module (mkInstantiatedUnit uid (homeUnitInstantiations home_unit)) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 8a9c791da3..d93e8fc84f 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -80,6 +80,7 @@ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.State import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless ) @@ -972,9 +973,10 @@ dupInstErr ispec dup_ispec [ispec, dup_ispec] addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () -addClsInstsErr herald ispecs - = setSrcSpan (getSrcSpan (head sorted)) $ - addErr (hang herald 2 (pprInstances sorted)) +addClsInstsErr herald ispecs = do + unit_state <- unitState <$> getDynFlags + setSrcSpan (getSrcSpan (head sorted)) $ + addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) where sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs -- The sortBy just arranges that instances are displayed in order diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 9f7d0b2ec1..b2c987794b 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -977,13 +977,19 @@ mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg mkLongErrAt loc msg extra = do { dflags <- getDynFlags ; printer <- getPrintUnqualified dflags ; - return $ mkLongErrMsg dflags loc printer msg extra } + unit_state <- unitState <$> getDynFlags ; + let msg' = pprWithUnitState unit_state msg in + return $ mkLongErrMsg dflags loc printer msg' extra } mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg mkErrDocAt loc errDoc = do { dflags <- getDynFlags ; printer <- getPrintUnqualified dflags ; - return $ mkErrDoc dflags loc printer errDoc } + unit_state <- unitState <$> getDynFlags ; + let f = pprWithUnitState unit_state + errDoc' = mapErrDoc f errDoc + in + return $ mkErrDoc dflags loc printer errDoc' } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError |