Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 67d4bd98 by Simon Peyton Jones at 2026-04-05T00:56:00+01:00 More .. forging ahead with KnownOccs - - - - - 27 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/Utils.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Deriv/RdrNames.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Info.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -120,15 +120,10 @@ import GHC.Unit.Types import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique -import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Builtin.Uniques -import GHC.Builtin.Names.TH( thKnownKeyTable ) - -import GHC.Utils.Panic -import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Data.FastString import GHC.Data.List.Infinite (Infinite (..)) @@ -185,27 +180,9 @@ names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in GHC.Builtin.Types etc. -} --- | `knownKeyOccMap` maps the OccName of a known-key to its Unique -knownKeyOccMap :: OccEnv KnownKey -knownKeyOccMap = mkOccEnv knownKeyTable - -knownKeyUniqMap :: UniqFM KnownKey OccName -knownKeyUniqMap = listToUFM [ (uniq, occ) | (occ, uniq) <- knownKeyTable ] - -knownKeyTable :: [(OccName, KnownKey)] -knownKeyTable = basicKnownKeyTable ++ thKnownKeyTable - -knownKeyOccName :: HasDebugCallStack => KnownKey -> OccName --- Find the OccName from the KnownKey, --- by looking in the knownKeyUniqMap -knownKeyOccName std_uniq - = case lookupUFM knownKeyUniqMap std_uniq of - Just occ -> occ - Nothing -> pprPanic "knownKeyOccName" (pprKnownKey std_uniq) - basicKnownKeyTable :: [(OccName, KnownKey)] basicKnownKeyTable - = [ (mkTcOcc "Rational", rationalTyConKey) + = [ (rationalTyConOcc, rationalTyConKey) , (mkTcOcc "Show", showClassKey) , (mkTcOcc "Foldable", foldableClassKey) , (mkTcOcc "Traversable", traversableClassKey) @@ -255,9 +232,9 @@ basicKnownKeyTable -- Class Monad, MonadFix, MonadZip , (mkTcOcc "Monad", monadClassKey) - , (mkVarOcc ">>", thenMClassOpKey) + , (thenMClassOpOcc, thenMClassOpKey) , (mkVarOcc ">>=", bindMClassOpKey) - , (mkVarOcc "return", returnMClassOpKey) + , (returnMClassOpOcc, returnMClassOpKey) , (mkVarOcc "fail", failMClassOpKey) , (mkVarOcc "guard", guardMIdKey) , (mkVarOcc "mfix", mfixIdKey) @@ -267,14 +244,14 @@ basicKnownKeyTable , (mkTcOcc "Applicative", applicativeClassKey) , (mkVarOcc "mzip", mzipIdKey) , (mkVarOcc "<*>", apAClassOpKey) - , (mkVarOcc "pure", pureAClassOpKey) - , (mkVarOcc "*>", thenAClassOpKey) + , (pureAClassOpOcc, pureAClassOpKey) + , (thenAClassOpOcc, thenAClassOpKey) -- Class Semigroup, Monoid , (mkTcOcc "Semigroup", semigroupClassKey) , (mkTcOcc "Monoid", monoidClassKey) - , (mkVarOcc "<>", sappendClassOpKey) - , (mkVarOcc "mappend", mappendClassOpKey) + , (sappendClassOpOcc, sappendClassOpKey) + , (mappendClassOpOcc, mappendClassOpKey) , (mkVarOcc "mempty", memptyClassOpKey) -- Class IsString @@ -297,9 +274,9 @@ basicKnownKeyTable -- , (mkVarOcc "setField", setFieldClassOpKey) -- FromList - , (mkVarOcc "isList", fromListClassOpKey) - , (mkVarOcc "isList", fromListNClassOpKey) - , (mkVarOcc "isList", toListClassOpKey) + , (mkVarOcc "fromList", fromListClassOpKey) + , (mkVarOcc "fromListN", fromListNClassOpKey) + , (mkVarOcc "toList", toListClassOpKey) -- Arrows , (mkVarOcc "arr", arrAIdKey) @@ -1184,14 +1161,31 @@ clsQual modu str unique = mk_known_key_name clsName modu str unique dcQual modu str unique = mk_known_key_name dataName modu str unique -{- -************************************************************************ +{- ********************************************************************* * * -\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} + Statically-known occurrence names * * -************************************************************************ ---MetaHaskell extension hand allocate keys here --} +********************************************************************* -} + +integerTyConOcc, rationalTyConOcc :: KnownOcc +rationalTyConOcc = mkTcOcc "Rational" +integerTyConOcc = mkTcOcc "Integer" + +sappendClassOpOcc, pureAClassOpOcc, thenAClassOpOcc, + returnMClassOpOcc, thenMClassOpOcc, mappendClassOpOcc :: KnownOcc +sappendClassOpOcc = mkVarOcc "<>" +pureAClassOpOcc = mkVarOcc "pure" +returnMClassOpOcc = mkVarOcc "return" +thenMClassOpOcc = mkVarOcc ">>" +thenAClassOpOcc = mkVarOcc "*>" +mappendClassOpOcc = mkVarOcc "mappend" + + +{- ********************************************************************* +* * + Statically-known keys +* * +********************************************************************* -} boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, @@ -1948,11 +1942,10 @@ ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 -- Overloaded lists isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: KnownKey -isListClassKey = mkPreludeMiscIdUnique 198 -fromListClassOpKey = mkPreludeMiscIdUnique 199 - +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 fromListNClassOpKey = mkPreludeMiscIdUnique 500 -toListClassOpKey = mkPreludeMiscIdUnique 501 +toListClassOpKey = mkPreludeMiscIdUnique 501 proxyHashKey :: KnownKey proxyHashKey = mkPreludeMiscIdUnique 502 ===================================== compiler/GHC/Builtin/Names/TH.hs ===================================== @@ -9,8 +9,8 @@ module GHC.Builtin.Names.TH where import GHC.Prelude () import GHC.Unit.Types -import GHC.Types.Name( Name, mk_known_key_name ) -import GHC.Types.Name.Occurrence( OccName, tcName, clsName, dataName, varName, fieldName ) +import GHC.Types.Name( Name, KnownOcc, mk_known_key_name ) +import GHC.Types.Name.Occurrence import GHC.Types.Unique ( Unique ) import GHC.Builtin.Uniques import GHC.Data.FastString @@ -26,6 +26,11 @@ import Language.Haskell.Syntax.Module.Name thKnownKeyTable :: [(OccName,Unique)] thKnownKeyTable = [] +templateHaskellOccs :: [OccName] +templateHaskellOccs + = [ expTyConOcc + , litPOcc ] + templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of GHC.HsToCore.Quote @@ -44,11 +49,6 @@ templateHaskellNames = [ charLName, stringLName, integerLName, intPrimLName, wordPrimLName, floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, charPrimLName, - -- Pat - litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, - conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName, - typePName, invisPName, orPName, -- FieldPat fieldPatName, -- Match @@ -217,6 +217,9 @@ liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey quoteClassName :: Name quoteClassName = thMonadCls (fsLit "Quote") quoteClassKey +expTyConOcc :: KnownOcc +expTyConOcc = mkTcOcc "Exp" + qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName, @@ -280,27 +283,27 @@ stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey -- data Pat = ... -litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, - infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, - sigPName, viewPName, typePName, invisPName, orPName :: Name -litPName = libFun (fsLit "litP") litPIdKey -varPName = libFun (fsLit "varP") varPIdKey -tupPName = libFun (fsLit "tupP") tupPIdKey -unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey -unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey -conPName = libFun (fsLit "conP") conPIdKey -infixPName = libFun (fsLit "infixP") infixPIdKey -tildePName = libFun (fsLit "tildeP") tildePIdKey -bangPName = libFun (fsLit "bangP") bangPIdKey -asPName = libFun (fsLit "asP") asPIdKey -wildPName = libFun (fsLit "wildP") wildPIdKey -recPName = libFun (fsLit "recP") recPIdKey -listPName = libFun (fsLit "listP") listPIdKey -sigPName = libFun (fsLit "sigP") sigPIdKey -viewPName = libFun (fsLit "viewP") viewPIdKey -orPName = libFun (fsLit "orP") orPIdKey -typePName = libFun (fsLit "typeP") typePIdKey -invisPName = libFun (fsLit "invisP") invisPIdKey +litPOcc, varPOcc, tupPOcc, unboxedTupPOcc, unboxedSumPOcc, conPOcc, + infixPOcc, tildePOcc, bangPOcc, asPOcc, wildPOcc, recPOcc, listPOcc, + sigPOcc, viewPOcc, typePOcc, invisPOcc, orPOcc :: KnownOcc +litPOcc = mkVarOcc "litP" +varPOcc = mkVarOcc "varP" +tupPOcc = mkVarOcc "tupP" +unboxedTupPOcc = mkVarOcc "unboxedTupP" +unboxedSumPOcc = mkVarOcc "unboxedSumP" +conPOcc = mkVarOcc "conP" +infixPOcc = mkVarOcc "infixP" +tildePOcc = mkVarOcc "tildeP" +bangPOcc = mkVarOcc "bangP" +asPOcc = mkVarOcc "asP" +wildPOcc = mkVarOcc "wildP" +recPOcc = mkVarOcc "recP" +listPOcc = mkVarOcc "listP" +sigPOcc = mkVarOcc "sigP" +viewPOcc = mkVarOcc "viewP" +orPOcc = mkVarOcc "orP" +typePOcc = mkVarOcc "typeP" +invisPOcc = mkVarOcc "invisP" -- type FieldPat = ... fieldPatName :: Name ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -18,15 +18,16 @@ -- about the two types of prelude things in GHC. -- module GHC.Builtin.Utils ( + -- * Main exports + wiredInNames, wiredInIds, ghcPrimIds, + knownKeyTable, knownKeyOccMap, knownKeyUniqMap, knownKeyOccName, + -- * Known-key names oldIsKnownKeyName, oldLookupKnownKeyName, oldLookupKnownNameInfo, - -- * Miscellaneous - wiredInNames, wiredInIds, ghcPrimIds, - ghcPrimExports, ghcPrimDeclDocs, ghcPrimWarns, @@ -48,8 +49,9 @@ import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Types import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Builtin.Types.Prim -import GHC.Builtin.Names.TH ( templateHaskellNames ) -import GHC.Builtin.Names +import GHC.Builtin.Names.TH ( templateHaskellNames, thKnownKeyTable ) +import GHC.Builtin.Names( basicKnownKeyTable, basicKnownKeyNames ) +import GHC.Builtin.Names( charDataConKey, intDataConKey, numericClassKeys, standardClassKeys ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.DataCon @@ -63,10 +65,10 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.SourceText +import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Map import GHC.Types.TyThing -import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways ) import GHC.Utils.Outputable import GHC.Utils.Misc as Utils @@ -83,10 +85,38 @@ import GHC.Data.List.SetOps import Control.Applicative ((<|>)) import Data.Maybe -{- -************************************************************************ + + +{- ********************************************************************* +* * + Known-key things +* * +********************************************************************* -} + +-- | `knownKeyOccMap` maps the OccName of a known-key to its Unique +knownKeyOccMap :: OccEnv KnownKey +knownKeyOccMap = mkOccEnv knownKeyTable + +knownKeyUniqMap :: UniqFM KnownKey OccName +knownKeyUniqMap = listToUFM [ (uniq, occ) | (occ, uniq) <- knownKeyTable ] + +knownKeyTable :: [(OccName, KnownKey)] +knownKeyTable = [ (getOccName n, getUnique n) | n <- wiredInNames ] ++ + basicKnownKeyTable ++ + thKnownKeyTable + +knownKeyOccName :: HasDebugCallStack => KnownKey -> OccName +-- Find the OccName from the KnownKey, +-- by looking in the knownKeyUniqMap +knownKeyOccName std_uniq + = case lookupUFM knownKeyUniqMap std_uniq of + Just occ -> occ + Nothing -> pprPanic "knownKeyOccName" (pprKnownKey std_uniq) + + +{- ********************************************************************* * * -\subsection[builtinNameInfo]{Lookup built-in names} + Wired-in things * * ************************************************************************ @@ -114,7 +144,6 @@ Note [About wired-in things] -- code, or in an interface file, you get a Name with the correct known key (See -- Note [Known-key names] in "GHC.Builtin.Names") wiredInNames :: [Name] --- ToDo: rename to wiredInNames wiredInNames | debugIsOn , Just badNamesDoc <- knownKeyNamesOkay all_names ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -29,6 +29,7 @@ module GHC.HsToCore.Monad ( dsLookupDataCon, dsLookupConLike, dsLookupKnownKeyTyCon, dsLookupKnownKeyId, dsLookupKnownKeyName, + dsLookupKnownOccId, dsLookupKnownOccTyCon, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, @@ -566,6 +567,13 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal + +{- ********************************************************************* +* * + Looking things up in the monad +* * +********************************************************************* -} + dsGetKnownKeySource :: DsM KnownKeyNameSource dsGetKnownKeySource = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames @@ -574,11 +582,32 @@ dsGetKnownKeySource ; return (KKNS_InScope rdr_env) } else return KKNS_FromModule } +-------------------------------------- +-- Lookups for known-occ things + +dsLookupKnownOccThing :: KnownOcc -> DsM TyThing +dsLookupKnownOccThing occ + = do { rebindable_src <- dsGetKnownKeySource + ; dsToIfL $ + do { mb_res <- lookupKnownOccThing occ rebindable_src + ; case mb_res of + Succeeded thing -> return thing + Failed msg -> failIfM (pprDiagnostic msg) } } + +dsLookupKnownOccTyCon :: KnownOcc -> DsM TyCon +dsLookupKnownOccTyCon uniq = tyThingTyCon <$> dsLookupKnownOccThing uniq + +dsLookupKnownOccId :: KnownOcc -> DsM Id +dsLookupKnownOccId uniq = tyThingId <$> dsLookupKnownOccThing uniq + +-------------------------------------- +-- Lookups for known-key things + dsLookupKnownKeyName :: KnownKey -> DsM Name dsLookupKnownKeyName uniq = do { rebindable_src <- dsGetKnownKeySource ; dsToIfL $ - do { mb_res <- lookupKnownKeyName rebindable_src uniq + do { mb_res <- lookupKnownKeyName uniq rebindable_src ; case mb_res of Succeeded name -> return name Failed msg -> failIfM (pprDiagnostic msg) } } @@ -587,39 +616,41 @@ dsLookupKnownKeyThing :: KnownKey -> DsM TyThing dsLookupKnownKeyThing uniq = do { rebindable_src <- dsGetKnownKeySource ; dsToIfL $ - do { mb_res <- lookupKnownKeyThing rebindable_src uniq + do { mb_res <- lookupKnownKeyThing uniq rebindable_src ; case mb_res of Succeeded thing -> return thing Failed msg -> failIfM (pprDiagnostic msg) } } dsLookupKnownKeyTyCon :: KnownKey -> DsM TyCon -dsLookupKnownKeyTyCon uniq - = tyThingTyCon <$> dsLookupKnownKeyThing uniq +dsLookupKnownKeyTyCon uniq = tyThingTyCon <$> dsLookupKnownKeyThing uniq dsLookupKnownKeyId :: KnownKey -> DsM Id -dsLookupKnownKeyId uniq - = tyThingId <$> dsLookupKnownKeyThing uniq +dsLookupKnownKeyId uniq = tyThingId <$> dsLookupKnownKeyThing uniq + +-------------------------------------- +-- Lookups given a Name dsLookupGlobal :: Name -> DsM TyThing --- Very like GHC.Tc.Utils.Env.tcLookupGlobal dsLookupGlobal name = dsToIfL (tcIfaceGlobal name) dsLookupGlobalId :: Name -> DsM Id -dsLookupGlobalId name - = tyThingId <$> dsLookupGlobal name +dsLookupGlobalId name = tyThingId <$> dsLookupGlobal name dsLookupTyCon :: Name -> DsM TyCon -dsLookupTyCon name - = tyThingTyCon <$> dsLookupGlobal name +dsLookupTyCon name = tyThingTyCon <$> dsLookupGlobal name dsLookupDataCon :: Name -> DsM DataCon -dsLookupDataCon name - = tyThingDataCon <$> dsLookupGlobal name +dsLookupDataCon name = tyThingDataCon <$> dsLookupGlobal name dsLookupConLike :: Name -> DsM ConLike -dsLookupConLike name - = tyThingConLike <$> dsLookupGlobal name +dsLookupConLike name = tyThingConLike <$> dsLookupGlobal name + +{- ********************************************************************* +* * + Other monadic operations +* * +********************************************************************* -} dsGetFamInstEnvs :: DsM FamInstEnvs -- Gets both the external-package inst-env ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -55,7 +55,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc (lastMaybe) import GHC.Data.Maybe import GHC.Core.Type -import GHC.Core.TyCon import GHC.Types.Literal import GHC.Types.Literal.Floating import GHC.Core @@ -63,6 +62,7 @@ import GHC.Core.TyCo.Compare( eqType, nonDetCmpType ) import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names +import GHC.Builtin.Utils( knownKeyOccName ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Tc.Solver.InertSet (InertSet, emptyInertSet) @@ -703,7 +703,7 @@ coreExprAsPmLit e = case collectArgs e of -> Just (PmLit ty (PmLitInt l)) (Var x, [_ty, n_arg, d_arg]) | Just dc <- isDataConWorkId_maybe x - , dataConName dc == ratioDataConName + , dc `hasKnownKey` ratioDataConKey , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg -> Just (PmLit (exprType e) (PmLitRat (n % d))) @@ -730,7 +730,7 @@ coreExprAsPmLit e = case collectArgs e of , [r, exp] <- dropWhile (not . is_ratio) args , (Var x, [_ty, n_arg, d_arg]) <- collectArgs r , Just dc <- isDataConWorkId_maybe x - , dataConName dc == ratioDataConName + , dc `hasKnownKey` ratioDataConKey , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg , Just (_exp_ty,exp') <- bignum_conapp_maybe exp @@ -753,7 +753,7 @@ coreExprAsPmLit e = case collectArgs e of , ty `eqType` charTy -> literalToPmLit stringTy (mkLitString "") (Var x, [Lit l]) - | idName x `elem` [unpackCStringName, unpackCStringUtf8Name] + | idUnique x `elem` [unpackCStringIdKey, unpackCStringUtf8IdKey] -> literalToPmLit stringTy l _ -> Nothing @@ -775,7 +775,7 @@ coreExprAsPmLit e = case collectArgs e of is_ratio (Type _) = False is_ratio r | Just (tc, _) <- splitTyConApp_maybe (exprType r) - = tyConName tc == ratioTyConName + = tc `hasKnownKey` ratioTyConKey | otherwise = False is_larg_exp_ratio x ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -2427,6 +2427,27 @@ rep2X lift_dsm get_wrap n xs = do ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } +krep2M :: KnownOcc -> [CoreExpr] -> MetaM (Core (M a)) +krep2 :: KnownOcc -> [CoreExpr] -> MetaM (Core (M a)) +krep2_nw :: NotM a => KnownOcc -> [CoreExpr] -> MetaM (Core a) +krep2_nwDsM :: NotM a => KnownOcc -> [CoreExpr] -> DsM (Core a) +krep2 = krep2X lift (asks quoteWrapper) +krep2M = krep2X lift (asks monadWrapper) +krep2_nw n xs = lift (krep2_nwDsM n xs) +krep2_nwDsM = krep2X id (return id) + +krep2X :: Monad m => (forall z . DsM z -> m z) + -> m (CoreExpr -> CoreExpr) + -> KnownOcc + -> [ CoreExpr ] + -> m (Core a) +krep2X lift_dsm get_wrap n xs = do + { rep_id <- lift_dsm $ dsLookupKnownOccId n + ; wrap <- get_wrap + ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } + + + dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) dataCon' n args = do { id <- lift $ dsLookupDataCon n ; return $ MkC $ mkCoreConApps id args } @@ -2443,63 +2464,63 @@ dataCon n = dataCon' n [] --------------- Patterns ----------------- repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat)) -repPlit (MkC l) = rep2 litPName [l] +repPlit (MkC l) = krep2 litPOcc [l] repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat)) -repPvar (MkC s) = rep2 varPName [s] +repPvar (MkC s) = krep2 varPOcc [s] repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPtup (MkC ps) = rep2 tupPName [ps] +repPtup (MkC ps) = krep2 tupPOcc [ps] repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] +repPunboxedTup (MkC ps) = krep2 unboxedTupPOcc [ps] repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here repPunboxedSum (MkC p) alt arity = do { platform <- getPlatform - ; rep2 unboxedSumPName [ p + ; krep2 unboxedSumPOcc [ p , mkIntExprInt platform alt , mkIntExprInt platform arity ] } repPcon :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps] +repPcon (MkC s) (MkC ts) (MkC ps) = krep2 conPOcc [s, ts, ps] repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] +repPrec (MkC c) (MkC rps) = krep2 recPOcc [c,rps] repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] +repPinfix (MkC p1) (MkC n) (MkC p2) = krep2 infixPOcc [p1, n, p2] repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPtilde (MkC p) = rep2 tildePName [p] +repPtilde (MkC p) = krep2 tildePOcc [p] repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPbang (MkC p) = rep2 bangPName [p] +repPbang (MkC p) = krep2 bangPOcc [p] repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] +repPaspat (MkC s) (MkC p) = krep2 asPOcc [s, p] repPwild :: MetaM (Core (M TH.Pat)) -repPwild = rep2 wildPName [] +repPwild = krep2 wildPOcc [] repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPlist (MkC ps) = rep2 listPName [ps] +repPlist (MkC ps) = krep2 listPOcc [ps] repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPview (MkC e) (MkC p) = rep2 viewPName [e,p] +repPview (MkC e) (MkC p) = krep2 viewPOcc [e,p] repPor :: Core (NonEmpty (M TH.Pat)) -> MetaM (Core (M TH.Pat)) -repPor (MkC ps) = rep2 orPName [ps] +repPor (MkC ps) = krep2 orPOcc [ps] repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] +repPsig (MkC p) (MkC t) = krep2 sigPOcc [p, t] repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) -repPtype (MkC t) = rep2 typePName [t] +repPtype (MkC t) = krep2 typePOcc [t] repPinvis :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) -repPinvis (MkC t) = rep2 invisPName [t] +repPinvis (MkC t) = krep2 invisPOcc [t] --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -32,8 +32,7 @@ module GHC.Iface.Binary ( import GHC.Prelude -import GHC.Builtin.Utils ( oldIsKnownKeyName, oldLookupKnownKeyName ) -import GHC.Builtin.Names ( knownKeyOccMap ) +import GHC.Builtin.Utils ( knownKeyOccMap, oldIsKnownKeyName, oldLookupKnownKeyName ) import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Utils.Outputable ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -20,8 +20,10 @@ module GHC.Iface.Load ( loadGlobalName, -- Known-key things - KnownKeyNameSource(..), lookupKnownKeyThing, - lookupKnownKeyName, loadKnownKeyOccMaps, + KnownKeyNameSource(..), + lookupKnownKeyThing, lookupKnownKeyName, + lookupKnownOccThing, lookupKnownOccName, + loadKnownKeyOccMaps, -- RnM/TcM functions loadModuleInterface, loadModuleInterfaces, @@ -155,24 +157,24 @@ instance Outputable KnownKeyNameSource where ppr (KKNS_InScope env) = text "InScope" <> braces (ppr env) lookupKnownKeyThing :: HasDebugCallStack - => KnownKeyNameSource -> KnownKey + => KnownKey -> KnownKeyNameSource -> IfM lcl (MaybeErr IfaceMessage TyThing) -lookupKnownKeyThing mb_gbl_rdr_env key - = do { mb_name <- lookupKnownKeyName mb_gbl_rdr_env key +lookupKnownKeyThing key mb_gbl_rdr_env + = do { mb_name <- lookupKnownKeyName key mb_gbl_rdr_env ; case mb_name of Failed err -> return (Failed err) Succeeded name -> lookupGlobalName name } lookupKnownKeyName :: HasDebugCallStack - => KnownKeyNameSource -> KnownKey + => KnownKey -> KnownKeyNameSource -> IfM lcl (MaybeErr IfaceMessage Name) -lookupKnownKeyName KKNS_FromModule uniq +lookupKnownKeyName uniq KKNS_FromModule = do { (kk_map, _) <- loadKnownKeyOccMaps ; case lookupUFM kk_map uniq of Just name -> return (Succeeded name) Nothing -> return (Failed (MissingKnownKey1 uniq)) } -lookupKnownKeyName (KKNS_InScope gbl_rdr_env) uniq +lookupKnownKeyName uniq (KKNS_InScope gbl_rdr_env) -- Just gbl_rdr_env: we have -frebindable-known-key-names on, and -- here is the top-level GlobalRdrEnv -- Look up the /un-qualified/ known-key OccName in the GlobalRdrEnv @@ -180,7 +182,7 @@ lookupKnownKeyName (KKNS_InScope gbl_rdr_env) uniq | Just (occ :: OccName) <- lookupUFM knownKeyUniqMap uniq = case lookupGRE gbl_rdr_env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) of [gre] -> do { let name = greName gre - ; traceIf $ hang (text "lookupKnownKeyName NoImplicitKnownKeyNames") + ; traceIf $ hang (text "lookupKnownKeyName1 NoImplicitKnownKeyNames") 2 (ppr name <+> ppr uniq) ; return (Succeeded name) } gres -> return (Failed (KnownKeyScopeError occ gres)) @@ -188,6 +190,36 @@ lookupKnownKeyName (KKNS_InScope gbl_rdr_env) uniq | otherwise = return (Failed (MissingKnownKey2 uniq)) +lookupKnownOccThing :: HasDebugCallStack + => KnownOcc -> KnownKeyNameSource + -> IfM lcl (MaybeErr IfaceMessage TyThing) +lookupKnownOccThing occ mb_gbl_rdr_env + = do { mb_name <- lookupKnownOccName occ mb_gbl_rdr_env + ; case mb_name of + Failed err -> return (Failed err) + Succeeded name -> lookupGlobalName name } + +lookupKnownOccName :: HasDebugCallStack + => KnownOcc -> KnownKeyNameSource + -> IfM lcl (MaybeErr IfaceMessage Name) +lookupKnownOccName occ KKNS_FromModule + = do { (_, occ_map) <- loadKnownKeyOccMaps + ; case lookupOccEnv occ_map occ of + Just name -> return (Succeeded name) + Nothing -> return (Failed (MissingKnownKey3 occ)) } + +lookupKnownOccName occ (KKNS_InScope gbl_rdr_env) + -- Just gbl_rdr_env: we have -frebindable-known-key-names on, and + -- here is the top-level GlobalRdrEnv + -- Look up the /un-qualified/ known-key OccName in the GlobalRdrEnv + -- If we get a unique hit, use it; if not, panic. + = case lookupGRE gbl_rdr_env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) of + [gre] -> do { let name = greName gre + ; traceIf $ hang (text "lookupKnownKeyName2 NoImplicitKnownKeyNames") + 2 (ppr name <+> ppr occ) + ; return (Succeeded name) } + gres -> return (Failed (KnownKeyScopeError occ gres)) + loadKnownKeyOccMaps :: IfM lcl KnownKeyNameMaps loadKnownKeyOccMaps = do { eps <- getEps @@ -234,7 +266,9 @@ checkKnownKeyNamesIface :: UniqFM KnownKey Name -> Maybe SDoc -- and the the uniques and occ-names agree checkKnownKeyNamesIface known_key_names_occ_map | null bad_ones = Nothing - | otherwise = Just (ppr bad_ones) + | otherwise = Just $ braces $ fsep $ + [ parens (ppr occ <> comma <+> pprKnownKey key) + | (occ,key) <- bad_ones ] where bad_ones = filter is_bad knownKeyTable is_bad (occ, key) ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -58,7 +58,6 @@ import GHC.Prelude import GHC.Iface.Load import GHC.Iface.Env -import GHC.Iface.Errors.Types( IfaceMessage(..) ) import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types @@ -68,40 +67,48 @@ import GHC.Tc.Types.LclEnv import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Rename.Unbound +import GHC.Rename.Utils + import GHC.Builtin.Types -import GHC.Builtin.Names +import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Builtin.Utils( knownKeyOccMap, knownKeyOccName ) -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Avail -import GHC.Types.Hint import GHC.Unit.Module import GHC.Unit.Module.ModIface + import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Types.Basic ( TupleSort(..), tupleSortBoxity ) -import GHC.Types.TyThing ( tyThingGREInfo ) -import GHC.Types.SrcLoc as SrcLoc -import GHC.Utils.Outputable as Outputable + +import GHC.Driver.Env +import GHC.Driver.Session + +import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set +import GHC.Types.TyThing ( tyThingGREInfo ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Hint +import GHC.Types.CompleteMatch +import GHC.Types.PkgQual +import GHC.Types.GREInfo +import GHC.Types.Basic ( TupleSort(..), tupleSortBoxity ) + +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe -import GHC.Driver.Env -import GHC.Driver.Session import GHC.Data.FastString import GHC.Data.List.SetOps ( minusList ) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Unbound -import GHC.Rename.Utils import GHC.Data.Bag -import GHC.Types.CompleteMatch -import GHC.Types.PkgQual -import GHC.Types.GREInfo import Control.Monad import Data.Either ( partitionEithers ) @@ -1021,29 +1028,11 @@ we'll miss the fact that the qualified import is redundant. rnLookupKnownOccName :: HasDebugCallStack => KnownOcc -> RnM Name rnLookupKnownOccName occ = do { kk_source <- getKnownKeySource - ; mb_res <- lookup_known_occ kk_source occ + ; mb_res <- initIfaceTcRn (lookupKnownOccName occ kk_source) ; case mb_res of Failed err -> failWithTc (TcRnInterfaceError err) Succeeded name -> return name } -lookup_known_occ :: HasDebugCallStack - => KnownKeyNameSource -> KnownOcc - -> RnM (MaybeErr IfaceMessage Name) -lookup_known_occ KKNS_FromModule occ - = do { (_, occ_map) <- initIfaceTcRn loadKnownKeyOccMaps - ; case lookupOccEnv occ_map occ of - Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey3 occ)) } - -lookup_known_occ (KKNS_InScope gbl_rdr_env) occ - = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of - [gre] -> do { let name = greName gre - ; addUsedGRE NoDeprecationWarnings gre - ; traceIf $ hang (text "lookupKnownKeyOcc NoImplicitKnownKeyNames") - 2 (ppr name <+> ppr occ) - ; return (Succeeded name) } - gres -> return (Failed (KnownKeyScopeError occ gres)) - lookupLocatedOccRn :: WhatLooking -> GenLocated (EpAnn ann) RdrName -> TcRn (GenLocated (EpAnn ann) Name) ===================================== compiler/GHC/Tc/Deriv/RdrNames.hs ===================================== @@ -26,8 +26,9 @@ import GHC.Types.Id.Make( coerceName ) -- `coerce` is wired-in import GHC.Builtin.PrimOps import GHC.Builtin.Types -- A bunch of wired-in TyCons and DataCons import GHC.Builtin.PrimOps.Ids (primOpId) -import GHC.Builtin.Names +import GHC.Builtin.Utils( knownKeyOccName ) import GHC.Builtin.Names.TH( unsafeCodeCoerceName, liftTypedName ) +import GHC.Builtin.Names import GHC.Data.List.Infinite (Infinite (..)) import qualified GHC.Data.List.Infinite as Inf ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -38,11 +38,8 @@ import qualified GHC.Boot.TH.Syntax as TH -- import "ghc-internal" qualified GHC.Internal.TH.Syntax as TH import qualified GHC.Boot.TH.Ppr as TH -import GHC.Builtin.Names -import GHC.Builtin.Types - ( boxedRepDataConTyCon, tYPETyCon - , pretendNameIsInScope - ) +import GHC.Builtin.Types( boxedRepDataConTyCon, tYPETyCon, pretendNameIsInScope ) +import GHC.Builtin.Names -- A bunch of keys import GHC.Types.Name.Reader import GHC.Unit.Module.ModIface @@ -6556,18 +6553,16 @@ suggestNonCanonicalDefinition reason = where action = case reason of NonCanonicalMonoid sub -> case sub of - NonCanonical_Sappend -> move sappendClassOpKey mappendClassOpKey - NonCanonical_Mappend -> remove mappendClassOpKey sappendClassOpKey + NonCanonical_Sappend -> move sappendClassOpOcc mappendClassOpOcc + NonCanonical_Mappend -> remove mappendClassOpOcc sappendClassOpOcc NonCanonicalMonad sub -> case sub of - NonCanonical_Pure -> move pureAClassOpKey returnMClassOpKey - NonCanonical_ThenA -> move thenAClassOpKey thenMClassOpKey - NonCanonical_Return -> remove returnMClassOpKey pureAClassOpKey - NonCanonical_ThenM -> remove thenMClassOpKey thenAClassOpKey - - move lhs_key rhs_key - = SuggestMoveNonCanonicalDefinition (knownKeyOccName lhs_key) (knownKeyOccName rhs_key) - remove lhs_key rhs_key - = SuggestRemoveNonCanonicalDefinition (knownKeyOccName lhs_key) (knownKeyOccName rhs_key) + NonCanonical_Pure -> move pureAClassOpOcc returnMClassOpOcc + NonCanonical_ThenA -> move thenAClassOpOcc thenMClassOpOcc + NonCanonical_Return -> remove returnMClassOpOcc pureAClassOpOcc + NonCanonical_ThenM -> remove thenMClassOpOcc thenAClassOpOcc + + move lhs_occ rhs_occ = SuggestMoveNonCanonicalDefinition lhs_occ rhs_occ + remove lhs_occ rhs_occ = SuggestRemoveNonCanonicalDefinition lhs_occ rhs_occ doc = case reason of NonCanonicalMonoid _ -> doc_monoid ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -707,7 +707,7 @@ tcTypedBracket rn_expr expr res_ty ; meta_ty <- tcCodeTy m_var expr_ty ; ps' <- readMutVar ps_var ; codeco <- tcLookupId unsafeCodeCoerceName - ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName + ; bracket_ty <- mkAppTy m_var <$> tcMetaKnownOccTy expTyConOcc ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty , hsb_wrap = Just wrapper, hsb_splices = ps' } -- The tc_expr is stored here so that the expression can be used in HIE files. ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -29,9 +29,10 @@ module GHC.Tc.Utils.Env( addTypecheckedBinds, addEvBinds, addTopEvBinds, failIllegalTyCon, failIllegalTyVar, - tcLookupKnownKeyGlobal, tcLookupKnownKeyTyCon, tcLookupKnownKeyClass, - tcLookupKnownKeyId, rnLookupKnownKeyName, - rnLookupKnownKeyRdr, getKnownKeySource, + tcLookupKnownKeyGlobal, tcLookupKnownKeyTyCon, + tcLookupKnownKeyClass, tcLookupKnownKeyId, + tcLookupKnownOccTyCon, tcLookupKnownOccId, + rnLookupKnownKeyName, rnLookupKnownKeyRdr, getKnownKeySource, -- Local environment tcExtendKindEnv, tcExtendKindEnvList, @@ -63,7 +64,7 @@ module GHC.Tc.Utils.Env( -- Template Haskell stuff LevelCheckReason(..), - tcMetaTy, tcMetaKnownKeyTy, + tcMetaTy, tcMetaKnownOccTy, thLevelIndex, isBrackLevel, -- New Ids @@ -507,6 +508,19 @@ to bring the data constructor A into scope. We thus emit the following message: ************************************************************************ -} +tcMetaKnownOccTy :: HasDebugCallStack => KnownOcc -> TcM Type +tcMetaKnownOccTy occ + = do { tc <- tcLookupKnownOccTyCon occ + ; return (mkTyConTy tc) } + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name + = do { t <- tcLookupTyCon tc_name + ; return (mkTyConTy t) } + getKnownKeySource :: TcRn KnownKeyNameSource -- Used by both renamer and typechecker and renamer getKnownKeySource @@ -516,46 +530,69 @@ getKnownKeySource ; return (KKNS_InScope rdr_env) } else return KKNS_FromModule } -rnLookupKnownKeyName :: HasDebugCallStack => KnownKey -> RnM Name -rnLookupKnownKeyName uniq +tcrn_wrapper :: (KnownKeyNameSource -> IfG (MaybeErr IfaceMessage a)) -> TcRn a +tcrn_wrapper do_the_lookup = do { kk_source <- getKnownKeySource - ; mb_res <- initIfaceTcRn (lookupKnownKeyName kk_source uniq) + ; mb_res <- initIfaceTcRn (do_the_lookup kk_source) ; case mb_res of - Failed err -> failWithTc (TcRnInterfaceError err) - Succeeded name -> return name } + Failed err -> failWithTc (TcRnInterfaceError err) + Succeeded res -> return res } + + +------------------------------------------------------ +-- Known-key functions rnLookupKnownKeyRdr :: HasDebugCallStack => KnownKey -> RnM RdrName rnLookupKnownKeyRdr uniq = do { nm <- rnLookupKnownKeyName uniq ; return (nameRdrName nm) } +rnLookupKnownKeyName :: HasDebugCallStack => KnownKey -> RnM Name +rnLookupKnownKeyName = tcrn_wrapper . lookupKnownKeyName + tcLookupKnownKeyGlobal :: HasDebugCallStack => KnownKey -> TcM TyThing -tcLookupKnownKeyGlobal uniq - = do { kk_source <- getKnownKeySource - ; traceTc "tcLookupKnownKeyGlobal" (ppr kk_source) - ; mb_thing <- initIfaceTcRn (lookupKnownKeyThing kk_source uniq) - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnInterfaceError msg) } +tcLookupKnownKeyGlobal = tcrn_wrapper . lookupKnownKeyThing tcLookupKnownKeyClass :: HasDebugCallStack => KnownKey -> TcM Class -tcLookupKnownKeyClass uniq - = do { thing <- tcLookupKnownKeyGlobal uniq +tcLookupKnownKeyClass = get_class . tcLookupKnownKeyGlobal + +tcLookupKnownKeyTyCon :: HasDebugCallStack => KnownKey -> TcM TyCon +tcLookupKnownKeyTyCon = get_tycon . tcLookupKnownKeyGlobal + +tcLookupKnownKeyId :: HasDebugCallStack => KnownKey -> TcM Id +tcLookupKnownKeyId = get_id . tcLookupKnownKeyGlobal + +------------------------------------------------------ +-- Known-occ functions + +tcLookupKnownOccGlobal :: HasDebugCallStack => KnownOcc -> TcM TyThing +tcLookupKnownOccGlobal = tcrn_wrapper . lookupKnownOccThing + +tcLookupKnownOccTyCon :: HasDebugCallStack => KnownOcc -> TcM TyCon +tcLookupKnownOccTyCon = get_tycon . tcLookupKnownOccGlobal + +tcLookupKnownOccId :: HasDebugCallStack => KnownOcc -> TcM Id +tcLookupKnownOccId = get_id . tcLookupKnownOccGlobal + +------------------------------------------------------- +get_class :: TcRn TyThing -> TcRn Class +get_class do_the_lookup + = do { thing <- do_the_lookup ; case thing of ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } -tcLookupKnownKeyTyCon :: HasDebugCallStack => KnownKey -> TcM TyCon -tcLookupKnownKeyTyCon uniq - = do { thing <- tcLookupKnownKeyGlobal uniq +get_tycon :: TcRn TyThing -> TcRn TyCon +get_tycon do_the_lookup + = do { thing <- do_the_lookup ; case thing of ATyCon tc -> return tc _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } -tcLookupKnownKeyId :: HasDebugCallStack => KnownKey -> TcM Id -tcLookupKnownKeyId uniq - = do { thing <- tcLookupKnownKeyGlobal uniq +get_id :: TcRn TyThing -> TcRn Id +get_id do_the_lookup + = do { thing <- do_the_lookup ; case thing of AnId id -> return id _ -> wrongThingErr WrongThingClass (AGlobal thing) (getName thing) } @@ -1018,18 +1055,6 @@ tcExtendRules lcl_rules thing_inside ************************************************************************ -} -tcMetaKnownKeyTy :: HasDebugCallStack => Unique -> TcM Type -tcMetaKnownKeyTy uniq - = do { tc <- tcLookupKnownKeyTyCon uniq - ; return (mkTyConTy tc) } - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name - = do { t <- tcLookupTyCon tc_name - ; return (mkTyConTy t) } isBrackLevel :: ThLevel -> Bool isBrackLevel (Brack {}) = True @@ -1091,13 +1116,14 @@ tcGetDefaultTys -- Not one of the built-in units -- @default Num (Integer, Double)@, plus extensions { extDef <- if extended_defaults - then do { list_ty <- tcMetaTy listTyConName - ; integer_ty <- tcMetaTy integerTyConName + then do { list_tc <- tcLookupKnownKeyTyCon listTyConKey + ; integer_tc <- tcLookupKnownKeyTyCon integerTyConKey ; foldableClass <- tcLookupKnownKeyClass foldableClassKey - ; showClass <- tcLookupKnownKeyClass showClassKey - ; eqClass <- tcLookupKnownKeyClass eqClassKey + ; showClass <- tcLookupKnownKeyClass showClassKey + ; eqClass <- tcLookupKnownKeyClass eqClassKey + ; let integer_ty = mkTyConTy integer_tc ; pure $ defaultEnv - [ builtinDefaults foldableClass [list_ty] + [ builtinDefaults foldableClass [mkTyConTy list_tc] , builtinDefaults showClass [unitTy, integer_ty, doubleTy] , builtinDefaults eqClass [unitTy, integer_ty, doubleTy] ] @@ -1111,10 +1137,10 @@ tcGetDefaultTys else pure emptyDefaultEnv ; checkWiredInTyCon doubleTyCon ; numDef <- case lookupDefaultEnv_Directly user_defaults numClassKey of - Nothing -> do { integer_ty <- tcMetaTy integerTyConName + Nothing -> do { integer_tc <- tcLookupKnownKeyTyCon integerTyConKey ; numClass <- tcLookupKnownKeyClass numClassKey ; pure $ unitDefaultEnv $ - builtinDefaults numClass [integer_ty, doubleTy] } + builtinDefaults numClass [mkTyConTy integer_tc, doubleTy] } _ -> -- The Num class is already user-defaulted, so -- no need to construct the builtin default ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -40,8 +40,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env -import GHC.Builtin.Types ( integerTyConName ) -import GHC.Builtin.Names +import GHC.Builtin.Names( integerTyConOcc, rationalTyConOcc ) import GHC.Hs import GHC.Hs.Syn.Type ( hsLitType ) @@ -786,11 +785,11 @@ newNonTrivialOverloadedLit ------------ mkOverLit :: OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i) - = do { integer_ty <- tcMetaTy integerTyConName + = do { integer_ty <- tcMetaKnownOccTy integerTyConOcc ; return (XLit $ HsInteger (il_text i) (il_value i) integer_ty) } mkOverLit (HsFractional r) - = do { rat_ty <- tcMetaKnownKeyTy rationalTyConKey + = do { rat_ty <- tcMetaKnownOccTy rationalTyConOcc ; return (XLit $ HsRat r rat_ty) } mkOverLit (HsIsString src s) = return (HsString src s) ===================================== libraries/base/src/Control/Applicative.hs ===================================== @@ -52,6 +52,8 @@ module Control.Applicative ( thenA, ) where + +import GHC.Internal.Base import GHC.Internal.Control.Category hiding ((.), id) import GHC.Internal.Control.Arrow import GHC.Internal.Data.Maybe @@ -62,12 +64,7 @@ import GHC.Internal.Data.Functor.Const (Const(..)) import GHC.Internal.Data.Typeable (Typeable) import GHC.Internal.Data.Data (Data) -import GHC.Internal.Base ( - Alternative(..), Applicative(..), Functor(..), Monad(..), MonadPlus(..), - ap, const, liftA, liftA3, liftM, liftM2, thenA, (.), (<**>), - ) import GHC.Internal.Functor.ZipList (ZipList(..)) -import GHC.Internal.Types import GHC.Generics import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) ===================================== libraries/base/src/Data/Fixed.hs ===================================== @@ -86,6 +86,8 @@ module Data.Fixed divMod' ) where +import Prelude +import GHC.KnownKeyNames import GHC.Internal.Data.Data import GHC.Internal.TypeLits (KnownNat, natVal) import GHC.Internal.Read @@ -94,7 +96,6 @@ import GHC.Internal.Text.Read.Lex import qualified GHC.Internal.TH.Monad as TH import qualified GHC.Internal.TH.Lift as TH import Data.Typeable -import Prelude -- $setup -- >>> import Prelude ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -20,13 +20,17 @@ module GHC.KnownKeyNames , Foldable, Traversable , Functor, fmap , Monad, (>>), (>>=), return, fail, guard, mfix, join - , Applicative, pure, mzip, (<*>) , Alternative - , Semigroup, Monoid - , (<>), mappend -- Misc - , (.), (&&), not + , (.), (&&), not, map, foldr, build + + -- Applicative + , Applicative, pure, mzip, (<*>), (*>) + + -- Semigroup, Monoid + , Semigroup, Monoid + , (<>), mappend, mempty -- Enum , Enum @@ -72,6 +76,8 @@ module GHC.KnownKeyNames -- Records and lists , HasField , fromLabel, getField + + -- Overloaded lists , IL.fromList, IL.fromListN, IL.toList -- Arrows @@ -80,6 +86,9 @@ module GHC.KnownKeyNames -- IO , thenIO, bindIO, returnIO, print + -- Unsatisfiable + , Unsatisfiable, unsatisfiable + -- Static pointers , IsStatic( fromStaticPtr ), makeStatic @@ -104,9 +113,30 @@ module GHC.KnownKeyNames , integerMod, integerDivMod#, integerQuotRem#, integerEncodeFloat#, integerEncodeDouble# , integerGcd, integerLcm, integerAnd, integerOr, integerXor , integerComplement, integerBit#, integerTestBit#, integerShiftL#, integerShiftR# + + -- Template Haskell + , Q, Name, FieldExp, Dec, Decs, TH.Type, FunDep + , Pred, Code, InjectivityAnn, Overlap, ModName, QuasiQuoter + , sequenceQ, newName, mkName, mkNameG_v, mkNameG_d, mkNameG_tc, mkNameG_fld, mkNameL + , mkNameQ, mkNameS, mkModName, unType, unTypeCode, unsafeCodeCoerce + , liftString, liftTyped + , Lit, charL, stringL, integerL, intPrimL, wordPrimL, floatPrimL + , doublePrimL, rationalL, stringPrimL, charPrimL + , Pat, litP, varP, tupP, unboxedTupP, unboxedSumP, conP, infixP, tildeP + , bangP, asP, wildP, recP, listP, sigP, viewP, orP, typeP, invisP + , Exp, varE, conE, litE, appE, appTypeE, infixE, infixApp, sectionL, sectionR + , lamE, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE + , multiIfE, letE, caseE, doE, mdoE, compE, fromE, fromThenE, fromToE, fromThenToE + , listE, sigE, recConE, recUpdE, staticE, unboundVarE, labelE, implicitParamVarE + , getFieldE, projectionE, typeE, forallE, forallVisE, constrainedE + , FieldPat, fieldPat + , Match, match + , Clause, clause ) where -import Prelude +import GHC.Internal.Show +import GHC.Internal.Num +import GHC.Internal.Real import Data.String( IsString ) import GHC.Internal.Base import GHC.Internal.Ix @@ -114,14 +144,18 @@ import GHC.Internal.Magic( inline ) import GHC.Internal.Enum import GHC.Internal.Data.Data import GHC.Internal.Data.String( fromString ) +import GHC.Internal.Data.Foldable( Foldable ) +import GHC.Internal.Data.Traversable( Traversable ) import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) -import GHC.Internal.Control.Monad( guard ) +import GHC.Internal.Control.Monad( fail, guard ) import GHC.Internal.Control.Monad.Fix( mfix, loop ) import GHC.Internal.Control.Monad.Zip( mzip ) import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records( HasField, getField ) import GHC.Internal.CString as CS +import GHC.Internal.TypeError( Unsatisfiable, unsatisfiable ) +import GHC.Internal.System.IO( print ) import qualified GHC.Internal.IsList as IL import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) @@ -132,6 +166,9 @@ import GHC.Internal.StaticPtr.Internal( makeStatic ) import GHC.Internal.Data.Typeable( Typeable, gcast1, gcast2 ) import GHC.Internal.Generics -import GHC.Internal.Bignum.Integer -import GHC.Internal.Bignum.Natural import GHC.Internal.Bignum.BigNat + +import GHC.Internal.TH.Syntax as TH +import GHC.Internal.TH.Lib hiding( InjectivityAnn, Role ) +import GHC.Internal.TH.Lift +import GHC.Internal.TH.Monad ===================================== libraries/base/src/GHC/RTS/Flags.hs ===================================== @@ -56,6 +56,7 @@ module GHC.RTS.Flags ) where import Prelude (Show,IO,Bool,Maybe,String,Int,Enum,FilePath,Double,Eq,(<$>)) +import GHC.KnownKeyNames import GHC.Generics (Generic) import qualified GHC.Internal.RTS.Flags as Internal ===================================== libraries/base/src/GHC/Stats.hs ===================================== @@ -37,7 +37,7 @@ module GHC.Stats import Prelude (Bool,IO,Read,Show,(<$>)) -import Prelude (Num) -- For -frebindable-known-key-names (defaulting) +import GHC.KnownKeyNames -- For -frebindable-known-key-names (defaulting) import qualified GHC.Internal.Stats as Internal import GHC.Generics (Generic) ===================================== libraries/base/src/System/Console/GetOpt.hs ===================================== @@ -62,7 +62,8 @@ module System.Console.GetOpt ( -- $example2 ) where -import Prelude +import Prelude hiding( foldr ) +import GHC.KnownKeyNames import GHC.Internal.Data.List ( isPrefixOf, find ) -- |What to do with options following non-options ===================================== libraries/base/src/System/Info.hs ===================================== @@ -27,6 +27,7 @@ module System.Info ) where import GHC.Internal.Data.Version (Version (..)) +import GHC.KnownKeyNames import Prelude -- | The version of 'compilerName' with which the program was compiled ===================================== libraries/base/src/Text/Printf.hs ===================================== @@ -93,7 +93,9 @@ module Text.Printf( ) where import Prelude +import GHC.KnownKeyNames( build ) import Data.Char + import GHC.Internal.Int import GHC.Internal.Data.List (stripPrefix) import GHC.Internal.Word @@ -484,7 +486,7 @@ intModifierMap = [ parseIntFormat :: a -> String -> FormatParse parseIntFormat _ s = - case foldr matchPrefix Nothing intModifierMap of + case Prelude.foldr matchPrefix Nothing intModifierMap of Just m -> m Nothing -> case s of ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -438,6 +438,7 @@ W4: The derived Lift instance references various identifiers in GHC.Internal.TH.Lib, so it is an import of GHC.Internal.TH.Lift. +** TODO: Fix me when the reinstallable base stuff has settled ** W5: If no explicit "default" declaration is present, the assumed ===================================== libraries/ghc-internal/src/GHC/Internal/IsList.hs ===================================== @@ -2,9 +2,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} --- We need known-key names fromList, fromListN, toList, but --- alas class Foldable also has a method toList. --- So we export proxies from GHC.KnownKeyNames +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines toList, fromList etc ----------------------------------------------------------------------------- -- | ===================================== libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs ===================================== @@ -14,6 +14,10 @@ -- which otherwise would bias GHC to conclude that any code using -- the static form would fail. {-# OPTIONS_GHC -fomit-interface-pragmas #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines makeStatic + module GHC.Internal.StaticPtr.Internal (makeStatic) where import GHC.Internal.Base (($), (++)) ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Internal.Base hiding( Type ) import GHC.Internal.TH.Syntax import GHC.Internal.TH.Monad import qualified GHC.Internal.TH.Lib as Lib (litE) +import GHC.Internal.TH.Lib( appE ) -- For known-key names -- See wrinkle (W4) of Note [Tracking dependencies on primitives] import GHC.Internal.Base( Monad ) -- Needed for known-key lookup ===================================== libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs ===================================== @@ -1,6 +1,7 @@ -- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell. {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} -- ToDo: this isn't right {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67d4bd98119353857047a3091620cac4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67d4bd98119353857047a3091620cac4... You're receiving this email because of your account on gitlab.haskell.org.