Refactor renamer datastructures

This patch significantly refactors key renamer datastructures (primarily Avail
and GlobalRdrElt) in order to treat DuplicateRecordFields in a more robust way.
In particular it allows the extension to be used with pattern synonyms (fixes
where mangled record selector names could be printed instead of field labels
(e.g. with -Wpartial-fields or hole fits, see new tests).

The key idea is the introduction of a new type GreName for names that may
represent either normal entities or field labels.  This is then used in
GlobalRdrElt and AvailInfo, in place of the old way of representing fields
using FldParent (yuck) and an extra list in AvailTC.

Updates the haddock submodule.

5 files changed, 75 insertions, 56 deletions

diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 270dc97364..201eb06255 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -1230,57 +1230,48 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
 -}
 
 -- | Haskell Pattern Synonym Details
-type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField (LIdP pass)]
--- The Void argument to HsConDetails here is a reflection of the fact that
--- type applications are not allowed in declarations of pattern synonyms at present.
+type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]
 
 -- See Note [Record PatSyn Fields]
 -- | Record Pattern Synonym Field
-data RecordPatSynField fld
-  = RecordPatSynField {
-      recordPatSynSelectorId :: fld  -- Selector name visible in rest of the file
-      , recordPatSynPatVar   :: fld
-      -- Filled in by renamer, the name used internally
-      -- by the pattern
-      } deriving (Data, Functor)
-
+data RecordPatSynField pass
+  = RecordPatSynField
+      { recordPatSynField :: FieldOcc pass
+      -- ^ Field label visible in rest of the file
+      , recordPatSynPatVar :: LIdP pass
+      -- ^ Filled in by renamer, the name used internally by the pattern
+      }
 
 
 {-
 Note [Record PatSyn Fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Consider the following two pattern synonyms.
 
-pattern P x y = ([x,True], [y,'v'])
-pattern Q{ x, y } =([x,True], [y,'v'])
+  pattern P x y = ([x,True], [y,'v'])
+  pattern Q{ x, y } =([x,True], [y,'v'])
 
 In P, we just have two local binders, x and y.
 
 In Q, we have local binders but also top-level record selectors
-x :: ([Bool], [Char]) -> Bool and similarly for y.
+  x :: ([Bool], [Char]) -> Bool
+  y :: ([Bool], [Char]) -> Char
+
+Both are recorded in the `RecordPatSynField`s for `x` and `y`:
+* recordPatSynField: the top-level record selector
+* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym.
 
 It would make sense to support record-like syntax
 
-pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
+  pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
 
-when we have a different name for the local and top-level binder
-the distinction between the two names clear
+when we have a different name for the local and top-level binder,
+making the distinction between the two names clear.
 
 -}
-instance Outputable a => Outputable (RecordPatSynField a) where
-    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
-
-instance Foldable RecordPatSynField  where
-    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
-                                 , recordPatSynPatVar = hidden })
-      = f visible `mappend` f hidden
-
-instance Traversable RecordPatSynField where
-    traverse f (RecordPatSynField { recordPatSynSelectorId =visible
-                                  , recordPatSynPatVar = hidden })
-      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
-                                               , recordPatSynPatVar = pat_var })
-          <$> f visible <*> f hidden
+instance Outputable (RecordPatSynField a) where
+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
 
 
 -- | Haskell Pattern Synonym Direction
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 0aec281312..33c32aa7f7 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE DeriveDataTypeable   #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                       -- in module GHC.Hs.Extension
@@ -20,7 +22,7 @@ import GHC.Unit.Module        ( ModuleName, IsBootInterface(..) )
 import GHC.Hs.Doc             ( HsDocString )
 import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )
 import GHC.Types.SourceText   ( SourceText(..), StringLiteral(..), pprWithSourceText )
-import GHC.Types.FieldLabel   ( FieldLbl(..) )
+import GHC.Types.FieldLabel   ( FieldLabel )
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -229,7 +231,6 @@ data IE pass
                 (LIEWrappedName (IdP pass))
                 IEWildcard
                 [LIEWrappedName (IdP pass)]
-                [XRec pass (FieldLbl (IdP pass))]
         -- ^ Imported or exported Thing With given imported or exported
         --
         -- The thing is a Class/Type and the imported or exported things are
@@ -256,46 +257,61 @@ data IE pass
 type instance XIEVar             (GhcPass _) = NoExtField
 type instance XIEThingAbs        (GhcPass _) = NoExtField
 type instance XIEThingAll        (GhcPass _) = NoExtField
-type instance XIEThingWith       (GhcPass _) = NoExtField
 type instance XIEModuleContents  (GhcPass _) = NoExtField
 type instance XIEGroup           (GhcPass _) = NoExtField
 type instance XIEDoc             (GhcPass _) = NoExtField
 type instance XIEDocNamed        (GhcPass _) = NoExtField
 type instance XXIE               (GhcPass _) = NoExtCon
 
+-- See Note [IEThingWith]
+type instance XIEThingWith       (GhcPass 'Renamed)     = [Located FieldLabel]
+type instance XIEThingWith       (GhcPass 'Parsed)      = NoExtField
+type instance XIEThingWith       (GhcPass 'Typechecked) = NoExtField
+
+
 -- | Imported or Exported Wildcard
 data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
 
 {-
 Note [IEThingWith]
 ~~~~~~~~~~~~~~~~~~
-
 A definition like
 
+    {-# LANGUAGE DuplicateRecordFields #-}
     module M ( T(MkT, x) ) where
       data T = MkT { x :: Int }
 
-gives rise to
+gives rise to this in the output of the parser:
+
+    IEThingWith NoExtField T [MkT, x] NoIEWildcard
+
+But in the renamer we need to attach the correct field label,
+because the selector Name is mangled (see Note [FieldLabel] in
+GHC.Types.FieldLabel).  Hence we change this to:
+
+    IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard
 
-    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)
-    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)
+using the TTG extension field to store the list of fields in renamed syntax
+only.  (Record fields always appear in this list, regardless of whether
+DuplicateRecordFields was in use at the definition site or not.)
 
 See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details.
 -}
 
 ieName :: IE (GhcPass p) -> IdP (GhcPass p)
-ieName (IEVar _ (L _ n))              = ieWrappedName n
-ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n
-ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n
-ieName (IEThingAll  _ (L _ n))        = ieWrappedName n
+ieName (IEVar _ (L _ n))            = ieWrappedName n
+ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n
+ieName (IEThingWith _ (L _ n) _ _)  = ieWrappedName n
+ieName (IEThingAll  _ (L _ n))      = ieWrappedName n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]
-ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n
-                                       : map (ieWrappedName . unLoc) ns
+ieNames (IEVar       _ (L _ n)   )   = [ieWrappedName n]
+ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]
+ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]
+ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n
+                                     : map (ieWrappedName . unLoc) ns
+-- NB the above case does not include names of field selectors
 ieNames (IEModuleContents {})     = []
 ieNames (IEGroup          {})     = []
 ieNames (IEDoc            {})     = []
@@ -321,10 +337,9 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
     ppr (IEVar       _     var) = ppr (unLoc var)
     ppr (IEThingAbs  _   thing) = ppr (unLoc thing)
     ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]
-    ppr (IEThingWith _ thing wc withs flds)
+    ppr (IEThingWith flds thing wc withs)
         = ppr (unLoc thing) <> parens (fsep (punctuate comma
-                                              (ppWiths ++
-                                              map (ppr . flLabel . unLoc) flds)))
+                                              (ppWiths ++ ppFields) ))
       where
         ppWiths =
           case wc of
@@ -333,6 +348,10 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
               IEWildcard pos ->
                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
                 in bs ++ [text ".."] ++ as
+        ppFields =
+          case ghcPass @p of
+            GhcRn -> map ppr flds
+            _     -> []
     ppr (IEModuleContents _ mod')
         = text "module" <+> ppr mod'
     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 7515c37fb5..3098f3a935 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -69,6 +69,11 @@ deriving instance Data (ABExport GhcPs)
 deriving instance Data (ABExport GhcRn)
 deriving instance Data (ABExport GhcTc)
 
+-- deriving instance DataId p => Data (RecordPatSynField p)
+deriving instance Data (RecordPatSynField GhcPs)
+deriving instance Data (RecordPatSynField GhcRn)
+deriving instance Data (RecordPatSynField GhcTc)
+
 -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR)
 deriving instance Data (PatSynBind GhcPs GhcPs)
 deriving instance Data (PatSynBind GhcPs GhcRn)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 1b1e56b314..2c64d7a491 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1898,9 +1898,13 @@ type LFieldOcc pass = XRec pass (FieldOcc pass)
 
 -- | Field Occurrence
 --
--- Represents an *occurrence* of an unambiguous field.  We store
--- both the 'RdrName' the user originally wrote, and after the
--- renamer, the selector function.
+-- Represents an *occurrence* of an unambiguous field.  This may or may not be a
+-- binding occurrence (e.g. this type is used in 'ConDeclField' and
+-- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for
+-- record construction and patterns, which do not).
+--
+-- We store both the 'RdrName' the user originally wrote, and after the renamer,
+-- the selector function.
 data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass
                               , rdrNameFieldOcc :: Located RdrName
                                  -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 0051eaa2c9..e414269413 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1192,17 +1192,17 @@ hsForeignDeclsBinders foreign_decls
 
 
 -------------------
-hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]
 -- ^ Collects record pattern-synonym selectors only; the pattern synonym
 -- names are collected by 'collectHsValBinders'.
 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
   = foldr addPatSynSelector [] . unionManyBags $ map snd binds
 
-addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [IdP p] -> [IdP p]
+addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]
 addPatSynSelector bind sels
   | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind
-  = map (unXRec @p . recordPatSynSelectorId) as ++ sels
+  = map recordPatSynField as ++ sels
   | otherwise = sels
 
 getPatSynBinds :: forall id. UnXRec id