[Git][ghc/ghc][wip/int-index/pun-names] WIP: Punned names
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Fri Jan 20 12:01:26 UTC 2023
Vladislav Zavialov pushed to branch wip/int-index/pun-names at Glasgow Haskell Compiler / GHC
Commits:
7c53b6be by Vladislav Zavialov at 2023-01-20T14:53:32+03:00
WIP: Punned names
- - - - -
6 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/Name/Reader.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
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
{-
=====================================
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]
=====================================
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;
=====================================
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
=====================================
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 at .
+ --
+ -- 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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c53b6be5ec2ee0285818eeccad374f2689c2d65
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c53b6be5ec2ee0285818eeccad374f2689c2d65
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230120/2bfb250e/attachment-0001.html>
More information about the ghc-commits
mailing list