WIP: Punned nameswip/int-index/pun-names

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