[Git][ghc/ghc][wip/spj-reinstallable-base2] 2 commits: kill all TH known keys, keep the occs
Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: c807aec4 by Rodrigo Mesquita at 2026-05-18T12:07:35+01:00 kill all TH known keys, keep the occs - - - - - 0749548e by Rodrigo Mesquita at 2026-05-18T16:10:47+01:00 fix th things - - - - - 5 changed files: - compiler/GHC/Builtin/TH.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs - libraries/base/src/GHC/Essentials.hs Changes: ===================================== compiler/GHC/Builtin/TH.hs ===================================== @@ -8,10 +8,8 @@ module GHC.Builtin.TH where import GHC.Prelude () -import GHC.Types.Name( Name, KnownOcc ) +import GHC.Types.Name( KnownOcc ) import GHC.Types.Name.Occurrence -import GHC.Types.Unique ( Unique ) -import GHC.Builtin.Uniques import GHC.Data.FastString -------------------- TH.Syntax ----------------------- @@ -230,8 +228,7 @@ implicitParamBindDOcc = mkVarOcc "implicitParamBindD" -- type Ctxt = ... cxtName :: KnownOcc -cxtName = mkVarOcc "cxt" -- TODO: WHERE IS THIS; AND DO I NEED TO EXPORT IT FROM GHC.Essentials?? - -- Look at the knownOccs below up until BangTypeName too. +cxtName = mkVarOcc "cxt" -- data SourceUnpackedness = ... noSourceUnpackednessOcc, sourceNoUnpackOcc, sourceUnpackOcc :: KnownOcc @@ -260,23 +257,23 @@ bangName = mkVarOcc "bang" -- type BangType = ... bangTypeName :: KnownOcc -bangTypeName = libFun (fsLit "bangType") bangTKey +bangTypeName = mkVarOcc "bangType" -- type VarBangType = ... varBangTypeName :: KnownOcc -varBangTypeName = libFun (fsLit "varBangType") varBangTKey +varBangTypeName = mkVarOcc "varBangType" -- data PatSynDir = ... unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: KnownOcc -unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey -implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey -explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey +unidirPatSynName = mkVarOcc "unidir" +implBidirPatSynName = mkVarOcc "implBidir" +explBidirPatSynName = mkVarOcc "explBidir" -- data PatSynArgs = ... prefixPatSynName, infixPatSynName, recordPatSynName :: KnownOcc -prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey -infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey -recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey +prefixPatSynName = mkVarOcc "prefixPatSyn" +infixPatSynName = mkVarOcc "infixPatSyn" +recordPatSynName = mkVarOcc "recordPatSyn" -- data Type = ... forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, @@ -284,124 +281,124 @@ forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName :: KnownOcc -forallTName = libFun (fsLit "forallT") forallTIdKey -forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -appKindTName = libFun (fsLit "appKindT") appKindTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey -equalityTName = libFun (fsLit "equalityT") equalityTIdKey -litTName = libFun (fsLit "litT") litTIdKey -promotedTName = libFun (fsLit "promotedT") promotedTIdKey -promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey -promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey -promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey -wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey -infixTName = libFun (fsLit "infixT") infixTIdKey -implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey +forallTName = mkVarOcc "forallT" +forallVisTName = mkVarOcc "forallVisT" +varTName = mkVarOcc "varT" +conTName = mkVarOcc "conT" +tupleTName = mkVarOcc "tupleT" +unboxedTupleTName = mkVarOcc "unboxedTupleT" +unboxedSumTName = mkVarOcc "unboxedSumT" +arrowTName = mkVarOcc "arrowT" +mulArrowTName = mkVarOcc "mulArrowT" +listTName = mkVarOcc "listT" +appTName = mkVarOcc "appT" +appKindTName = mkVarOcc "appKindT" +sigTName = mkVarOcc "sigT" +equalityTName = mkVarOcc "equalityT" +litTName = mkVarOcc "litT" +promotedTName = mkVarOcc "promotedT" +promotedTupleTName = mkVarOcc "promotedTupleT" +promotedNilTName = mkVarOcc "promotedNilT" +promotedConsTName = mkVarOcc "promotedConsT" +wildCardTName = mkVarOcc "wildCardT" +infixTName = mkVarOcc "infixT" +implicitParamTName = mkVarOcc "implicitParamT" -- data TyLit = ... numTyLitName, strTyLitName, charTyLitName :: KnownOcc -numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey -strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey -charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey +numTyLitName = mkVarOcc "numTyLit" +strTyLitName = mkVarOcc "strTyLit" +charTyLitName = mkVarOcc "charTyLit" -- data TyVarBndr = ... plainTVName, kindedTVName :: KnownOcc -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainTVName = mkVarOcc "plainTV" +kindedTVName = mkVarOcc "kindedTV" plainInvisTVName, kindedInvisTVName :: KnownOcc -plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey -kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey +plainInvisTVName = mkVarOcc "plainInvisTV" +kindedInvisTVName = mkVarOcc "kindedInvisTV" plainBndrTVName, kindedBndrTVName :: KnownOcc -plainBndrTVName = libFun (fsLit "plainBndrTV") plainBndrTVIdKey -kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey +plainBndrTVName = mkVarOcc "plainBndrTV" +kindedBndrTVName = mkVarOcc "kindedBndrTV" -- data Specificity = ... specifiedSpecName, inferredSpecName :: KnownOcc -specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey -inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey +specifiedSpecName = mkVarOcc "specifiedSpec" +inferredSpecName = mkVarOcc "inferredSpec" -- data BndrVis = ... bndrReqName, bndrInvisName :: KnownOcc -bndrReqName = libFun (fsLit "bndrReq") bndrReqKey -bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey +bndrReqName = mkVarOcc "bndrReq" +bndrInvisName = mkVarOcc "bndrInvis" -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: KnownOcc -nominalRName = libFun (fsLit "nominalR") nominalRIdKey -representationalRName = libFun (fsLit "representationalR") representationalRIdKey -phantomRName = libFun (fsLit "phantomR") phantomRIdKey -inferRName = libFun (fsLit "inferR") inferRIdKey +nominalRName = mkVarOcc "nominalR" +representationalRName = mkVarOcc "representationalR" +phantomRName = mkVarOcc "phantomR" +inferRName = mkVarOcc "inferR" -- data Kind = ... starKName, constraintKName :: KnownOcc -starKName = libFun (fsLit "starK") starKIdKey -constraintKName = libFun (fsLit "constraintK") constraintKIdKey +starKName = mkVarOcc "starK" +constraintKName = mkVarOcc "constraintK" -- data FamilyResultSig = ... noSigName, kindSigName, tyVarSigName :: KnownOcc -noSigName = libFun (fsLit "noSig") noSigIdKey -kindSigName = libFun (fsLit "kindSig") kindSigIdKey -tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey +noSigName = mkVarOcc "noSig" +kindSigName = mkVarOcc "kindSig" +tyVarSigName = mkVarOcc "tyVarSig" -- data InjectivityAnn = ... injectivityAnnName :: KnownOcc -injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey +injectivityAnnName = mkVarOcc "injectivityAnn" -- data Callconv = ... cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: KnownOcc -cCallName = libFun (fsLit "cCall") cCallIdKey -stdCallName = libFun (fsLit "stdCall") stdCallIdKey -cApiCallName = libFun (fsLit "cApi") cApiCallIdKey -primCallName = libFun (fsLit "prim") primCallIdKey -javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey +cCallName = mkVarOcc "cCall" +stdCallName = mkVarOcc "stdCall" +cApiCallName = mkVarOcc "cApi" +primCallName = mkVarOcc "prim" +javaScriptCallName = mkVarOcc "javaScript" -- data Safety = ... unsafeName, safeName, interruptibleName :: KnownOcc -unsafeName = libFun (fsLit "unsafe") unsafeIdKey -safeName = libFun (fsLit "safe") safeIdKey -interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey +unsafeName = mkVarOcc "unsafe" +safeName = mkVarOcc "safe" +interruptibleName = mkVarOcc "interruptible" -- data RuleBndr = ... ruleVarName, typedRuleVarName :: KnownOcc -ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey -typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey +ruleVarName = mkVarOcc "ruleVar" +typedRuleVarName = mkVarOcc "typedRuleVar" -- data FunDep = ... funDepName :: KnownOcc -funDepName = libFun (fsLit "funDep") funDepIdKey +funDepName = mkVarOcc "funDep" -- data TySynEqn = ... tySynEqnName :: KnownOcc -tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey +tySynEqnName = mkVarOcc "tySynEqn" -- data AnnTarget = ... valueAnnotationName, typeAnnotationName, moduleAnnotationName :: KnownOcc -valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey -typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey -moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey +valueAnnotationName = mkVarOcc "valueAnnotation" +typeAnnotationName = mkVarOcc "typeAnnotation" +moduleAnnotationName = mkVarOcc "moduleAnnotation" -- type DerivClause = ... derivClauseName :: KnownOcc -derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey +derivClauseName = mkVarOcc "derivClause" -- data DerivStrategy = ... stockStrategyName, anyclassStrategyName, newtypeStrategyName, viaStrategyName :: KnownOcc -stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey -anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey -newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey -viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey +stockStrategyName = mkVarOcc "stockStrategy" +anyclassStrategyName = mkVarOcc "anyclassStrategy" +newtypeStrategyName = mkVarOcc "newtypeStrategy" +viaStrategyName = mkVarOcc "viaStrategy" patQTyConOcc, expQTyConOcc, stmtTyConOcc, conTyConOcc, bangTypeTyConOcc, @@ -433,276 +430,42 @@ derivStrategyTyConOcc = mkTcOcc "DerivStrategy" -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: KnownOcc -quoteExpName = qqFld (fsLit "quoteExp") quoteExpKey -quotePatName = qqFld (fsLit "quotePat") quotePatKey -quoteDecName = qqFld (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey +quoteExpName = mkRecFieldOcc (fsLit "QuasiQuoter") "quoteExp" +quotePatName = mkRecFieldOcc (fsLit "QuasiQuoter") "quotePat" +quoteDecName = mkRecFieldOcc (fsLit "QuasiQuoter") "quoteDec" +quoteTypeName = mkRecFieldOcc (fsLit "QuasiQuoter") "quoteType" -- data Inline = ... noInlineDataConName, inlineDataConName, inlinableDataConName :: KnownOcc -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey +noInlineDataConName = mkDataOcc "NoInline" +inlineDataConName = mkDataOcc "Inline" +inlinableDataConName = mkDataOcc "Inlinable" -- data RuleMatch = ... conLikeDataConName, funLikeDataConName :: KnownOcc -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey +conLikeDataConName = mkDataOcc "ConLike" +funLikeDataConName = mkDataOcc "FunLike" -- data Phases = ... allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: KnownOcc -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey +allPhasesDataConName = mkDataOcc "AllPhases" +fromPhaseDataConName = mkDataOcc "FromPhase" +beforePhaseDataConName = mkDataOcc "BeforePhase" -- data Overlap = ... overlappableDataConName, overlappingDataConName, overlapsDataConName, incoherentDataConName :: KnownOcc -overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey -overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey -overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey -incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey +overlappableDataConName = mkDataOcc "Overlappable" +overlappingDataConName = mkDataOcc "Overlapping" +overlapsDataConName = mkDataOcc "Overlaps" +incoherentDataConName = mkDataOcc "Incoherent" -- data NamespaceSpecifier = ... noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName, dataNamespaceSpecifierDataConName :: KnownOcc -noNamespaceSpecifierDataConName = - thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey -typeNamespaceSpecifierDataConName = - thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey -dataNamespaceSpecifierDataConName = - thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey - -{- ********************************************************************* -* * - Class keys -* * -********************************************************************* -} - --- ClassUniques available: 200-299 --- Check in GHC.Builtin.KnownKeys if you want to change this - -liftClassKey :: Unique -liftClassKey = mkPreludeClassUnique 200 - -{- ********************************************************************* -* * - TyCon keys -* * -********************************************************************* -} - --- TyConUniques available: 200-299 --- Check in GHC.Builtin.KnownKeys if you want to change this - - -{- ********************************************************************* -* * - DataCon keys -* * -********************************************************************* -} - --- DataConUniques available: 100-150 --- If you want to change this, make sure you check in GHC.Builtin.KnownKeys - --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 200 -inlineDataConKey = mkPreludeDataConUnique 201 -inlinableDataConKey = mkPreludeDataConUnique 202 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 204 -funLikeDataConKey = mkPreludeDataConUnique 205 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 206 -fromPhaseDataConKey = mkPreludeDataConUnique 207 -beforePhaseDataConKey = mkPreludeDataConUnique 208 - --- data Overlap = .. -overlappableDataConKey, - overlappingDataConKey, - overlapsDataConKey, - incoherentDataConKey :: Unique -overlappableDataConKey = mkPreludeDataConUnique 209 -overlappingDataConKey = mkPreludeDataConUnique 210 -overlapsDataConKey = mkPreludeDataConUnique 211 -incoherentDataConKey = mkPreludeDataConUnique 212 - --- data NamespaceSpecifier = ... -noNamespaceSpecifierDataConKey, - typeNamespaceSpecifierDataConKey, - dataNamespaceSpecifierDataConKey :: Unique -noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213 -typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214 -dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215 -{- ********************************************************************* -* * - Id keys -* * -********************************************************************* -} - --- IdUniques available: 200-499 --- If you want to change this, make sure you check in GHC.Builtin.KnownKeys - --- type BangType = ... -bangTKey :: Unique -bangTKey = mkPreludeMiscIdUnique 375 - --- type VarBangType = ... -varBangTKey :: Unique -varBangTKey = mkPreludeMiscIdUnique 376 - --- data PatSynDir = ... -unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique -unidirPatSynIdKey = mkPreludeMiscIdUnique 377 -implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 -explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 - --- data PatSynArgs = ... -prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique -prefixPatSynIdKey = mkPreludeMiscIdUnique 380 -infixPatSynIdKey = mkPreludeMiscIdUnique 381 -recordPatSynIdKey = mkPreludeMiscIdUnique 382 - --- data Type = ... -forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, - unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, - appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, - promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, - wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 390 -forallVisTIdKey = mkPreludeMiscIdUnique 391 -varTIdKey = mkPreludeMiscIdUnique 392 -conTIdKey = mkPreludeMiscIdUnique 393 -tupleTIdKey = mkPreludeMiscIdUnique 394 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 -unboxedSumTIdKey = mkPreludeMiscIdUnique 396 -arrowTIdKey = mkPreludeMiscIdUnique 397 -listTIdKey = mkPreludeMiscIdUnique 398 -appTIdKey = mkPreludeMiscIdUnique 399 -appKindTIdKey = mkPreludeMiscIdUnique 400 -sigTIdKey = mkPreludeMiscIdUnique 401 -equalityTIdKey = mkPreludeMiscIdUnique 402 -litTIdKey = mkPreludeMiscIdUnique 403 -promotedTIdKey = mkPreludeMiscIdUnique 404 -promotedTupleTIdKey = mkPreludeMiscIdUnique 405 -promotedNilTIdKey = mkPreludeMiscIdUnique 406 -promotedConsTIdKey = mkPreludeMiscIdUnique 407 -wildCardTIdKey = mkPreludeMiscIdUnique 408 -implicitParamTIdKey = mkPreludeMiscIdUnique 409 -infixTIdKey = mkPreludeMiscIdUnique 410 - --- data TyLit = ... -numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 411 -strTyLitIdKey = mkPreludeMiscIdUnique 412 -charTyLitIdKey = mkPreludeMiscIdUnique 413 - --- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 414 -kindedTVIdKey = mkPreludeMiscIdUnique 415 - -plainInvisTVIdKey, kindedInvisTVIdKey :: Unique -plainInvisTVIdKey = mkPreludeMiscIdUnique 482 -kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 - -plainBndrTVIdKey, kindedBndrTVIdKey :: Unique -plainBndrTVIdKey = mkPreludeMiscIdUnique 484 -kindedBndrTVIdKey = mkPreludeMiscIdUnique 485 - --- data Role = ... -nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 416 -representationalRIdKey = mkPreludeMiscIdUnique 417 -phantomRIdKey = mkPreludeMiscIdUnique 418 -inferRIdKey = mkPreludeMiscIdUnique 419 - --- data Kind = ... -starKIdKey, constraintKIdKey :: Unique -starKIdKey = mkPreludeMiscIdUnique 425 -constraintKIdKey = mkPreludeMiscIdUnique 426 - --- data FamilyResultSig = ... -noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique -noSigIdKey = mkPreludeMiscIdUnique 427 -kindSigIdKey = mkPreludeMiscIdUnique 428 -tyVarSigIdKey = mkPreludeMiscIdUnique 429 - --- data InjectivityAnn = ... -injectivityAnnIdKey :: Unique -injectivityAnnIdKey = mkPreludeMiscIdUnique 430 - --- data Callconv = ... -cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, - javaScriptCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 431 -stdCallIdKey = mkPreludeMiscIdUnique 432 -cApiCallIdKey = mkPreludeMiscIdUnique 433 -primCallIdKey = mkPreludeMiscIdUnique 434 -javaScriptCallIdKey = mkPreludeMiscIdUnique 435 - --- data Safety = ... -unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 440 -safeIdKey = mkPreludeMiscIdUnique 441 -interruptibleIdKey = mkPreludeMiscIdUnique 442 - --- data FunDep = ... -funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 445 - --- mulArrow -mulArrowTIdKey :: Unique -mulArrowTIdKey = mkPreludeMiscIdUnique 446 - --- data TySynEqn = ... -tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 460 - --- quasiquoting -quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 470 -quotePatKey = mkPreludeMiscIdUnique 471 -quoteDecKey = mkPreludeMiscIdUnique 472 -quoteTypeKey = mkPreludeMiscIdUnique 473 - --- data RuleBndr = ... -ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 480 -typedRuleVarIdKey = mkPreludeMiscIdUnique 481 - --- data AnnTarget = ... -valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique -valueAnnotationIdKey = mkPreludeMiscIdUnique 490 -typeAnnotationIdKey = mkPreludeMiscIdUnique 491 -moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 - --- type DerivPred = ... -derivClauseIdKey :: Unique -derivClauseIdKey = mkPreludeMiscIdUnique 493 - --- data DerivStrategy = ... -stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, - viaStrategyIdKey :: Unique -stockStrategyIdKey = mkPreludeDataConUnique 494 -anyclassStrategyIdKey = mkPreludeDataConUnique 495 -newtypeStrategyIdKey = mkPreludeDataConUnique 496 -viaStrategyIdKey = mkPreludeDataConUnique 497 - --- data Specificity = ... -specifiedSpecKey, inferredSpecKey :: Unique -specifiedSpecKey = mkPreludeMiscIdUnique 498 -inferredSpecKey = mkPreludeMiscIdUnique 499 - --- data BndrVis = ... -bndrReqKey, bndrInvisKey :: Unique -bndrReqKey = mkPreludeMiscIdUnique 800 -- TODO (int-index): make up some room in the 5** numberspace? -bndrInvisKey = mkPreludeMiscIdUnique 801 - +noNamespaceSpecifierDataConName = mkDataOcc "NoNamespaceSpecifier" +typeNamespaceSpecifierDataConName = mkDataOcc "TypeNamespaceSpecifier" +dataNamespaceSpecifierDataConName = mkDataOcc "DataNamespaceSpecifier" ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -887,7 +887,7 @@ repC (L _ (ConDeclH98 { con_name = con ; ctxt' <- repMbContext mcxt ; if not is_existential && isNothing mcxt then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) + else rep2 forallCOcc ([unC ex_bndrs, unC ctxt', unC c']) } repC (L l (ConDeclGADT { con_names = cons @@ -908,12 +908,12 @@ repC (L l (ConDeclGADT { con_names = cons let loop last_bndrs' [] = do ctxt' <- repMbContext mcxt c' <- repGadtDataCons cons args res_ty - rep2 forallCName ([unC last_bndrs', unC ctxt', unC c']) + rep2 forallCOcc ([unC last_bndrs', unC ctxt', unC c']) loop last_bndrs' (bndrs : bndrs_s) = addHsTyVarBinds FreshNamesOnly bndrs $ \bndrs' -> do body_c' <- loop bndrs' bndrs_s ctxt' <- repContext [] - rep2 forallCName [unC last_bndrs', unC ctxt', unC body_c'] + rep2 forallCOcc [unC last_bndrs', unC ctxt', unC body_c'] in loop outer_bndrs' invis_inner_bndrs | Nothing <- m_invis_inner_bndrs @@ -935,14 +935,14 @@ repMbContext Nothing = repContext [] repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) -repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] -repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] -repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] +repSrcUnpackedness SrcUnpack = rep2 sourceUnpackOcc [] +repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackOcc [] +repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessOcc [] repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness)) -repSrcStrictness SrcLazy = rep2 sourceLazyName [] -repSrcStrictness SrcStrict = rep2 sourceStrictName [] -repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] +repSrcStrictness SrcLazy = rep2 sourceLazyOcc [] +repSrcStrictness SrcStrict = rep2 sourceStrictOcc [] +repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessOcc [] repConDeclField :: HsConDeclField GhcRn -> MetaM (Core (M TH.BangType)) repConDeclField (CDF { cdf_unpack, cdf_bang, cdf_type }) = do @@ -2344,7 +2344,7 @@ globalVarLocal unique name = do { MkC occ <- occNameLit name ; platform <- targetPlatform <$> getDynFlags ; let uni = mkIntegerExpr platform (toInteger $ getKey unique) - ; rep2_nwDsM mkNameLName [occ,uni] } + ; rep2_nwDsM mkNameLOcc [occ,uni] } globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) globalVarExternal mod name_occ @@ -2352,14 +2352,14 @@ globalVarExternal mod name_occ ; MkC pkg <- coreStringLit name_pkg ; MkC occ <- occNameLit name_occ ; if | isDataOcc name_occ - -> rep2_nwDsM mkNameG_dName [pkg,mod,occ] + -> rep2_nwDsM mkNameG_dOcc [pkg,mod,occ] | isVarOcc name_occ - -> rep2_nwDsM mkNameG_vName [pkg,mod,occ] + -> rep2_nwDsM mkNameG_vOcc [pkg,mod,occ] | isTcOcc name_occ - -> rep2_nwDsM mkNameG_tcName [pkg,mod,occ] + -> rep2_nwDsM mkNameG_tcOcc [pkg,mod,occ] | Just con_fs <- fieldOcc_maybe name_occ -> do { MkC con <- coreStringLit con_fs - ; rep2_nwDsM mkNameG_fldName [pkg,mod,con,occ] } + ; rep2_nwDsM mkNameG_fldOcc [pkg,mod,con,occ] } | otherwise -> pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) } @@ -2465,11 +2465,11 @@ krep2X lift_dsm get_wrap n xs = do -dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) -dataCon' n args = do { id <- lift $ dsLookupDataCon n +dataCon' :: KnownOcc -> [CoreExpr] -> MetaM (Core a) +dataCon' n args = do { id <- lift $ dsLookupKnownOccDataCon n ; return $ MkC $ mkCoreConApps id args } -dataCon :: Name -> MetaM (Core a) +dataCon :: KnownOcc -> MetaM (Core a) dataCon n = dataCon' n [] @@ -2615,7 +2615,7 @@ repDoBlock doName maybeModName (MkC ss) = do coreModNameM = case maybeModName of Just m -> do MkC s <- lift $ coreStringLit (moduleNameFS m) - mName <- rep2_nw mkModNameName [s] + mName <- rep2_nw mkModNameOcc [s] coreJust modNameTyConOcc mName _ -> coreNothing modNameTyConOcc @@ -2918,15 +2918,15 @@ repH98DataCon con details case details of PrefixCon ps -> do arg_tys <- repPrefixConArgs IsNotPrefixConGADT ps - rep2 normalCName [unC con', unC arg_tys] + rep2 normalCOcc [unC con', unC arg_tys] InfixCon st1 st2 -> do verifyLinearFields IsNotPrefixConGADT [st1, st2] arg1 <- repConDeclField st1 arg2 <- repConDeclField st2 - rep2 infixCName [unC arg1, unC con', unC arg2] + rep2 infixCOcc [unC arg1, unC con', unC arg2] RecCon ips -> do arg_vtys <- repRecConArgs ips - rep2 recCName [unC con', unC arg_vtys] + rep2 recCOcc [unC con', unC arg_vtys] repGadtDataCons :: NonEmpty (LocatedN Name) -> HsConDeclGADTDetails GhcRn @@ -2938,11 +2938,11 @@ repGadtDataCons cons details res_ty PrefixConGADT _ ps -> do arg_tys <- repPrefixConArgs IsPrefixConGADT ps res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] + rep2 gadtCOcc [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] RecConGADT _ ips -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, + rep2 recGadtCOcc [unC (nonEmptyCoreList' cons'), unC arg_vtys, unC res_ty'] -- TH currently only supports linear constructors. @@ -3197,15 +3197,15 @@ repRdrName rdr_name = do -- used for holes anyway so it probably never happens repNameS :: Core String -> MetaM (Core TH.Name) -repNameS (MkC name) = rep2_nw mkNameSName [name] +repNameS (MkC name) = rep2_nw mkNameSOcc [name] repNameQ :: Core String -> Core String -> MetaM (Core TH.Name) -repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQName [mn, name] +repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQOcc [mn, name] --------------- Miscellaneous ------------------- repGensym :: Core String -> MetaM (Core (M TH.Name)) -repGensym (MkC lit_str) = rep2 newNameName [lit_str] +repGensym (MkC lit_str) = rep2 newNameOcc [lit_str] repBindM :: Type -> Type -- a and b -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b)) ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -337,10 +337,10 @@ runRnSplice flavour run_meta ppr_res splice Just h -> h splice -- TODO: Should call tcUntypedSplice here - ; let the_expr = case splice' of - HsUntypedSpliceExpr _ e -> e - HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str - XUntypedSplice {} -> pprPanic "runRnSplice: XUntypedSplice" (pprUntypedSplice False Nothing splice') + ; the_expr <- case splice' of + HsUntypedSpliceExpr _ e -> pure e + HsQuasiQuote _ q str -> fst <$> rnLExpr (mkQuasiQuoteExpr flavour q str) + XUntypedSplice {} -> pprPanic "runRnSplice: XUntypedSplice" (pprUntypedSplice False Nothing splice') -- Typecheck the expression ; meta_exp_ty <- tcMetaKnownOccTy meta_ty_name @@ -392,18 +392,18 @@ recordPendingSplice _ _ (TcPending _ _ _) = panic "impossible" ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> LIdP GhcRn -> XRec GhcPs FastString - -> LHsExpr GhcRn + -> LHsExpr GhcPs -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter (L q_span' quote) = L q_span $ HsApp noExtField (L q_span $ HsApp noExtField (L q_span - (mkHsVar (L (l2l q_span) quote_selector))) + (mkHsVar (L (l2l q_span) (Exact (ExactOcc quote_selector))))) quoterExpr) quoteExpr where q_span = noAnnSrcSpan (locA q_span') - quoterExpr = L (l2l quoter) $! mkHsVar $! quoter + quoterExpr = L (l2l quoter) $! mkHsVar $! Exact . ExactName <$> quoter quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -834,7 +834,7 @@ tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsQuasiQuote (HsQuasiQuoteEx res_co <- unifyInvisibleType InvisibleKind splice_ty quote_ty -- 3. Lookup the relevant field selector from QuasiQuoter - sel <- tcLookupId qq_sel_name + sel <- tcLookupKnownOccId qq_sel_name -- 4. Apply the selector to the quasi-quoter let expr' = mkLHsWrapCo res_co $ @@ -877,7 +877,7 @@ tcPendingSpliceTyped q@(QuoteWrapper _ m_var) splice_name (HsTypedSpliceExpr _ e ; let rep = getRuntimeRep res_ty ; meta_exp_ty <- tcCodeTy m_var res_ty ; expr' <- tcCheckMonoExpr expr meta_exp_ty - ; untype_code <- tcLookupId unTypeCodeName + ; untype_code <- tcLookupKnownOccId unTypeCodeOcc ; let expr'' = mkHsApp (mkLHsWrap (applyQuoteWrapper q) (nlHsTyApp untype_code [rep, res_ty])) expr' ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -195,7 +195,7 @@ module GHC.Essentials , Lift, Quote -- The Lift and Quote classeso , Q, DecsQ, ExpQ, TypeQ, PatQ , Name, Decs, TH.Type, FunDep - , Pred, Code, InjectivityAnn, Overlap, ModName, QuasiQuoter + , Pred, Code, InjectivityAnn, ModName , Con, BangType, VarBangType, RuleBndr, TySynEqn, Role, DerivClause , Kind, TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis, DerivStrategy , sequenceQ, newName, mkName, mkNameG_v, mkNameG_d, mkNameG_tc, mkNameG_fld, mkNameL @@ -221,6 +221,9 @@ module GHC.Essentials , letE, caseE, doE, mdoE, compE, fromE, fromThenE, fromToE, fromThenToE , listE, sigE, recConE, recUpdE, staticE, unboundVarE, labelE, implicitParamVarE , getFieldE, projectionE, typeE, forallE, forallVisE, constrainedE + , TH.cxt + , TH.noSourceUnpackedness, TH.sourceNoUnpack, TH.sourceUnpack + , TH.noSourceStrictness, TH.sourceLazy, TH.sourceStrict , FieldExp, fieldExp , FieldPat, fieldPat , Match, match @@ -228,6 +231,35 @@ module GHC.Essentials , Stmt, bindS, letS, noBindS, parS, recS , Body, normalB, guardedB , Guard, normalGE, patGE + , normalC, recC, infixC, forallC, gadtC, recGadtC + , TH.bang, TH.bangType, TH.varBangType + , TH.unidir, TH.implBidir, TH.explBidir + , TH.prefixPatSyn, TH.recordPatSyn, TH.infixPatSyn + , forallT, forallVisT, varT, conT, infixT, tupleT, + , unboxedTupleT, unboxedSumT, arrowT, mulArrowT, listT, + , appT, appKindT, sigT, equalityT, litT, promotedT, + , promotedTupleT, promotedNilT, promotedConsT, + , wildCardT, implicitParamT + , numTyLit, strTyLit, charTyLit + , plainTV, kindedTV + , plainInvisTV, kindedInvisTV + , specifiedSpec, inferredSpec + , bndrReq, bndrInvis + , nominalR, representationalR, phantomR, inferR + , starK, constraintK + , noSig, kindSig, tyVarSig + , injectivityAnn + , TH.cCall, TH.stdCall, TH.cApiCall, TH.primCall, TH.javaScriptCall + , TH.unsafe, TH.safe, TH.interruptible + , TH.ruleVar, TH.typedRuleVar + , TH.funDep, TH.tySynEqn + , TH.valueAnnotation, TH.typeAnnotation, TH.moduleAnnotation + , TH.derivClause + , TH.stockStrategy, TH.anyclassStrategy, TH.newtypeStrategy, TH.viaStrategy + , TH.QuasiQuoter(..) + , TH.Inline(..), TH.RuleMatch(..) + , TH.Phases(..) , TH.Overlap(..) + , TH.NamespaceSpecifier(..) -- GHCi , GHCiSandboxIO(ghciStepIO) @@ -298,7 +330,7 @@ import GHC.Internal.TH.Syntax as TH hiding( Fixity(..), SourceUnpackedness(..), SourceStrictness(..) , DecidedStrictness(..) ) -- hiding(Fixity) see Note [Tricky known-occ cases] in GHC.Builtin.KnownOccs -import GHC.Internal.TH.Lib +import GHC.Internal.TH.Lib as TH import GHC.Internal.TH.Lift import GHC.Internal.TH.Monad import GHC.Internal.TopHandler View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cec620e84ff1f6bb18ed942c2f13e88... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cec620e84ff1f6bb18ed942c2f13e88... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Rodrigo Mesquita (＠alt-romes)