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>

8 files changed, 383 insertions, 64 deletions

diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 1c01d2a334..53eb9cceaa 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -2,33 +2,48 @@
 -- (c) The University of Glasgow
 --
 
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Avail (
-    Avails,
+    Avails, AvailFlds, AvailFld, AvailFields, AvailField,
     AvailInfo(..),
     availsToNameSet,
+    availsToNameSetWithSelectors,
     availsToNameEnv,
-    availName, availNames,
-    stableAvailCmp
+    availName, availNames, availNonFldNames,
+    availNamesWithSelectors,
+    availFlds, availOverloadedFlds,
+    stableAvailCmp, stableAvailFieldsCmp,
+    availFieldsLabels,
+    availFieldsNames, availFieldsNamesWithSelectors,
+    fieldLabelsToAvailFields,
+    pprAvailField
   ) where
 
 import Name
 import NameEnv
 import NameSet
 
+import FieldLabel
 import Binary
 import Outputable
 import Util
 
+import Data.Function
+
 -- -----------------------------------------------------------------------------
 -- The AvailInfo type
 
 -- | Records what things are "available", i.e. in scope
 data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
                | AvailTC Name
-                         [Name]  -- ^ A type or class in scope. Parameters:
+                         [Name]
+                         AvailFields
+                                 -- ^ A type or class in scope. Parameters:
                                  --
                                  --  1) The name of the type or class
                                  --  2) The available pieces of type or class.
+                                 --  3) The record fields of the type.
                                  --
                                  -- The AvailTC Invariant:
                                  --   * If the type or class is itself
@@ -42,14 +57,57 @@ data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
 -- | A collection of 'AvailInfo' - several things that are \"available\"
 type Avails = [AvailInfo]
 
+-- | Record fields in an 'AvailInfo'
+-- See Note [Representing fields in AvailInfo]
+type AvailFlds name = [AvailFld name]
+type AvailFld name  = (name, Maybe FieldLabelString)
+type AvailFields    = AvailFlds Name
+type AvailField     = AvailFld Name
+
+{-
+Note [Representing fields in AvailInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When -XOverloadedRecordFields is disabled (the normal case), a
+datatype like
+
+  data T = MkT { foo :: Int }
+
+gives rise to the AvailInfo
+
+  AvailTC T [T, MkT] [(foo, Nothing)],
+
+whereas if -XOverloadedRecordFields is enabled it gives
+
+  AvailTC T [T, MkT] [($sel:foo:T, Just "foo")]
+
+since the label does not match the selector name.
+
+The labels in an Overloaded field list are not necessarily unique:
+data families allow the same parent (the family tycon) to have
+multiple distinct fields with the same label. For example,
+
+  data family F a
+  data instance F Int  = MkFInt { foo :: Int }
+  data instance F Bool = MkFBool { foo :: Bool}
+
+gives rise to
+
+  AvailTC F [F, MkFInt, MkFBool]
+    [($sel:foo:R:FInt, Just "foo"), ($sel:foo:R:FBool, Just "foo")].
+-}
+
 -- | Compare lexicographically
 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail n1)     (Avail n2)     = n1 `stableNameCmp` n2
-stableAvailCmp (Avail {})     (AvailTC {})   = LT
-stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
-                                               (cmpList stableNameCmp ns ms)
-stableAvailCmp (AvailTC {})   (Avail {})     = GT
+stableAvailCmp (Avail n1)         (Avail n2)     = n1 `stableNameCmp` n2
+stableAvailCmp (Avail {})         (AvailTC {})   = LT
+stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
+    (n `stableNameCmp` m) `thenCmp`
+    (cmpList stableNameCmp ns ms) `thenCmp`
+    (stableAvailFieldsCmp nfs mfs)
+stableAvailCmp (AvailTC {})       (Avail {})     = GT
 
+stableAvailFieldsCmp :: AvailFields -> AvailFields -> Ordering
+stableAvailFieldsCmp = cmpList (stableNameCmp `on` fst)
 
 -- -----------------------------------------------------------------------------
 -- Operations on AvailInfo
@@ -58,6 +116,10 @@ availsToNameSet :: [AvailInfo] -> NameSet
 availsToNameSet avails = foldr add emptyNameSet avails
       where add avail set = addListToNameSet set (availNames avail)
 
+availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
+availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
+      where add avail set = addListToNameSet set (availNamesWithSelectors avail)
+
 availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
 availsToNameEnv avails = foldr add emptyNameEnv avails
      where add avail env = extendNameEnvList env
@@ -66,13 +128,57 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
 -- | Just the main name made available, i.e. not the available pieces
 -- of type or class brought into scope by the 'GenAvailInfo'
 availName :: AvailInfo -> Name
-availName (Avail n)     = n
-availName (AvailTC n _) = n
+availName (Avail n)       = n
+availName (AvailTC n _ _) = n
 
--- | All names made available by the availability information
+-- | All names made available by the availability information (excluding selectors)
 availNames :: AvailInfo -> [Name]
-availNames (Avail n)      = [n]
-availNames (AvailTC _ ns) = ns
+availNames (Avail n)         = [n]
+availNames (AvailTC _ ns fs) = ns ++ availFieldsNames fs
+
+-- | All names made available by the availability information (including selectors)
+availNamesWithSelectors :: AvailInfo -> [Name]
+availNamesWithSelectors (Avail n)         = [n]
+availNamesWithSelectors (AvailTC _ ns fs) = ns ++ availFieldsNamesWithSelectors fs
+
+-- | Names for non-fields made available by the availability information
+availNonFldNames :: AvailInfo -> [Name]
+availNonFldNames (Avail n)        = [n]
+availNonFldNames (AvailTC _ ns _) = ns
+
+-- | Fields made available by the availability information
+availFlds :: AvailInfo -> AvailFields
+availFlds (AvailTC _ _ fs) = fs
+availFlds _                = []
+
+-- | Overloaded fields made available by the availability information
+availOverloadedFlds :: AvailInfo -> [(FieldLabelString, Name)]
+availOverloadedFlds avail = [ (lbl, sel) | (sel, Just lbl) <- availFlds avail ]
+
+-- -----------------------------------------------------------------------------
+-- Operations on AvailFields
+
+availFieldsLabels :: AvailFields -> [FieldLabelString]
+availFieldsLabels = map help
+  where
+    help (_,   Just lbl) = lbl
+    help (sel, Nothing)  = occNameFS $ nameOccName sel
+
+availFieldsNames :: AvailFlds name -> [name]
+availFieldsNames fs = [ n | (n, Nothing) <- fs ]
+
+availFieldsNamesWithSelectors :: AvailFlds name -> [name]
+availFieldsNamesWithSelectors = map fst
+
+fieldLabelToAvailField :: FieldLabel -> AvailField
+fieldLabelToAvailField fl = (flSelector fl, mb_lbl)
+  where
+    mb_lbl | flIsOverloaded fl = Just (flLabel fl)
+           | otherwise         = Nothing
+
+fieldLabelsToAvailFields :: [FieldLabel] -> AvailFields
+fieldLabelsToAvailFields = map fieldLabelToAvailField
+
 
 -- -----------------------------------------------------------------------------
 -- Printing
@@ -81,17 +187,22 @@ instance Outputable AvailInfo where
    ppr = pprAvail
 
 pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail n)      = ppr n
-pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
+pprAvail (Avail n)         = ppr n
+pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map pprAvailField fs)))
+
+pprAvailField :: Outputable name => AvailFld name -> SDoc
+pprAvailField (n, Nothing)  = ppr n
+pprAvailField (_, Just lbl) = ppr lbl
 
 instance Binary AvailInfo where
     put_ bh (Avail aa) = do
             putByte bh 0
             put_ bh aa
-    put_ bh (AvailTC ab ac) = do
+    put_ bh (AvailTC ab ac ad) = do
             putByte bh 1
             put_ bh ab
             put_ bh ac
+            put_ bh ad
     get bh = do
             h <- getByte bh
             case h of
@@ -99,5 +210,5 @@ instance Binary AvailInfo where
                       return (Avail aa)
               _ -> do ab <- get bh
                       ac <- get bh
-                      return (AvailTC ab ac)
-
+                      ad <- get bh
+                      return (AvailTC ab ac ad)
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index ad56290694..53cac1ed59 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -16,7 +16,10 @@ module DataCon (
         -- * Main data types
 	DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
 	ConTag,
-	
+
+        -- ** Field labels
+        FieldLbl(..), FieldLabel, FieldLabelString,
+
 	-- ** Type construction
 	mkDataCon, fIRST_TAG,
         buildAlgTyCon, 
@@ -30,7 +33,7 @@ module DataCon (
 	dataConStupidTheta,  
 	dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
-	dataConFieldLabels, dataConFieldType,
+	dataConFieldLabels, dataConFieldLabel, dataConFieldType,
 	dataConStrictMarks, 
 	dataConSourceArity, dataConRepArity, dataConRepRepArity,
 	dataConIsInfix,
@@ -61,6 +64,7 @@ import Coercion
 import Kind
 import Unify
 import TyCon
+import FieldLabel
 import Class
 import Name
 import Var
@@ -76,6 +80,7 @@ import NameEnv
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
+import Data.List
 import Data.Maybe
 import Data.Char
 import Data.Word
@@ -764,12 +769,16 @@ dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels = dcFields
 
+-- | Extract the 'FieldLabel' and type for any given field of the 'DataCon'
+dataConFieldLabel :: DataCon -> FieldLabelString -> (FieldLabel, Type)
+dataConFieldLabel con lbl
+  = case find ((== lbl) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
+      Just x  -> x
+      Nothing -> pprPanic "dataConFieldLabel" (ppr con <+> ppr lbl)
+
 -- | Extract the type for any given labelled field of the 'DataCon'
-dataConFieldType :: DataCon -> FieldLabel -> Type
-dataConFieldType con label
-  = case lookup label (dcFields con `zip` dcOrigArgTys con) of
-      Just ty -> ty
-      Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
+dataConFieldType :: DataCon -> FieldLabelString -> Type
+dataConFieldType con lbl = snd $ dataConFieldLabel con lbl
 
 -- | The strictness markings decided on by the compiler.  Does not include those for
 -- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot
index 08920ccf64..6d64828cb1 100644
--- a/compiler/basicTypes/DataCon.lhs-boot
+++ b/compiler/basicTypes/DataCon.lhs-boot
@@ -2,6 +2,7 @@
 module DataCon where
 import Name( Name, NamedThing )
 import {-# SOURCE #-} TyCon( TyCon )
+import FieldLabel ( FieldLabel )
 import Unique ( Uniquable )
 import Outputable ( Outputable, OutputableBndr )
 
@@ -9,6 +10,7 @@ data DataCon
 data DataConRep
 dataConName      :: DataCon -> Name
 dataConTyCon     :: DataCon -> TyCon
+dataConFieldLabels :: DataCon -> [FieldLabel]
 isVanillaDataCon :: DataCon -> Bool
 
 instance Eq DataCon
diff --git a/compiler/basicTypes/FieldLabel.lhs b/compiler/basicTypes/FieldLabel.lhs
new file mode 100644
index 0000000000..94a8b05a86
--- /dev/null
+++ b/compiler/basicTypes/FieldLabel.lhs
@@ -0,0 +1,128 @@
+%
+% (c) Adam Gundry 2013
+%
+
+This module defines the representation of FieldLabels as stored in
+TyCons.  As well as a selector name, these have some extra structure
+to support the OverloadedRecordFields extension.  For every field
+label, regardless of whether the extension is enabled in the defining
+module, we generate instances of the Has and Upd classes and FldTy and
+UpdTy type families (all defined in base:GHC.Records).
+
+In the normal case (with NoOverloadedRecordFields), a datatype like
+
+    data T = MkT { foo :: Int }
+
+has FieldLabel { flLabel = "foo"
+               , flIsOverloaded = False
+               , flSelector = foo
+               , flHasDFun = $fHas:foo:T
+               , flUpdDFun = $fUpd:foo:T
+               , flFldTyAxiom = TFCo:FldTy:foo:T
+               , flUpdTyAxiom = TFCo:UpdTy:foo:T }.
+
+In particular, the Name of the selector has the same string
+representation as the label.  If the OverloadedRecordFields extension
+is enabled, however, the same declaration instead gives
+
+               { flIsOverloaded = True
+               , flSelector = $sel:foo:T }.
+
+Now the name of the selector ($sel:foo:T) does not match the label of
+the field (foo).  We must be careful not to show the selector name to
+the user!  The point of mangling the selector name is to allow a
+module to define the same field label in different datatypes:
+
+    data T = MkT { foo :: Int }
+    data U = MkU { foo :: Bool }
+
+\begin{code}
+
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+
+module FieldLabel ( FieldLabelString
+                  , FieldLabelEnv
+                  , FieldLbl(..)
+                  , FieldLabel
+                  , mkFieldLabelOccs
+                  ) where
+
+import OccName
+import Name
+
+import Binary
+import FastString
+import FastStringEnv
+import Outputable
+
+import Data.Foldable
+import Data.Traversable
+
+-- | Field labels are just represented as strings;
+-- they are not necessarily unique (even within a module)
+type FieldLabelString = FastString
+
+-- | A map from labels to all the auxiliary information
+type FieldLabelEnv = FastStringEnv FieldLabel
+
+
+type FieldLabel = FieldLbl Name
+
+-- | Fields in an algebraic record type
+data FieldLbl a = FieldLabel {
+      flLabel        :: FieldLabelString, -- ^ Label of the field
+      flIsOverloaded :: Bool,             -- ^ Is this field overloaded?
+      flSelector     :: a,                -- ^ Record selector function
+      flHasDFun      :: a,                -- ^ DFun for Has class instance
+      flUpdDFun      :: a,                -- ^ DFun for Upd class instance
+      flFldTyAxiom   :: a,                -- ^ Axiom for FldTy family instance
+      flUpdTyAxiom   :: a                 -- ^ Axiom for UpdTy family instance
+    }
+  deriving (Functor, Foldable, Traversable)
+
+instance Outputable a => Outputable (FieldLbl a) where
+    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))
+
+instance Binary a => Binary (FieldLbl a) where
+    put_ bh (FieldLabel aa ab ac ad ae af ag) = do
+        put_ bh aa
+        put_ bh ab
+        put_ bh ac
+        put_ bh ad
+        put_ bh ae
+        put_ bh af
+        put_ bh ag
+
+    get bh = do
+        aa <- get bh
+        ab <- get bh
+        ac <- get bh
+        ad <- get bh
+        ae <- get bh
+        af <- get bh
+        ag <- get bh
+        return (FieldLabel aa ab ac ad ae af ag)
+\end{code}
+
+
+Record selector OccNames are built from the underlying field name and
+the name of the type constructor, to support overloaded record fields.
+
+\begin{code}
+mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
+mkFieldLabelOccs lbl tc is_overloaded
+  = FieldLabel lbl is_overloaded sel_occ has_occ upd_occ get_occ set_occ
+  where
+    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString tc
+    has_str = "Has"
+    upd_str = "Upd"
+    get_str = "FldTy"
+    set_str = "UpdTy"
+
+    sel_occ | is_overloaded = mkRecFldSelOcc str
+            | otherwise     = mkVarOccFS lbl
+    has_occ = mkRecFldDFunOcc (has_str ++ str)
+    upd_occ = mkRecFldDFunOcc (upd_str ++ str)
+    get_occ = mkRecFldAxiomOcc (get_str ++ str)
+    set_occ = mkRecFldAxiomOcc (set_str ++ str)
+\end{code}
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index aada6dccc2..840f2c6d85 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -36,7 +36,7 @@ module Id (
 
         -- ** Taking an Id apart
         idName, idType, idUnique, idInfo, idDetails, idRepArity,
-        recordSelectorFieldLabel,
+        recordSelectorTyCon,
 
         -- ** Modifying an Id
         setIdName, setIdUnique, Id.setIdType, 
@@ -313,12 +313,12 @@ mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
 %************************************************************************
 
 \begin{code}
--- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise
-recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
-recordSelectorFieldLabel id
+-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.
+recordSelectorTyCon :: Id -> TyCon
+recordSelectorTyCon id
   = case Var.idDetails id of
-        RecSelId { sel_tycon = tycon } -> (tycon, idName id)
-        _ -> panic "recordSelectorFieldLabel"
+        RecSelId { sel_tycon = tycon } -> tycon
+        _ -> panic "recordSelectorTyCon"
 
 isRecordSelector        :: Id -> Bool
 isNaughtyRecordSelector :: Id -> Bool
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 38922fcd00..a754622605 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -36,7 +36,7 @@ module MkId (
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
         voidPrimId, voidArgId,
         nullAddrId, seqId, lazyId, lazyIdKey,
-        coercionTokenId, magicDictId, coerceId,
+        coercionTokenId, magicDictId, proxyHashId, coerceId,
 
 	-- Re-export error Ids
 	module PrelRules
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index b41d711f69..d2b811d0e5 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -72,6 +72,7 @@ module OccName (
 	mkPDatasTyConOcc, mkPDatasDataConOcc,
         mkPReprTyConOcc, 
         mkPADFunOcc,
+        mkRecFldSelOcc, mkRecFldDFunOcc, mkRecFldAxiomOcc,
 
 	-- ** Deconstruction
 	occNameFS, occNameString, occNameSpace, 
@@ -645,6 +646,12 @@ mkPDatasTyConOcc   = mk_simple_deriv_with tcName   "VPs:"
 mkPDataDataConOcc  = mk_simple_deriv_with dataName "VPD:"
 mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"
 
+-- Overloaded record field dfunids and axioms
+mkRecFldSelOcc, mkRecFldDFunOcc, mkRecFldAxiomOcc :: String -> OccName
+mkRecFldSelOcc   = mk_deriv varName "$sel"
+mkRecFldDFunOcc  = mk_deriv varName "$f"
+mkRecFldAxiomOcc = mkInstTyCoOcc . mkTcOcc
+
 mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
 mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
 
@@ -702,6 +709,7 @@ mkDFunOcc info_str is_boot set
 	   | otherwise = "$f"
 \end{code}
 
+
 Sometimes we need to pick an OccName that has not already been used,
 given a set of in-use OccNames.
 
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 3ff771f0fe..2e4d78cb9b 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -45,16 +45,17 @@ module RdrName (
 
         -- * Global mapping of 'RdrName' to 'GlobalRdrElt's
         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
-        lookupGlobalRdrEnv, extendGlobalRdrEnv, 
+        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName,
         pprGlobalRdrEnv, globalRdrEnvElts,
-        lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
+        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes,
         transformGREs, findLocalDupsRdrEnv, pickGREs,
 
         -- * GlobalRdrElts
         gresFromAvails, gresFromAvail,
 
         -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
-        GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,
+        unQualOK, qualSpecOK, unQualSpecOK,
         Provenance(..), pprNameProvenance,
         Parent(..),
         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
@@ -70,6 +71,7 @@ import NameSet
 import Maybes
 import SrcLoc
 import FastString
+import FieldLabel
 import Outputable
 import Unique
 import Util
@@ -409,25 +411,39 @@ data GlobalRdrElt
 
 -- | The children of a Name are the things that are abbreviated by the ".."
 --   notation in export lists.  See Note [Parents]
-data Parent = NoParent | ParentIs Name
-              deriving (Eq)
+data Parent = NoParent
+            | ParentIs  { par_is :: Name }
+            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
+            deriving (Eq)
 
 instance Outputable Parent where
-   ppr NoParent     = empty
-   ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
+   ppr NoParent        = empty
+   ppr (ParentIs n)    = ptext (sLit "parent:") <> ppr n
+   ppr (FldParent n f) = ptext (sLit "fldparent:")
+                             <> ppr n <> colon <> ppr f
 
 plusParent :: Parent -> Parent -> Parent
 -- See Note [Combining parents]
-plusParent (ParentIs n) p2 = hasParent n p2
-plusParent p1 (ParentIs n) = hasParent n p1
-plusParent _ _ = NoParent
+plusParent (ParentIs n)    p2 = hasParentIs n p2
+plusParent (FldParent n f) p2 = hasFldParent n f p2
+plusParent p1 (ParentIs n)    = hasParentIs n p1
+plusParent p1 (FldParent n f) = hasFldParent n f p1
+plusParent NoParent NoParent  = NoParent
 
-hasParent :: Name -> Parent -> Parent
+hasParentIs :: Name -> Parent -> Parent
 #ifdef DEBUG
-hasParent n (ParentIs n')
-  | n /= n' = pprPanic "hasParent" (ppr n <+> ppr n')  -- Parents should agree
+hasParentIs n (ParentIs n')
+  | n /= n' = pprPanic "hasParentIs" (ppr n <+> ppr n')  -- Parents should agree
 #endif
-hasParent n _  = ParentIs n
+hasParentIs n _  = ParentIs n
+
+hasFldParent :: Name -> Maybe FieldLabelString -> Parent -> Parent
+#ifdef DEBUG
+hasFldParent n f (FldParent n' f')
+  | n /= n' || f /= f'    -- Parents should agree
+    = pprPanic "hasFldParent" (ppr n <+> ppr f <+> ppr n' <+> ppr f')
+#endif
+hasFldParent n f _  = FldParent n f
 \end{code}
 
 Note [Parents]
@@ -470,27 +486,36 @@ those.  For T that will mean we have
   one GRE with NoParent
 That's why plusParent picks the "best" case.
 
-
 \begin{code}
 -- | make a 'GlobalRdrEnv' where all the elements point to the same
 -- Provenance (useful for "hiding" imports, or imports with
 -- no details).
 gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
 gresFromAvails prov avails
-  = concatMap (gresFromAvail (const prov)) avails
-
-gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
-gresFromAvail prov_fn avail
-  = [ GRE {gre_name = n,
-           gre_par = mkParent n avail,
-           gre_prov = prov_fn n}
-    | n <- availNames avail ]
+  = concatMap (gresFromAvail (const prov) prov) avails
+
+gresFromAvail :: (Name -> Provenance) -> Provenance
+              -> AvailInfo -> [GlobalRdrElt]
+gresFromAvail prov_fn prov_fld avail = xs ++ ys
   where
+    parent _ (Avail _)                   = NoParent
+    parent n (AvailTC m _ _) | n == m    = NoParent
+                             | otherwise = ParentIs m
+
+    xs = map greFromFld (availFlds avail)
+    ys = map greFromNonFld (availNonFldNames avail)
+
+    greFromNonFld n = GRE { gre_name = n, gre_par = parent n avail, gre_prov = prov_fn n}
+
+    greFromFld (n, mb_lbl)
+      = GRE { gre_name = n
+            , gre_par  = FldParent (availName avail) mb_lbl
+            , gre_prov = prov_fld }
 
 mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail _)                 = NoParent
-mkParent n (AvailTC m _) | n == m    = NoParent
-                         | otherwise = ParentIs m
+mkParent _ (Avail _)                   = NoParent
+mkParent n (AvailTC m _ _) | n == m    = NoParent
+                           | otherwise = ParentIs m
 
 emptyGlobalRdrEnv :: GlobalRdrEnv
 emptyGlobalRdrEnv = emptyOccEnv
@@ -524,6 +549,10 @@ lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
                                   Nothing   -> []
                                   Just gres -> gres
 
+greOccName :: GlobalRdrElt -> OccName
+greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl
+greOccName gre                                            = nameOccName (gre_name gre)
+
 lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
 lookupGRE_RdrName rdr_name env
   = case lookupOccEnv env (rdrNameOcc rdr_name) of
@@ -535,6 +564,14 @@ lookupGRE_Name env name
   = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name),
             gre_name gre == name ]
 
+lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt]
+-- Used when looking up record fields, where the selector name and
+-- field label are different: the GlobalRdrEnv is keyed on the label
+lookupGRE_Field_Name env sel_name lbl
+  = [ gre | gre <- lookupGlobalRdrEnv env (mkVarOccFS lbl),
+            gre_name gre == sel_name ]
+
+
 getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
 -- Returns all the qualifiers by which 'x' is in scope
 -- Nothing means "the unqualified version is in scope"
@@ -549,6 +586,21 @@ isLocalGRE :: GlobalRdrElt -> Bool
 isLocalGRE (GRE {gre_prov = LocalDef}) = True
 isLocalGRE _                           = False
 
+isRecFldGRE :: GlobalRdrElt -> Bool
+isRecFldGRE (GRE {gre_par = FldParent{}}) = True
+isRecFldGRE _                             = False
+
+isOverloadedRecFldGRE :: GlobalRdrElt -> Bool
+isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}})
+                        = True
+isOverloadedRecFldGRE _ = False
+
+-- Returns the field label of this GRE, if it has one
+greLabel :: GlobalRdrElt -> Maybe FieldLabelString
+greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
+greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))
+greLabel _                                              = Nothing
+
 unQualOK :: GlobalRdrElt -> Bool
 -- ^ Test if an unqualifed version of this thing would be in scope
 unQualOK (GRE {gre_prov = LocalDef})    = True
@@ -628,7 +680,7 @@ mkGlobalRdrEnv gres
   = foldr add emptyGlobalRdrEnv gres
   where
     add gre env = extendOccEnv_Acc insertGRE singleton env
-                                   (nameOccName (gre_name gre))
+                                   (greOccName gre)
                                    gre
 
 insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
@@ -685,14 +737,23 @@ extendGlobalRdrEnv do_shadowing env avails
          -- don't shadow each other; that would conceal genuine errors
          -- E.g. in GHCi   data T = A | A
 
-    add_avail env avail = foldl (add_name avail) env (availNames avail)
+    add_avail env avail = foldl (add_fld_name avail)
+                               (foldl (add_name avail) env (availNonFldNames avail))
+                               (availFlds avail)
+
+    add_name avail env name = add_name' env name (nameOccName name) (mkParent name avail)
+
+    add_fld_name (AvailTC par_name _ _) env (name, mb_fld) =
+        add_name' env name lbl (FldParent par_name mb_fld)
+      where
+        lbl = maybe (nameOccName name) mkVarOccFS mb_fld
+    add_fld_name (Avail _) _ _ = error "Field made available without its parent"
 
-    add_name avail env name
+    add_name' env name occ par
        = extendOccEnv_Acc (:) singleton env occ gre
        where
-         occ = nameOccName name
          gre = GRE { gre_name = name
-                   , gre_par = mkParent name avail
+                   , gre_par = par
                    , gre_prov = LocalDef }
 
 shadow_name :: GlobalRdrEnv -> Name -> GlobalRdrEnv