ghc: implement OverloadedRecordFieldswip/orf

This fully implements the new ORF extension, developed during the Google
Summer of Code 2013, and as described on the wiki:

  https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields

This also updates the Haddock submodule.

Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

7 files changed, 169 insertions, 68 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bcea29bea2..f42375926e 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -238,8 +238,11 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
                                , dd_cons = cons', dd_derivs = derivs' }
 
        ; returnL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+                                         , dfid_rep_tycon = placeHolderRepTyCon
+                                         , dfid_pats = typats'
+                                         , dfid_defn = defn
+                                         , dfid_fvs = placeHolderNames} }}
 
 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
@@ -250,8 +253,11 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
                                , dd_kindSig = Nothing
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+                                         , dfid_rep_tycon = placeHolderRepTyCon
+                                         , dfid_pats = typats'
+                                         , dfid_defn = defn
+                                         , dfid_fvs = placeHolderNames } }}
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
@@ -396,7 +402,8 @@ cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 cvt_id_arg (i, str, ty)
   = do  { i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
-        ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
+        ; return (ConDeclField { cd_fld_lbl = i', cd_fld_sel = error "cvt_id_arg"
+                               , cd_fld_type =  ty', cd_fld_doc = Nothing}) }
 
 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
 cvtDerivs [] = return Nothing
@@ -642,7 +649,8 @@ which we don't want.
 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 cvtFld (v,e)
   = do  { v' <- vNameL v; e' <- cvtl e
-        ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
+        ; return (HsRecField { hsRecFieldLbl = v', hsRecFieldSel = hsRecFieldSelMissing
+                             , hsRecFieldArg = e', hsRecPun = False}) }
 
 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
@@ -852,7 +860,8 @@ cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e'
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)
   = do  { s' <- vNameL s; p' <- cvtPat p
-        ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
+        ; return (HsRecField { hsRecFieldLbl = s', hsRecFieldSel = hsRecFieldSelMissing
+                             , hsRecFieldArg = p', hsRecPun = False}) }
 
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bae804eb07..932810708d 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -31,6 +31,7 @@ module HsDecls (
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
   TyFamInstEqn(..), LTyFamInstEqn,
   LClsInstDecl, ClsInstDecl(..),
+  placeHolderRepTyCon,
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
@@ -921,6 +922,7 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name)
 data DataFamInstDecl name
   = DataFamInstDecl
        { dfid_tycon :: Located name
+       , dfid_rep_tycon :: Name                     -- error thunk until renamer
        , dfid_pats  :: HsWithBndrs [LHsType name]   -- lhs
             -- ^ Type patterns (with kind and type bndrs)
             -- See Note [Family instance declaration binders]
@@ -928,6 +930,10 @@ data DataFamInstDecl name
        , dfid_fvs   :: NameSet }                    -- free vars for dependency analysis
   deriving( Typeable, Data )
 
+placeHolderRepTyCon :: Name
+-- Used for the Name in DataFamInstDecl prior to the renamer
+placeHolderRepTyCon = panic "placeHolderRepTyCon"
+
 
 ----------------- Class instances -------------
 
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index f5ba1903ee..9e85818f8d 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -331,6 +331,8 @@ data HsExpr id
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
   |  HsUnboundVar RdrName
+  |  HsOverloadedRecFld FieldLabelString
+  |  HsSingleRecFld RdrName id   -- Used to attach a selector id to non-overloaded fields
   deriving (Data, Typeable)
 
 -- | HsTupArg is used for tuple sections
@@ -645,7 +647,8 @@ ppr_expr (HsArrForm op _ args)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
 ppr_expr (HsUnboundVar nm)
   = ppr nm
-
+ppr_expr (HsOverloadedRecFld f) = ppr f
+ppr_expr (HsSingleRecFld f _) = ppr f
 \end{code}
 
 HsSyn records exactly where the user put parens, with HsPar.
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index 7163cbfe10..8192f51c2d 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -13,6 +13,7 @@ module HsImpExp where
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
+import Avail
 
 import Outputable
 import FastString
@@ -107,7 +108,7 @@ data IE name
   = IEVar               name
   | IEThingAbs          name             -- ^ Class/Type (can't tell)
   | IEThingAll          name             -- ^ Class/Type plus all methods/constructors
-  | IEThingWith         name [name]      -- ^ Class/Type plus some methods/constructors
+  | IEThingWith         name [name] (AvailFlds name)  -- ^ Class/Type plus some methods/constructors and record fields
   | IEModuleContents    ModuleName       -- ^ (Export Only)
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
@@ -117,21 +118,21 @@ data IE name
 
 \begin{code}
 ieName :: IE name -> name
-ieName (IEVar n)         = n
-ieName (IEThingAbs  n)   = n
-ieName (IEThingWith n _) = n
-ieName (IEThingAll  n)   = n
+ieName (IEVar n)           = n
+ieName (IEThingAbs  n)     = n
+ieName (IEThingWith n _ _) = n
+ieName (IEThingAll  n)     = n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
-ieNames (IEVar            n   ) = [n]
-ieNames (IEThingAbs       n   ) = [n]
-ieNames (IEThingAll       n   ) = [n]
-ieNames (IEThingWith      n ns) = n : ns
-ieNames (IEModuleContents _   ) = []
-ieNames (IEGroup          _ _ ) = []
-ieNames (IEDoc            _   ) = []
-ieNames (IEDocNamed       _   ) = []
+ieNames (IEVar            n     ) = [n]
+ieNames (IEThingAbs       n     ) = [n]
+ieNames (IEThingAll       n     ) = [n]
+ieNames (IEThingWith      n ns fs) = n : ns ++ availFieldsNames fs
+ieNames (IEModuleContents _     ) = []
+ieNames (IEGroup          _ _   ) = []
+ieNames (IEDoc            _     ) = []
+ieNames (IEDocNamed       _     ) = []
 \end{code}
 
 \begin{code}
@@ -147,8 +148,10 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc var
     ppr (IEThingAbs     thing)  = pprImpExp thing
     ppr (IEThingAll     thing)  = hcat [pprImpExp thing, text "(..)"]
-    ppr (IEThingWith thing withs)
-        = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
+    ppr (IEThingWith thing withs flds)
+        = pprImpExp thing <> parens (fsep (punctuate comma
+                                        (map pprImpExp withs ++
+                                            map pprAvailField flds)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index ef888fe5a8..37272f0293 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -12,7 +12,10 @@ module HsPat (
 
         HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
-        HsRecFields(..), HsRecField(..), hsRecFields,
+        HsRecFields(..), HsRecField(..),
+        hsRecFieldSelMissing,
+        hsRecFieldId, hsRecFieldId_maybe,
+        hsRecFields, hsRecFieldsUnambiguous,
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
@@ -40,11 +43,13 @@ import DataCon
 import TyCon
 import Outputable
 import Type
+import RdrName
+import OccName
 import SrcLoc
 import FastString
+import Maybes
 -- libraries:
 import Data.Data hiding (TyCon)
-import Data.Maybe
 \end{code}
 
 
@@ -199,7 +204,8 @@ data HsRecFields id arg         -- A bunch of record fields
 --                     and the remainder being 'filled in' implicitly
 
 data HsRecField id arg = HsRecField {
-        hsRecFieldId  :: Located id,
+        hsRecFieldLbl :: Located RdrName,
+        hsRecFieldSel :: Either id [(id, id)],
         hsRecFieldArg :: arg,           -- Filled in by renamer
         hsRecPun      :: Bool           -- Note [Punning]
   } deriving (Data, Typeable)
@@ -207,8 +213,8 @@ data HsRecField id arg = HsRecField {
 -- Note [Punning]
 -- ~~~~~~~~~~~~~~
 -- If you write T { x, y = v+1 }, the HsRecFields will be
---      HsRecField x x True ...
---      HsRecField y (v+1) False ...
+--      HsRecField x x x True ...
+--      HsRecField y y (v+1) False ...
 -- That is, for "punned" field x is expanded (in the renamer)
 -- to x=x; but with a punning flag so we can detect it later
 -- (e.g. when pretty printing)
@@ -216,8 +222,25 @@ data HsRecField id arg = HsRecField {
 -- If the original field was qualified, we un-qualify it, thus
 --    T { A.x } means T { A.x = x }
 
-hsRecFields :: HsRecFields id arg -> [id]
-hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
+hsRecFieldSelMissing :: Either id [(id, id)]
+hsRecFieldSelMissing = error "hsRecFieldSelMissing"
+
+hsRecFields :: HsRecFields id arg -> [(FieldLabelString, Either id [(id, id)])]
+hsRecFields rbinds = map toFld (rec_flds rbinds)
+  where
+    toFld x = ( occNameFS . rdrNameOcc . unLoc . hsRecFieldLbl $ x
+              , hsRecFieldSel x)
+
+hsRecFieldsUnambiguous :: HsRecFields id arg -> [(FieldLabelString, id)]
+hsRecFieldsUnambiguous = map outOfLeftField . hsRecFields
+  where outOfLeftField (l, Left x)  = (l, x)
+        outOfLeftField (_, Right _) = error "hsRecFieldsUnambigous"
+
+hsRecFieldId_maybe :: HsRecField id arg -> Maybe (Located id)
+hsRecFieldId_maybe x = either (Just . L (getLoc (hsRecFieldLbl x))) (const Nothing) (hsRecFieldSel x)
+
+hsRecFieldId :: HsRecField id arg -> Located id
+hsRecFieldId = expectJust "hsRecFieldId" . hsRecFieldId_maybe
 \end{code}
 
 %************************************************************************
@@ -300,7 +323,7 @@ instance (OutputableBndr id, Outputable arg)
 
 instance (OutputableBndr id, Outputable arg)
       => Outputable (HsRecField id arg) where
-  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
+  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
                     hsRecPun = pun })
     = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
 \end{code}
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 28c6a2b89c..4ae141bc83 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -23,7 +23,7 @@ module HsTypes (
         LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
 
-        ConDeclField(..), pprConDeclFields,
+        ConDeclField(..), pprConDeclFields, cd_fld_name,
         
         mkHsQTvs, hsQTvBndrs,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
@@ -34,6 +34,8 @@ module HsTypes (
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
 
+        getDFunHsTypeKey,
+
         -- Printing
         pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context,
     ) where
@@ -42,10 +44,12 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
 
 import HsLit
 
-import Name( Name )
-import RdrName( RdrName )
+import Name( Name, getOccName, occNameString )
+import RdrName( RdrName, rdrNameOcc )
 import DataCon( HsBang(..) )
 import Type
+import TysWiredIn
+import PrelNames
 import HsDoc
 import BasicTypes
 import SrcLoc
@@ -367,11 +371,15 @@ data HsTupleSort = HsUnboxedTuple
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
 data ConDeclField name  -- Record fields have Haddoc docs on them
-  = ConDeclField { cd_fld_name :: Located name,
+  = ConDeclField { cd_fld_lbl  :: Located RdrName,
+                   cd_fld_sel  :: name,  -- error thunk until after renaming
                    cd_fld_type :: LBangType name, 
                    cd_fld_doc  :: Maybe LHsDocString }
   deriving (Data, Typeable)
 
+cd_fld_name :: ConDeclField name -> Located name
+cd_fld_name x = L (getLoc (cd_fld_lbl x)) $ cd_fld_sel x
+
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
@@ -518,6 +526,39 @@ splitHsFunType other               = ([], other)
 \end{code}
 
 
+\begin{code}
+-- Get some string from a type, to be used to construct a dictionary
+-- function name (like getDFunTyKey in TcType, but for HsTypes)
+getDFunHsTypeKey :: HsType RdrName -> String
+getDFunHsTypeKey (HsForAllTy _ _ _ t)   = getDFunHsTypeKey (unLoc t)
+getDFunHsTypeKey (HsTyVar tv)           = occNameString (rdrNameOcc tv)
+getDFunHsTypeKey (HsAppTy fun _)        = getDFunHsTypeKey (unLoc fun)
+getDFunHsTypeKey (HsFunTy {})           = occNameString (getOccName funTyCon)
+getDFunHsTypeKey (HsListTy _)           = occNameString (getOccName listTyCon)
+getDFunHsTypeKey (HsPArrTy _)           = occNameString (getOccName parrTyCon)
+getDFunHsTypeKey (HsTupleTy {})         = occNameString (getOccName unitTyCon)
+getDFunHsTypeKey (HsOpTy _ (_, op) _)   = occNameString (rdrNameOcc (unLoc op))
+getDFunHsTypeKey (HsParTy ty)           = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsIParamTy {})        = occNameString (getOccName ipClassName)
+getDFunHsTypeKey (HsEqTy {})            = occNameString (getOccName eqTyCon)
+getDFunHsTypeKey (HsKindSig ty _)       = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsQuasiQuoteTy {})    = "quasiQuote"
+getDFunHsTypeKey (HsSpliceTy {})        = "splice"
+getDFunHsTypeKey (HsDocTy ty _)         = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsBangTy _ ty)        = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsRecTy {})           = "record"
+getDFunHsTypeKey (HsCoreTy {})          = "core"
+getDFunHsTypeKey (HsExplicitListTy {})  = occNameString (getOccName listTyCon)
+getDFunHsTypeKey (HsExplicitTupleTy {}) = occNameString (getOccName unitTyCon)
+getDFunHsTypeKey (HsTyLit x)            = getDFunHsTyLitKey x
+getDFunHsTypeKey (HsWrapTy _ ty)        = getDFunHsTypeKey ty
+
+getDFunHsTyLitKey :: HsTyLit -> String
+getDFunHsTyLitKey (HsNumTy n) = show n
+getDFunHsTyLitKey (HsStrTy n) = show n
+\end{code}
+
+
 %************************************************************************
 %*                                                                      *
 \subsection{Pretty printing}
@@ -568,7 +609,7 @@ ppr_hs_context cxt = parens (interpp'SP cxt)
 pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
-    ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
+    ppr_fld (ConDeclField { cd_fld_lbl = n, cd_fld_type = ty, 
                             cd_fld_doc = doc })
         = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index eff67df3cf..b0bf427c73 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -100,6 +100,8 @@ import Util
 import Bag
 import Outputable
 import Data.Either
+import Data.Foldable (foldMap)
+import Data.Monoid
 \end{code}
 
 
@@ -677,31 +679,37 @@ variables bound by the lazy pattern are n,m, *not* the dictionary d.
 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 
 \begin{code}
-hsGroupBinders :: HsGroup Name -> [Name]
+hsGroupBinders :: HsGroup Name -> ([Name], [(RdrName, Name, Name)])
 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                           hs_instds = inst_decls, hs_fords = foreign_decls })
 -- Collect the binders of a Group
-  =  collectHsValBinders val_decls
-  ++ hsTyClDeclsBinders tycl_decls inst_decls
-  ++ hsForeignDeclsBinders foreign_decls
+  =  (collectHsValBinders val_decls, [])
+       `mappend` hsTyClDeclsBinders tycl_decls inst_decls
+       `mappend` (hsForeignDeclsBinders foreign_decls, [])
 
 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
-hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] ->
+                          ([Name], [(RdrName, Name, Name)])
 -- We need to look at instance declarations too, 
 -- because their associated types may bind data constructors
 hsTyClDeclsBinders tycl_decls inst_decls
-  = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
-               concatMap (hsInstDeclBinders . unLoc) inst_decls)
+  = unLocs (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls `mappend`
+                          foldMap (hsInstDeclBinders . unLoc) inst_decls)
+  where unLocs (xs, ys) = (map unLoc xs, map (\ (x, y, z) -> (unLoc x, y, unLoc z)) ys)
 
 -------------------
-hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
+hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) ->
+                          ([Located name], [(Located RdrName, name, Located name)])
 -- ^ Returns all the /binding/ names of the decl.
--- The first one is guaranteed to be the name of the decl. For record fields
+-- The first one is guaranteed to be the name of the decl. The first component
+-- represents all binding names except fields; the second represents fields as
+-- (label, selector name, tycon name) triples. For record fields
 -- mentioned in multiple constructors, the SrcLoc will be from the first
 -- occurrence.  We use the equality to filter out duplicate field names.
+-- Note that the selector name will be an error thunk until after the renamer.
 --
 -- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
 -- /declaration/, not just the name itself (which is how it appears in
@@ -710,56 +718,64 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 -- error messages.  (See Trac #8607.)
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
-  = [L loc name]
-hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = [L loc name]
-hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = [L loc name]
+  = ([L loc name], [])
+hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = ([L loc name], [])
+hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
 hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                        , tcdSigs = sigs, tcdATs = ats }))
-  = L loc cls_name :
-    [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
-    [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ]
+  = (L loc cls_name :
+       [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
+       [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ]
+    , [])
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
-  = L loc name : hsDataDefnBinders defn
+  = (\ (xs, ys) -> (L loc name : xs, ys)) $ withTyCon (L loc name) $ hsDataDefnBinders defn
 
 -------------------
-hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
+hsInstDeclBinders :: Eq name => InstDecl name ->
+                         ([Located name], [(Located RdrName, name, Located name)])
 hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
-  = concatMap (hsDataFamInstBinders . unLoc) dfis
+  = foldMap (hsDataFamInstBinders . unLoc) dfis
 hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
-hsInstDeclBinders (TyFamInstD {}) = []
+hsInstDeclBinders (TyFamInstD {}) = mempty
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
-hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
-  = hsDataDefnBinders defn
+hsDataFamInstBinders :: Eq name => DataFamInstDecl name ->
+                            ([Located name], [(Located RdrName, name, Located name)])
+hsDataFamInstBinders (DataFamInstDecl { dfid_tycon = tycon_name, dfid_defn = defn })
+  = withTyCon tycon_name (hsDataDefnBinders defn)
   -- There can't be repeated symbols because only data instances have binders
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
+hsDataDefnBinders :: Eq name => HsDataDefn name ->
+                         ([Located name], [(Located RdrName, name)])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
-hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
+hsConDeclsBinders :: (Eq name) => [LConDecl name] ->
+                         ([Located name], [(Located RdrName, name)])
   -- See hsLTyClDeclBinders for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
 hsConDeclsBinders cons
-  = snd (foldl do_one ([], []) cons)
+  = foldl do_one ([], []) cons
   where
-    do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name
+    do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name
                                             , con_details = RecCon flds }))
-	= (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc)
-	where
+        = (L loc name : acc, map cd_fld_lfld new_flds ++ flds_seen)
+        where
           -- don't re-mangle the location of field names, because we don't
           -- have a record of the full location of the field declaration anyway
-	  new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
-			       (map cd_fld_name flds)
+          new_flds = filterOut (\ x -> unLoc (cd_fld_lbl x) `elem` map (unLoc . fst) flds_seen) flds
+          cd_fld_lfld x = (cd_fld_lbl x, cd_fld_sel x)
+
+    do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name }))
+        = (L loc name : acc, flds_seen)
 
-    do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name }))
-	= (flds_seen, L loc name : acc)
+withTyCon :: name' -> (a, [(r, name)]) -> (a, [(r, name, name')])
+withTyCon tycon_name (xs, ys) = (xs, map (\ (r, n) -> (r, n, tycon_name)) ys)
 \end{code}
 
 Note [Binders in family instances]