From 7c53b6be5ec2ee0285818eeccad374f2689c2d65 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Fri, 20 Jan 2023 12:05:29 +0300 Subject: WIP: Punned names --- compiler/GHC/Builtin/Types.hs | 5 ++-- compiler/GHC/HsToCore/Quote.hs | 1 + compiler/GHC/Parser.y | 6 ++--- compiler/GHC/Parser/PostProcess.hs | 4 ++++ compiler/GHC/Types/Name/Reader.hs | 49 +++++++++++++++++++++++++++++++++----- utils/check-exact/Utils.hs | 1 + 6 files changed, 54 insertions(+), 12 deletions(-) diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 44d22f3676..8da852e292 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -57,7 +57,7 @@ module GHC.Builtin.Types ( word8TyCon, word8DataCon, word8Ty, -- * List - listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + listTyCon, listTyConName, listTyConKey, nilDataCon, nilDataConName, nilDataConKey, consDataCon_RDR, consDataCon, consDataConName, promotedNilDataCon, promotedConsDataCon, @@ -513,7 +513,7 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName + intDataCon_RDR, consDataCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName @@ -521,7 +521,6 @@ intTyCon_RDR = nameRdrName intTyConName charTyCon_RDR = nameRdrName charTyConName stringTyCon_RDR = nameRdrName stringTyConName intDataCon_RDR = nameRdrName intDataConName -listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName {- diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index f6cf36101b..66ffdb7f21 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2963,6 +2963,7 @@ repRdrName rdr_name = do repNameQ mod occ Orig m n -> lift $ globalVarExternal m n Exact n -> lift $ globalVar n + ExactPun n _ -> lift $ globalVar n repNameS :: Core String -> MetaM (Core TH.Name) repNameS (MkC name) = rep2_nw mkNameSName [name] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 16b6519788..f0791eef24 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -67,7 +67,7 @@ import GHC.Prelude import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS, mkTcOcc ) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error ( GhcHint(..) ) @@ -92,7 +92,7 @@ import GHC.Parser.Errors.Ppr () import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, consDataCon_RDR, + listTyConName, consDataCon_RDR, unrestrictedFunTyCon ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -3616,7 +3616,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } - | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR) + | '[' ']' {% amsrn (sLL $1 $> $ punRdrName listTyConName) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } oqtycon :: { LocatedN RdrName } -- An "ordinary" qualified tycon; diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 9c0a5df0aa..b033d7a6cd 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -822,6 +822,10 @@ setRdrNameSpace (Exact n) ns = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) where occ = setOccNameSpace ns (nameOccName n) +setRdrNameSpace name@(ExactPun n pun) ns + | isTcClsNameSpace ns = name -- No-op (ExactPun is guaranteed to be a TcClsName) + | isDataConNameSpace ns = setRdrNameSpace (Exact n) ns -- Data constructors are not puns, so treat this as an ordinary Exact name. + | otherwise = pprPanic "setRdrNameSpace" (pprNameSpace ns <+> ppr (n, pun)) setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace (ATyCon tc) ns diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index 7c52a94584..d363e0d766 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -30,7 +30,7 @@ module GHC.Types.Name.Reader ( -- ** Construction mkRdrUnqual, mkRdrQual, mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, + nameRdrName, getRdrName, punRdrName, -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTv, promoteRdrName, @@ -91,6 +91,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Misc as Utils import GHC.Utils.Panic +import GHC.Utils.Panic.Plain (assert) import GHC.Types.Name.Env import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -165,6 +166,17 @@ data RdrName -- (2) By Template Haskell, when TH has generated a unique name -- -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + + | ExactPun Name FastString + -- ^ A variant of 'Exact' used for punned type constructors + -- under @ListTuplePuns@. + -- + -- Created by the parser from the @[]@ and @(,)@ syntax in types. + -- The corresponding data constructors are represented with 'Exact'. + -- + -- Invariant 1: the 'FastString' is a cached result of 'namePun_maybe'. + -- Invariant 2: the 'NameSpace' is 'TcClsName'. + deriving Data {- @@ -183,6 +195,7 @@ rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ rdrNameOcc (Orig _ occ) = occ rdrNameOcc (Exact name) = nameOccName name +rdrNameOcc (ExactPun _ pun) = mkTcOccFS pun rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -194,12 +207,14 @@ demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) demoteRdrName (Orig _ _) = Nothing demoteRdrName (Exact _) = Nothing +demoteRdrName (ExactPun _ _) = Nothing demoteRdrNameTv :: RdrName -> Maybe RdrName demoteRdrNameTv (Unqual occ) = fmap Unqual (demoteOccTvName occ) demoteRdrNameTv (Qual m occ) = fmap (Qual m) (demoteOccTvName occ) demoteRdrNameTv (Orig _ _) = Nothing demoteRdrNameTv (Exact _) = Nothing +demoteRdrNameTv (ExactPun _ _) = Nothing -- promoteRdrName promotes the NameSpace of RdrName. -- See Note [Promotion] in GHC.Rename.Env. @@ -208,6 +223,7 @@ promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ) promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ) promoteRdrName (Orig _ _) = Nothing promoteRdrName (Exact _) = Nothing +promoteRdrName (ExactPun _ _) = Nothing -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName @@ -242,6 +258,14 @@ nameRdrName name = Exact name -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) +punRdrName :: Name -> RdrName +punRdrName name = + case namePun_maybe name of + Just pun -> + assert (isTcClsNameSpace (nameNameSpace name)) $ -- Only type constructors are punned + ExactPun name $! pun + Nothing -> pprPanic "punRdrName" (ppr name) + nukeExact :: Name -> RdrName nukeExact n | isExternalName n = Orig (nameModule n) (nameOccName n) @@ -281,12 +305,14 @@ isOrig_maybe (Orig m n) = Just (m,n) isOrig_maybe _ = Nothing isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False +isExact (Exact _) = True +isExact (ExactPun _ _) = True +isExact _ = False isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing +isExact_maybe (Exact n) = Just n +isExact_maybe (ExactPun n _) = Just n +isExact_maybe _ = Nothing {- ************************************************************************ @@ -298,6 +324,7 @@ isExact_maybe _ = Nothing instance Outputable RdrName where ppr (Exact name) = ppr name + ppr (ExactPun _ pun_occ) = ppr pun_occ ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) @@ -331,7 +358,7 @@ instance Ord RdrName where a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - -- Exact < Unqual < Qual < Orig + -- Exact < ExactPun < Unqual < Qual < Orig -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig -- before comparing so that Prelude.map == the exact Prelude.map, but -- that meant that we reported duplicates when renaming bindings @@ -342,11 +369,20 @@ instance Ord RdrName where compare (Exact n1) (Exact n2) = n1 `compare` n2 compare (Exact _) _ = LT + compare (ExactPun _ _) (Exact _) = GT + compare (ExactPun n1 _) (ExactPun n2 _) = + -- No need to compare the FastStrings, + -- they are just a cached invocation of namePun_maybe. + compare n1 n2 + compare (ExactPun _ _) _ = LT + compare (Unqual _) (Exact _) = GT + compare (Unqual _) (ExactPun _ _) = GT compare (Unqual o1) (Unqual o2) = o1 `compare` o2 compare (Unqual _) _ = LT compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (ExactPun _ _) = GT compare (Qual _ _) (Unqual _) = GT compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Qual _ _) (Orig _ _) = LT @@ -431,6 +467,7 @@ 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] + ExactPun {} -> False Qual {} -> False Orig {} -> False diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index b60c989bcf..4c7014ac01 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -319,6 +319,7 @@ rdrName2String r = ++ occNameString occ Orig _ occ -> occNameString occ Exact n -> getOccString n + ExactPun _ pun -> unpackFS pun name2String :: Name -> String name2String = showPprUnsafe -- cgit v1.2.1