Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 5a6fbce9 by Simon Peyton Jones at 2026-04-03T00:52:08+01:00 Onward [skip ci] - - - - - 11 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -206,7 +206,6 @@ knownKeyOccName std_uniq basicKnownKeyTable :: [(OccName, KnownKeyNameKey)] basicKnownKeyTable = [ (mkTcOcc "Rational", rationalTyConKey) - , (mkTcOcc "Ord", ordClassKey) , (mkTcOcc "Show", showClassKey) , (mkTcOcc "Foldable", foldableClassKey) , (mkTcOcc "Traversable", traversableClassKey) @@ -218,9 +217,18 @@ basicKnownKeyTable , (mkTcOcc "Ix", ixClassKey) , (mkTcOcc "Alternative", alternativeClassKey) - -- Class Eq + -- Class Eq and Ord , (mkTcOcc "Eq", eqClassKey) + , (mkTcOcc "Ord", ordClassKey) , (mkVarOcc "==", eqClassOpKey) + , (mkVarOcc ">=", geClassOpKey) + , (mkVarOcc "<=", leClassOpKey) + , (mkVarOcc "<", ltClassOpKey) + , (mkVarOcc ">", gtClassOpKey) + , (mkVarOcc "compare", compareClassOpKey) + , (mkDataOcc "LT", ordLTDataConKey) + , (mkDataOcc "EQ", ordEQDataConKey) + , (mkDataOcc "GT", ordGTDataConKey) -- Numeric operations , (mkTcOcc "Num", numClassKey) @@ -236,6 +244,7 @@ basicKnownKeyTable -- Class Functor , (mkTcOcc "Functor", functorClassKey) , (mkVarOcc "fmap", fmapClassOpKey) + , (mkVarOcc "map", mapIdKey) -- Class Monad, MonadFix, MonadZip , (mkTcOcc "Monad", monadClassKey) @@ -263,7 +272,7 @@ basicKnownKeyTable , (mkTcOcc "IsString", isStringClassKey) , (mkVarOcc "fromString", fromStringClassOpKey) - -- Stuff for pre-typechecker expansion + -- Records , (mkTcOcc "HasField", hasFieldClassKey) , (mkVarOcc "fromLabel", fromLabelClassOpKey) , (mkVarOcc "getField", getFieldClassOpKey) @@ -420,9 +429,6 @@ basicKnownKeyNames -- Dynamic toDynName, - -- Numeric stuff - geName, - -- Conversion functions ratioTyConName, ratioDataConName, toIntegerName, toRationalName, @@ -458,7 +464,7 @@ basicKnownKeyNames nonEmptyTyConName, -- List operations - mapName, foldrName, buildName, augmentName, + foldrName, buildName, augmentName, -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, @@ -727,6 +733,8 @@ mkMainModule_ m = mkModule mainUnit m * * ************************************************************************ -} +kk_RDR :: KnownKeyNameKey -> RdrName +kk_RDR key = knownKeyRdrName key (knownKeyOccName key) main_RDR_Unqual :: RdrName main_RDR_Unqual = mkUnqual varName (fsLit "main") @@ -735,17 +743,18 @@ main_RDR_Unqual = mkUnqual varName (fsLit "main") ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -ge_RDR = nameRdrName geName -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = nameRdrName ordLTDataConName -eqTag_RDR = nameRdrName ordEQDataConName -gtTag_RDR = nameRdrName ordGTDataConName +eq_RDR = kk_RDR eqClassOpKey +ge_RDR = kk_RDR geClassOpKey +le_RDR = kk_RDR leClassOpKey +lt_RDR = kk_RDR ltClassOpKey +gt_RDR = kk_RDR gtClassOpKey +compare_RDR = kk_RDR compareClassOpKey +ltTag_RDR = kk_RDR ordLTDataConKey +eqTag_RDR = kk_RDR ordEQDataConKey +gtTag_RDR = kk_RDR ordGTDataConKey map_RDR :: RdrName -map_RDR = nameRdrName mapName +map_RDR = kk_RDR mapIdKey foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName @@ -906,7 +915,7 @@ uWordHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") (fsLit " fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName -fmap_RDR = nameRdrName fmapName +fmap_RDR = kk_RDR fmapClassOpKey replace_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$") pure_RDR = nameRdrName pureAName ap_RDR = nameRdrName apAName @@ -951,7 +960,7 @@ runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey -ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey @@ -1029,12 +1038,6 @@ unpackCStringName, unpackCStringUtf8Name :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey --- Base classes (Eq, Ord, Functor) -fmapName, geName, functorClassName :: Name -geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_INTERNAL_BASE (fsLit "Functor") functorClassKey -fmapName = varQual gHC_INTERNAL_BASE (fsLit "fmap") fmapClassOpKey - -- Class Monad thenMName, bindMName, returnMName :: Name thenMName = varQual gHC_INTERNAL_BASE (fsLit ">>") thenMClassOpKey @@ -1076,14 +1079,13 @@ considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") consider -- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, - mapName, assertName, + assertName, dollarName :: Name dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_INTERNAL_BASE (fsLit "foldr") foldrIdKey buildName = varQual gHC_INTERNAL_BASE (fsLit "build") buildIdKey augmentName = varQual gHC_INTERNAL_BASE (fsLit "augment") augmentIdKey -mapName = varQual gHC_INTERNAL_BASE (fsLit "map") mapIdKey assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey @@ -2063,7 +2065,7 @@ rootMainKey, runMainKey :: KnownKeyNameKey rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: KnownKeyNameKey +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: KnownKeyNameKey thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2096,52 +2098,53 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: KnownKeyNameKey rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 -seqHashKey = mkPreludeMiscIdUnique 134 - -coerceKey :: KnownKeyNameKey -coerceKey = mkPreludeMiscIdUnique 157 -{- -Certain class operations from Prelude classes. They get their own -uniques so we can look them up easily when we want to conjure them up -during type checking. --} +seqHashKey, coerceKey :: KnownKeyNameKey +seqHashKey = mkPreludeMiscIdUnique 134 +coerceKey = mkPreludeMiscIdUnique 135 -- Just a placeholder for unbound variables produced by the renamer: unboundKey :: KnownKeyNameKey -unboundKey = mkPreludeMiscIdUnique 158 +unboundKey = mkPreludeMiscIdUnique 136 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey :: KnownKeyNameKey -fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 -minusClassOpKey = mkPreludeMiscIdUnique 161 -fromRationalClassOpKey = mkPreludeMiscIdUnique 162 -enumFromClassOpKey = mkPreludeMiscIdUnique 163 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 -enumFromToClassOpKey = mkPreludeMiscIdUnique 165 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 -eqClassOpKey = mkPreludeMiscIdUnique 167 -geClassOpKey = mkPreludeMiscIdUnique 168 -negateClassOpKey = mkPreludeMiscIdUnique 169 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) 02L -thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 173 -returnMClassOpKey = mkPreludeMiscIdUnique 174 +fromIntegerClassOpKey = mkPreludeMiscIdUnique 140 +minusClassOpKey = mkPreludeMiscIdUnique 141 +fromRationalClassOpKey = mkPreludeMiscIdUnique 142 +enumFromClassOpKey = mkPreludeMiscIdUnique 143 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 144 +enumFromToClassOpKey = mkPreludeMiscIdUnique 145 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 146 + +eqClassOpKey = mkPreludeMiscIdUnique 147 +geClassOpKey = mkPreludeMiscIdUnique 148 +leClassOpKey = mkPreludeMiscIdUnique 149 +ltClassOpKey = mkPreludeMiscIdUnique 150 +gtClassOpKey = mkPreludeMiscIdUnique 151 +compareClassOpKey = mkPreludeMiscIdUnique 152 + + +negateClassOpKey = mkPreludeMiscIdUnique 153 +bindMClassOpKey = mkPreludeMiscIdUnique 154 +thenMClassOpKey = mkPreludeMiscIdUnique 155 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 156 +returnMClassOpKey = mkPreludeMiscIdUnique 157 -- Recursive do notation mfixIdKey :: KnownKeyNameKey -mfixIdKey = mkPreludeMiscIdUnique 175 +mfixIdKey = mkPreludeMiscIdUnique 158 -- MonadFail operations failMClassOpKey :: KnownKeyNameKey -failMClassOpKey = mkPreludeMiscIdUnique 176 +failMClassOpKey = mkPreludeMiscIdUnique 159 -- fromLabel fromLabelClassOpKey :: KnownKeyNameKey -fromLabelClassOpKey = mkPreludeMiscIdUnique 177 +fromLabelClassOpKey = mkPreludeMiscIdUnique 160 -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, @@ -2180,6 +2183,7 @@ ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: KnownKeyNameKey isListClassKey = mkPreludeMiscIdUnique 198 fromListClassOpKey = mkPreludeMiscIdUnique 199 + fromListNClassOpKey = mkPreludeMiscIdUnique 500 toListClassOpKey = mkPreludeMiscIdUnique 501 ===================================== compiler/GHC/HsToCore/ListComp.hs ===================================== @@ -118,7 +118,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM -- Create an unzip function for the appropriate arity and element types and find "map" unzip_stuff' <- mkUnzipBind form from_bndrs_tys - map_id <- dsLookupGlobalId mapName + map_id <- dsLookupKnownKeyId mapIdKey -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -27,7 +27,7 @@ module GHC.HsToCore.Monad ( dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, - dsLookupKnownKey, dsLookupKnownKeyTyCon, dsLookupKnownKeyId, + dsLookupKnownKeyTyCon, dsLookupKnownKeyId, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, @@ -563,13 +563,26 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal -dsLookupKnownKey :: KnownKeyNameKey -> DsM TyThing -dsLookupKnownKey uniq +dsGetKnownKeySource :: DsM KnownKeyNameSource +dsGetKnownKeySource = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames - ; mb_rdr_env <- if rebindable_path - then do { rdr_env <- dsGetGlobalRdrEnv - ; return (KKNS_InScope rdr_env) } - else return KKNS_FromModule + ; if rebindable_path + then do { rdr_env <- dsGetGlobalRdrEnv + ; return (KKNS_InScope rdr_env) } + else return KKNS_FromModule } + +dsLookupKnownKeyName :: KnownKeyNameKey -> DsM Name +dsLookupKnownKeyName uniq + = do { rebindable_path <- dsGetKnownKeySource + ; dsToIfL $ + do { mb_res <- lookupKnownKeyName mb_rdr_env uniq + ; case mb_res of + Succeeded name -> return name + Failed msg -> failIfM (pprDiagnostic msg) } } + +dsLookupKnownKeyThing :: KnownKeyNameKey -> DsM TyThing +dsLookupKnownKeyThing uniq + = do { rebindable_path <- dsGetKnownKeySource ; dsToIfL $ do { mb_res <- lookupKnownKeyThing mb_rdr_env uniq ; case mb_res of @@ -578,11 +591,11 @@ dsLookupKnownKey uniq dsLookupKnownKeyTyCon :: KnownKeyNameKey -> DsM TyCon dsLookupKnownKeyTyCon uniq - = tyThingTyCon <$> dsLookupKnownKey uniq + = tyThingTyCon <$> dsLookupKnownKeyThing uniq dsLookupKnownKeyId :: KnownKeyNameKey -> DsM Id dsLookupKnownKeyId uniq - = tyThingId <$> dsLookupKnownKey uniq + = tyThingId <$> dsLookupKnownKeyThing uniq dsLookupGlobal :: Name -> DsM TyThing -- Very like GHC.Tc.Utils.Env.tcLookupGlobal ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -2315,9 +2315,14 @@ lookupOccDsM n globalVar :: Name -> DsM (Core TH.Name) globalVar n = case nameModule_maybe n of - Just m -> globalVarExternal m (getOccName n) + Just m -> globalVarExternal m (getOccName n) Nothing -> globalVarLocal (getUnique n) (getOccName n) +globalKnownKey :: KnonwKeyNameKey -> DsM (Core TH.Name) +globalKnownKey key + = do { name <- dsLookupKnownKeyName key + ; globalVar name } + globalVarLocal :: Unique -> OccName -> DsM (Core TH.Name) globalVarLocal unique name = do { MkC occ <- occNameLit name @@ -3150,7 +3155,8 @@ repRdrName rdr_name = do occ <- occNameLit occ repNameQ mod occ Orig m n -> lift $ globalVarExternal m n - Exact n -> lift $ globalVar n + Exact (ExactName n) -> lift $ globalVar n + Exact (ExactKey key _) -> lift $ globalKnownKey key repNameS :: Core String -> MetaM (Core TH.Name) repNameS (MkC name) = rep2_nw mkNameSName [name] ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -864,7 +864,9 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns +setRdrNameSpace (Exact (ExactKey k o)) ns -- Highly suspicious + = Exact (ExactKey k (setOccNameSpace ns o)) +setRdrNameSpace (Exact (ExactName n)) ns | Just thing <- wiredInNameTyThing_maybe n = setWiredInNameSpace thing ns -- Preserve Exact Names for wired-in things, @@ -875,7 +877,7 @@ setRdrNameSpace (Exact n) ns | otherwise -- This can happen when quoting and then -- splicing a fixity declaration for a type - = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + = nameRdrName (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) where occ = setOccNameSpace ns (nameOccName n) @@ -884,13 +886,13 @@ setWiredInNameSpace (ATyCon tc) ns | isDataConNameSpace ns = ty_con_data_con tc | isTcClsNameSpace ns - = Exact (getName tc) -- No-op + = nameRdrName (getName tc) -- No-op setWiredInNameSpace (AConLike (RealDataCon dc)) ns | isTcClsNameSpace ns = data_con_ty_con dc | isDataConNameSpace ns - = Exact (getName dc) -- No-op + = nameRdrName (getName dc) -- No-op setWiredInNameSpace thing ns = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) @@ -899,10 +901,10 @@ ty_con_data_con :: TyCon -> RdrName ty_con_data_con tc | isTupleTyCon tc , Just dc <- tyConSingleDataCon_maybe tc - = Exact (getName dc) + = nameRdrName (getName dc) | tc `hasKey` listTyConKey - = Exact nilDataConName + = nameRdrName nilDataConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace srcDataName (getOccName tc)) @@ -911,10 +913,10 @@ data_con_ty_con :: DataCon -> RdrName data_con_ty_con dc | let tc = dataConTyCon dc , isTupleTyCon tc - = Exact (getName tc) + = nameRdrName (getName tc) | dc `hasKey` nilDataConKey - = Exact listTyConName + = nameRdrName listTyConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace tcClsName (getOccName dc)) ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -485,8 +485,13 @@ data ExactOrOrigResult -- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult lookupExactOrOrig_base rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code + | Just n <- rdrNameExactName_maybe rdr_name -- This happens in derived code = cvtEither <$> lookupExactOcc_either n + + | Just key <- exactKeyRdr_maybe rdr_name + = do { name <- rnLookupKnownKeyName key + ; cvtEither <$> lookupExactOcc_either name } + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { nm <- lookupOrig rdr_mod rdr_occ @@ -499,6 +504,7 @@ lookupExactOrOrig_base rdr_name ; return $ case mb_gre of Left err -> ExactOrOrigError err Right gre -> FoundExactOrOrig gre } + | otherwise = return NotExactOrOrig where cvtEither (Left e) = ExactOrOrigError e ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -1656,17 +1656,17 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon as_needed = take con_arity as_RDRs lift_Expr = mk_bracket finish con_brack :: LHsExpr GhcPs - con_brack = nlHsApps (Exact conEName) + con_brack = nlHsApps (nameRdrName conEName) [noLocA $ HsUntypedBracket noExtField - $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))] + $ VarBr noSrcSpanA True (noLocA (nameRdrName (dataConName data_con)))] - finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed) + finish = foldl' (\b1 b2 -> nlHsApps (nameRdrName appEName) [b1, b2]) con_brack (map lift_var as_needed) lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed) lift_var x = nlHsPar (mk_lift_expr x) mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed) - mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x] + mk_lift_expr x = nlHsApps (nameRdrName liftName) [nlHsVar x] {- ************************************************************************ @@ -2612,7 +2612,7 @@ new_dc_deriv_rdr_name loc dc occ_fun newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName newAuxBinderRdrName loc parent occ_fun = do uniq <- newUnique - pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc + pure $ nameRdrName $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc -- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@ -- whose return types match when checked against @tycon_args@. ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1552,12 +1552,12 @@ instance TH.Quasi TcM where = addErr $ TcRnTHError $ AddTopDeclsError $ InvalidTopDecl d bindName :: RdrName -> TcM () - bindName (Exact n) + bindName rdr_name + | Just n <- rdrNameExactName_maybe rdr_nname = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) } + | otherwise + = addErr $ TcRnTHError $ THNameError $ NonExactName rdr_name qAddForeignFilePath lang fp = do var <- fmap tcg_th_foreign_files getGblEnv ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1889,7 +1889,7 @@ cvtTypeKind typeOrKind ty hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs hsTypeToArrow w = case unLoc w of - HsTyVar _ _ (L _ (isExact_maybe -> Just n)) + HsTyVar _ _ (L _ (rdrNameExactName_maybe -> Just n)) | n == oneDataConName -> HsLinearAnn noAnn | n == manyDataConName -> HsUnannotated (EpArrow noAnn) _ -> HsExplicitMult (noAnn, EpArrow noAnn) w @@ -2319,7 +2319,7 @@ thOrigOrExactRdrName occ th_ns pkg mod = knownOrigToExactRdrName (thOrigRdrName knownOrigToExactRdrName :: RdrName -> RdrName knownOrigToExactRdrName (Orig mod occ) | Just name <- isKnownOrigName_maybe mod occ - = Exact name + = nameRdrName name knownOrigToExactRdrName rdr = rdr -- Return an exact RdrName if we're dealing with built-in syntax. ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -26,18 +26,20 @@ module GHC.Types.Name.Reader ( -- * The main type RdrName(..), -- Constructors exported only to GHC.Iface.Binary + ExactRdrName(..), -- ** Construction mkRdrUnqual, mkRdrQual, mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, + nameRdrName, knownKeyRdrName, getRdrName, -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTcCls, demoteRdrNameTv, promoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + isOrig, isOrig_maybe, isExact, + rdrNameExactName_maybe, rdrNameKnownKey_maybe, isSrcRdrName, -- ** Preserving user-written qualification WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, @@ -196,7 +198,7 @@ data RdrName -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' - | Exact ExactSpec + | Exact ExactRdrName -- ^ Exact name -- -- We know exactly the 'Name'. This is used: @@ -209,9 +211,14 @@ data RdrName -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data -data ExactSpec - = ExactName Name -- Use this when you know the exact Name - | ExactKey KnownKeyNameKey -- Use this for known-key names +data ExactRdrName + = ExactName -- Use this when you know the exact Name + Name + + | ExactKey -- Use this for known-key names + KnownKeyNameKey + OccName -- This OccName corresponds to the key + deriving Data {- @@ -229,7 +236,8 @@ rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name +rdrNameOcc (Exact (ExactName name)) = nameOccName name +rdrNameOcc (Exact (ExactKey _ occ)) = occ rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -291,16 +299,19 @@ mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) +knownKeyRdrName :: KnownKeyNameKey -> OccName -> RdrName +knownKeyRdrName key occ = Exact (ExactKey key occ) + nameRdrName :: Name -> RdrName nameRdrName name = Exact (ExactName name) -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) +-- nukeExact :: Name -> RdrName +-- nukeExact n +-- | isExternalName n = Orig (nameModule n) (nameOccName n) +-- | otherwise = Unqual (nameOccName n) isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool @@ -339,9 +350,13 @@ isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing +rdrNameExactName_maybe :: RdrName -> Maybe Name +rdrNameExactName_maybe (Exact (ExactName n)) = Just n +rdrNameExactName_maybe _ = Nothing + +rdrNameKnownKey_maybe :: RdrName -> Maybe KnownKeyNameKey +rdrNameKnownKey_maybe (Exact (ExactKey k _)) = Just k +rdrNameKnownKey_maybe _ = Nothing {- ************************************************************************ @@ -352,7 +367,8 @@ isExact_maybe _ = Nothing -} instance Outputable RdrName where - ppr (Exact name) = ppr name + ppr (Exact (ExactName name)) = ppr name + ppr (Exact (ExactKey key occ)) = ppr occ <> braces (pprKnownKey key) ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) @@ -364,16 +380,28 @@ instance OutputableBndr RdrName where pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name + | Just name <- rdrNameExactName_maybe rdr = pprPrefixName name -- pprPrefixName has some special cases, so -- we delegate to them rather than reproduce them | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) +instance Eq ExactRdrName where + (ExactName n1) == (ExactName n2) = n1==n2 + (ExactKey k1 _) == (ExactKey k2 _) = k1==k2 + _ == _ = False + +instance Ord ExactRdrName where + (ExactName n1) `compare` (ExactName n2) = n1 `compare` n2 + (ExactName {}) `compare` (ExactKey {}) = LT + (ExactKey {}) `compare` (ExactName {}) = GT + (ExactKey k1 _) `compare` (ExactKey k2 _) = k1 `nonDetCmpUnique` k2 + instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 +-- (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 +-- r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 @@ -471,7 +499,7 @@ lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr = lookupOccEnv env occ -- See Note [Local bindings with Exact Names] - | Exact name <- rdr + | Just name <- rdrNameExactName_maybe rdr , name `elemNameSet` ns = Just name @@ -492,8 +520,9 @@ lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Unqual occ -> occ `elemOccEnv` env + Exact (ExactName name) -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Exact (ExactKey{}) -> False Qual {} -> False Orig {} -> False ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -67,6 +67,7 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import GHC.Word ( Word64 ) import Data.Char ( chr, ord, isPrint ) +import Data.Data ( Data ) import Language.Haskell.Syntax.Module.Name @@ -128,6 +129,7 @@ Prefer `env_ut :: Char` and -- -- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Word64 + deriving Data -- Needed only because KnownKeyNameKey is in RdrName data UniqueTag = AlphaTyVarTag View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a6fbce9a799ad24d05b864f43ddc5b3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a6fbce9a799ad24d05b864f43ddc5b3... You're receiving this email because of your account on gitlab.haskell.org.