ghc: implement OverloadedRecordFieldswip/orf-new

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.

7 files changed, 249 insertions, 70 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 43d9bfb4e9..cc3ddcac8b 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -265,7 +265,9 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
                                , dd_cons = cons', dd_derivs = derivs' }
 
        ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+                                         , dfid_rep_tycon = placeHolderRepTyCon
+                                         , dfid_pats = typats'
                                          , dfid_defn = defn
                                          , dfid_fvs = placeHolderNames } }}
 
@@ -278,7 +280,9 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
                                , dd_kindSig = Nothing
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+                                         , dfid_rep_tycon = placeHolderRepTyCon
+                                         , dfid_pats = typats'
                                          , dfid_defn = defn
                                          , dfid_fvs = placeHolderNames } }}
 
@@ -426,7 +430,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
@@ -679,7 +684,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' }
@@ -892,7 +898,8 @@ cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
 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 6f7e41f6f7..a18508e98e 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -38,6 +38,7 @@ module HsDecls (
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
   TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
   LClsInstDecl, ClsInstDecl(..),
+  placeHolderRepTyCon,
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
@@ -1017,14 +1018,18 @@ deriving instance (DataId name) => Data (TyFamInstDecl name)
 type LDataFamInstDecl name = Located (DataFamInstDecl name)
 data DataFamInstDecl name
   = DataFamInstDecl
-       { dfid_tycon :: Located name
-       , dfid_pats  :: HsTyPats name      -- LHS
-       , dfid_defn  :: HsDataDefn  name   -- RHS
-       , dfid_fvs   :: PostRn name NameSet } -- Rree vars for
-                                               -- dependency analysis
+       { dfid_tycon     :: Located name
+       , dfid_rep_tycon :: name  -- See Note [Assigning names to instance declarations] in RnSource
+       , dfid_pats      :: HsTyPats   name       -- LHS
+       , dfid_defn      :: HsDataDefn name       -- RHS
+       , dfid_fvs       :: PostRn name NameSet } -- Free vars for dependency analysis
   deriving( Typeable )
 deriving instance (DataId name) => Data (DataFamInstDecl name)
 
+placeHolderRepTyCon :: name
+-- Used for dfid_rep_tycon in DataFamInstDecl prior to the renamer
+placeHolderRepTyCon = panic "placeHolderRepTyCon"
+
 
 ----------------- Class instances -------------
 
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index c61e0c719c..b8a156dfd7 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -218,6 +218,10 @@ data HsExpr id
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
 
+  -- | Overloaded record fields
+  | HsOverloadedRecFld FieldLabelString
+  | HsSingleRecFld RdrName id   -- Used to attach a selector id to non-overloaded fields
+
   -- | Expression with an explicit type signature. @e :: type@  
   | ExprWithTySig                       
                 (LHsExpr id)
@@ -651,7 +655,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..db01070bbb 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,8 @@ 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; see Note [IEThingWith]
   | IEModuleContents    ModuleName       -- ^ (Export Only)
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
@@ -115,23 +117,39 @@ data IE name
   deriving (Eq, Data, Typeable)
 \end{code}
 
+Note [IEThingWith]
+~~~~~~~~~~~~~~~~~~
+
+A definition like
+
+    module M ( T(MkT, x) ) where
+      data T = MkT { x :: Int }
+
+gives rise to
+
+    IEThingWith T [MkT] [("x", Nothing)]         (without OverloadedRecordFields)
+    IEThingWith T [MkT] [("x", Just $sel:x:T)]   (with    OverloadedRecordFields)
+
+See Note [Representing fields in AvailInfo] in Avail for more details.
+
+
 \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 +165,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 bbd37bc426..7ebdad725c 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -18,7 +18,10 @@ module HsPat (
 
         HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
-        HsRecFields(..), HsRecField(..), hsRecFields,
+        HsRecFields(..), HsRecField(..),
+        hsRecFieldSelMissing,
+        hsRecFieldId, hsRecFieldId_maybe,
+        hsRecFields, hsRecFieldsUnambiguous,
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
@@ -45,13 +48,16 @@ import Var
 import ConLike
 import DataCon
 import TyCon
+import FieldLabel
 import Outputable
 import Type
+import RdrName
+import OccName
 import SrcLoc
 import FastString
+import Maybes
 -- libraries:
 import Data.Data hiding (TyCon,Fixity)
-import Data.Maybe
 \end{code}
 
 
@@ -217,7 +223,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)], -- Note [HsRecField selector]
         hsRecFieldArg :: arg,           -- Filled in by renamer
         hsRecPun      :: Bool           -- Note [Punning]
   } deriving (Data, Typeable)
@@ -225,8 +232,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)
@@ -234,8 +241,58 @@ 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)
+
+-- Note [HsRecField selector]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- A HsRecField always contains a label (in hsRecFieldLbl), which is
+-- the thing the user wrote, but thanks to OverloadedRecordFields this
+-- may not unambiguously correspond to a Name.  The hsRecFieldSel is
+-- filled in by the renamer (RnPat.rnHsRecFields1) thus:
+--
+--  * If the field is unambiguous, it uses `Left sel_name`
+--
+--  * If the field is ambiguous, there are multiple fields with the
+--    correct label in scope, it uses `Right xs` where `xs` is a list of
+--    (parent name, selector name) pairs.
+--
+-- The typechecker (tcExpr) then disambiguates the record update.
+--
+-- For example, suppose we have:
+--
+--     data S = MkS { x :: Int }
+--     data T = MkT { x :: Int }
+--
+--     f z = (z { x = 3 }) :: S
+--
+-- After the renamer, the HsRecField corresponding to the record
+-- update will have
+--
+--     hsRecFieldLbl = "x"
+--     hsRecFieldSel = Right [(S, $sel:x:S), (T, $sel:x:T)]
+--
+-- and the typechecker will determine that $sel:x:S is meant.
+
+
+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}
 
 %************************************************************************
@@ -318,7 +375,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 9bd5845a45..fd16ab9d2a 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -30,7 +30,7 @@ module HsTypes (
         LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
 
-        ConDeclField(..), pprConDeclFields,
+        ConDeclField(..), pprConDeclFields, cd_fld_name,
         
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
@@ -42,6 +42,8 @@ module HsTypes (
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
 
+        getDFunHsTypeKey,
+
         -- Printing
         pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, 
     ) where
@@ -50,11 +52,13 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
 
 import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
-import Name( Name )
-import RdrName( RdrName )
+import Name( Name, getOccName, occNameString )
+import RdrName( RdrName, rdrNameOcc )
 import DataCon( HsBang(..) )
 import TysPrim( funTyConName )
 import Type
+import TysWiredIn
+import PrelNames
 import HsDoc
 import BasicTypes
 import SrcLoc
@@ -397,12 +401,37 @@ data HsTupleSort = HsUnboxedTuple
 data HsExplicitFlag = Qualified | Implicit | Explicit 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,  -- See Note [ConDeclField selector]
                    cd_fld_type :: LBangType name, 
                    cd_fld_doc  :: Maybe LHsDocString }
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
+cd_fld_name :: ConDeclField name -> Located name
+cd_fld_name x = L (getLoc (cd_fld_lbl x)) $ cd_fld_sel x
+\end{code}
+
+Note [ConDeclField selector]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A ConDeclField always contains the field label as the user wrote it in
+cd_fld_lbl.  After the renamer, it will additionally contain the Name
+of the selector function in cd_fld_sel.  (Before the renamer,
+cd_fld_sel contains an error thunk.)
+
+Due to OverloadedRecordFields, the OccName of the selector function
+may have been mangled, which is why we keep the original field label
+separately.  For example, when OverloadedRecordFields is enabled
+
+    data T = MkT { x :: Int }
+
+gives
+
+    ConDeclField { cd_fld_lbl = "x", cd_fld_sel = $sel:x:T, ... }.
+
+
+\begin{code}
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
@@ -569,6 +598,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}
@@ -615,7 +677,7 @@ pprHsContextNoArrow 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 cae0983a85..e5deb0bf72 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -40,7 +40,7 @@ module HsUtils(
   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
 
   -- Patterns
-  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat,
+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
   nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
 
@@ -101,8 +101,10 @@ import Bag
 import Outputable
 
 import Data.Either
+import Data.Foldable ( foldMap )
 import Data.Function
 import Data.List
+import Data.Monoid ( mempty, mappend )
 \end{code}
 
 
@@ -350,6 +352,9 @@ nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 
+nlConVarPatName :: Name -> [Name] -> LPat Name
+nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
+
 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 
@@ -731,31 +736,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
@@ -764,45 +775,51 @@ 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 :: forall name. (Eq name) => [LConDecl name] -> [Located name]
+hsConDeclsBinders :: forall name. (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 = go id cons
-  where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name]
-        go _ [] = []
+  where go :: ([(Located RdrName, name)] -> [(Located RdrName, name)])
+           -> [LConDecl name] -> ([Located name], [(Located RdrName, name)])
+        go _ [] = ([], [])
         go remSeen (r:rs) =
           -- 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
@@ -810,12 +827,18 @@ hsConDeclsBinders cons = go id cons
              -- remove only the first occurrence of any seen field in order to
              -- avoid circumventing detection of duplicate fields (#9156)
              L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) ->
-               (L loc name) : r' ++ go remSeen' rs
-                  where r' = remSeen (map cd_fld_name flds)
-                        remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
+               (L loc name : ns, r' ++ fs)
+                  where r' = remSeen (map cd_fld_lfld flds)
+                        cd_fld_lfld x = (cd_fld_lbl x, cd_fld_sel x)
+                        remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc . fst) v | v <- r']
+                        (ns, fs) = go remSeen' rs
              L loc (ConDecl { con_name = L _ name }) ->
-                (L loc name) : go remSeen rs
+               (L loc name : ns, fs)
+                  where (ns, fs) = go remSeen rs
+
 
+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]