Implement DuplicateRecordFields

This implements DuplicateRecordFields, the first part of the
OverloadedRecordFields extension, as described at
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields

This includes fairly wide-ranging changes in order to allow multiple
records within the same module to use the same field names.  Note that
it does *not* allow record selector functions to be used if they are
ambiguous, and it does not have any form of type-based disambiguation
for selectors (but it does for updates). Subsequent parts will make
overloading selectors possible using orthogonal extensions, as
described on the wiki pages.  This part touches quite a lot of the
codebase, and requires changes to several GHC API datatypes in order
to distinguish between field labels (which may be overloaded) and
selector function names (which are always unique).

The Haddock submodule has been adapted to compile with the GHC API
changes, but it will need further work to properly support modules
that use the DuplicateRecordFields extension.

Test Plan: New tests added in testsuite/tests/overloadedrecflds; these
will be extended once the other parts are implemented.

Reviewers: goldfire, bgamari, simonpj, austin

Subscribers: sjcjoosten, haggholm, mpickering, bgamari, tibbe, thomie,
goldfire

Differential Revision: https://phabricator.haskell.org/D761

5 files changed, 94 insertions, 52 deletions

diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 8efd342b22..945678a859 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -136,7 +136,7 @@ buildDataCon :: FamInstEnvs
             -> [HsSrcBang]
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
-           -> [Name]                   -- Field labels
+           -> [FieldLabel]             -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext
            -> [(TyVar,Type)]           -- Equality spec
            -> ThetaType                -- Does not include the "stupid theta"
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 61ec33e56c..85210cd6f3 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -22,6 +22,7 @@ module IfaceSyn (
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
+        ifaceConDeclFields,
         ifaceDeclFingerprints,
 
         -- Free Names
@@ -39,8 +40,9 @@ import IfaceType
 import PprCore()            -- Printing DFunArgs
 import Demand
 import Class
+import FieldLabel
 import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
 import Name
 import CostCentre
 import Literal
@@ -64,6 +66,7 @@ import Lexeme (isLexSym)
 
 import Control.Monad
 import System.IO.Unsafe
+import Data.List (find)
 import Data.Maybe (isJust)
 
 infixl 3 &&&
@@ -187,10 +190,16 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
                                      -- See Note [Storing compatibility] in CoAxiom
 
 data IfaceConDecls
-  = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
-  | IfDataFamTyCon              -- Data family
-  | IfDataTyCon [IfaceConDecl]  -- Data type decls
-  | IfNewTyCon  IfaceConDecl    -- Newtype decls
+  = IfAbstractTyCon Bool                          -- c.f TyCon.AbstractTyCon
+  | IfDataFamTyCon                                -- Data family
+  | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
+  | IfNewTyCon  IfaceConDecl   Bool [FieldLabelString] -- Newtype decls
+
+-- For IfDataTyCon and IfNewTyCon we store:
+--  * the data constructor(s);
+--  * a boolean indicating whether DuplicateRecordFields was enabled
+--    at the definition site; and
+--  * a list of field labels.
 
 data IfaceConDecl
   = IfCon {
@@ -334,8 +343,18 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
 visibleIfConDecls IfDataFamTyCon       = []
-visibleIfConDecls (IfDataTyCon cs)     = cs
-visibleIfConDecls (IfNewTyCon c)       = [c]
+visibleIfConDecls (IfDataTyCon cs _ _) = cs
+visibleIfConDecls (IfNewTyCon c   _ _) = [c]
+
+ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
+ifaceConDeclFields x = case x of
+    IfAbstractTyCon {}              -> []
+    IfDataFamTyCon  {}              -> []
+    IfDataTyCon cons is_over labels -> map (help cons  is_over) labels
+    IfNewTyCon  con  is_over labels -> map (help [con] is_over) labels
+  where
+    help (dc:_) is_over lbl = mkFieldLabelOccs lbl (ifConOcc dc) is_over
+    help [] _ _ = error "ifaceConDeclFields: data type has no constructors!"
 
 ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
@@ -352,8 +371,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
 
 -- Newtype
 ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
-                              ifCons = IfNewTyCon (
-                                        IfCon { ifConOcc = con_occ })})
+                              ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
   =   -- implicit newtype coercion
     (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
       -- data constructor and worker (newtypes don't have a wrapper)
@@ -361,7 +379,7 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
 
 
 ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
-                              ifCons = IfDataTyCon cons })
+                              ifCons = IfDataTyCon cons _ _ })
   = -- for each data constructor in order,
     --    data constructor, worker, and (possibly) wrapper
     concatMap dc_occs cons
@@ -643,8 +661,9 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
 
     show_con dc
-      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc
+      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc
       | otherwise = Nothing
+    fls = ifaceConDeclFields condecls
 
     mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
     -- See Note [Result type of a data family GADT]
@@ -666,15 +685,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     pp_nd = case condecls of
               IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
               IfDataFamTyCon    -> ptext (sLit "data family")
-              IfDataTyCon _     -> ptext (sLit "data")
-              IfNewTyCon _      -> ptext (sLit "newtype")
+              IfDataTyCon{}     -> ptext (sLit "data")
+              IfNewTyCon{}      -> ptext (sLit "newtype")
 
     pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
 
     pp_prom | is_prom   = ptext (sLit "Promotable")
             | otherwise = Outputable.empty
 
-
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                             , ifCtxt   = context, ifName  = clas
                             , ifTyVars = tyvars,  ifRoles = roles
@@ -843,8 +861,9 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
 
 pprIfaceConDecl :: ShowSub -> Bool
                 -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
+                -> [FieldLbl OccName]
                 -> IfaceConDecl -> SDoc
-pprIfaceConDecl ss gadt_style mk_user_con_res_ty
+pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
         (IfCon { ifConOcc = name, ifConInfix = is_infix,
                  ifConExTvs = ex_tvs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
@@ -874,9 +893,14 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty
     pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
     pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty
 
-    maybe_show_label (lbl,bty)
-      | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
+    maybe_show_label (sel,bty)
+      | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
       | otherwise      = Nothing
+      where
+        -- IfaceConDecl contains the name of the selector function, so
+        -- we have to look up the field label (in case
+        -- DuplicateRecordFields was used for the definition)
+        lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
 
     ppr_fields [ty1, ty2]
       | is_infix && null labels
@@ -1164,9 +1188,9 @@ freeNamesIfClsSig :: IfaceClassOp -> NameSet
 freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
 
 freeNamesIfConDecls :: IfaceConDecls -> NameSet
-freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
-freeNamesIfConDecls (IfNewTyCon c)  = freeNamesIfConDecl c
-freeNamesIfConDecls _               = emptyNameSet
+freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon  c _ _) = freeNamesIfConDecl c
+freeNamesIfConDecls _                   = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
 freeNamesIfConDecl c
@@ -1548,16 +1572,16 @@ instance Binary IfaceAxBranch where
 
 instance Binary IfaceConDecls where
     put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
-    put_ bh IfDataFamTyCon     = putByte bh 1
-    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
-    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
+    put_ bh IfDataFamTyCon      = putByte bh 1
+    put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
+    put_ bh (IfNewTyCon c b fs)   = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
     get bh = do
         h <- getByte bh
         case h of
             0 -> liftM IfAbstractTyCon $ get bh
             1 -> return IfDataFamTyCon
-            2 -> liftM IfDataTyCon $ get bh
-            _ -> liftM IfNewTyCon $ get bh
+            2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
+            _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
 
 instance Binary IfaceConDecl where
     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 72bffea6af..cbf8048db2 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -68,6 +68,7 @@ import Util
 import FastString
 import Fingerprint
 import Hooks
+import FieldLabel
 
 import Control.Monad
 import Data.IORef
@@ -907,14 +908,14 @@ When printing export lists, we print like this:
 -}
 
 pprExport :: IfaceExport -> SDoc
-pprExport (Avail n)      = ppr n
-pprExport (AvailTC _ []) = Outputable.empty
-pprExport (AvailTC n (n':ns))
-  | n==n'     = ppr n <> pp_export ns
-  | otherwise = ppr n <> char '|' <> pp_export (n':ns)
+pprExport (Avail n)         = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n ns0 fs) = case ns0 of
+                                 (n':ns) | n==n' -> ppr n <> pp_export ns fs
+                                 _               -> ppr n <> char '|' <> pp_export ns0 fs
   where
-    pp_export []    = Outputable.empty
-    pp_export names = braces (hsep (map ppr names))
+    pp_export []    [] = Outputable.empty
+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
 
 pprUsage :: Usage -> SDoc
 pprUsage usage@UsagePackageModule{}
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 66790bc82f..66a885bb6d 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -106,6 +106,7 @@ import UniqFM
 import Unique
 import Util             hiding ( eqListBy )
 import FastString
+import FastStringEnv
 import Maybes
 import ListSetOps
 import Binary
@@ -1080,12 +1081,14 @@ mkIfaceExports exports
   where
     sort_subs :: AvailInfo -> AvailInfo
     sort_subs (Avail n) = Avail n
-    sort_subs (AvailTC n []) = AvailTC n []
-    sort_subs (AvailTC n (m:ms))
-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms)
-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+    sort_subs (AvailTC n (m:ms) fs)
+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
        -- Maintain the AvailTC Invariant
 
+    sort_flds = sortBy (stableNameCmp `on` flSelector)
+
 {-
 Note [Orignal module]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -1604,7 +1607,7 @@ tyConToIfaceDecl env tycon
                   ifTyVars  = if_tc_tyvars,
                   ifRoles   = tyConRoles tycon,
                   ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
-                  ifCons    = ifaceConDecls (algTyConRhs tycon),
+                  ifCons    = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
                   ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                   ifGadtSyntax = isGadtSyntaxTyCon tycon,
                   ifPromotable = isJust (promotableTyCon_maybe tycon),
@@ -1618,7 +1621,7 @@ tyConToIfaceDecl env tycon
                   ifTyVars     = funAndPrimTyVars,
                   ifRoles      = tyConRoles tycon,
                   ifCtxt       = [],
-                  ifCons       = IfDataTyCon [],
+                  ifCons       = IfDataTyCon [] False [],
                   ifRec        = boolToRecFlag False,
                   ifGadtSyntax = False,
                   ifPromotable = False,
@@ -1652,11 +1655,11 @@ tyConToIfaceDecl env tycon
       = IfaceBuiltInSynFamTyCon
 
 
-    ifaceConDecls (NewTyCon { data_con = con })     = IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls (DataFamilyTyCon {})              = IfDataFamTyCon
-    ifaceConDecls (TupleTyCon { data_con = con })   = IfDataTyCon [ifaceConDecl con]
-    ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
+    ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
+    ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
+    ifaceConDecls (DataFamilyTyCon {})             _    = IfDataFamTyCon
+    ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con] False []
+    ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The AbstractTyCon case happens when a TyCon has been trimmed
         -- during tidying.
         -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
@@ -1672,7 +1675,7 @@ tyConToIfaceDecl env tycon
                     ifConEqSpec  = map to_eq_spec eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
-                    ifConFields  = map getOccName
+                    ifConFields  = map (nameOccName . flSelector)
                                        (dataConFieldLabels data_con),
                     ifConStricts = map (toIfaceBang con_env2)
                                        (dataConImplBangs data_con),
@@ -1694,6 +1697,11 @@ tyConToIfaceDecl env tycon
           (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
+    ifaceOverloaded flds = case fsEnvElts flds of
+                             fl:_ -> flIsOverloaded fl
+                             []   -> False
+    ifaceFields flds = map flLabel $ fsEnvElts flds
+
 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
 toIfaceBang _    HsLazy              = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 5f91bad0e3..c833ab07a8 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -70,6 +70,7 @@ import DynFlags
 import Util
 import FastString
 
+import Data.List
 import Control.Monad
 import qualified Data.Map as Map
 #if __GLASGOW_HASKELL__ < 709
@@ -509,15 +510,17 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
         IfDataFamTyCon  -> return DataFamilyTyCon
-        IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
-                                ; return (mkDataTyConRhs data_cons) }
-        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
-                                ; mkNewTyConRhs tycon_name tycon data_con }
+        IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
+                                    ; data_cons  <- mapM (tc_con_decl field_lbls) cons
+                                    ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon  con  _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
+                                    ; data_con  <- tc_con_decl field_lbls con
+                                    ; mkNewTyConRhs tycon_name tycon data_con }
   where
-    tc_con_decl (IfCon { ifConInfix = is_infix,
+    tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
                          ifConExTvs = ex_tvs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
-                         ifConArgTys = args, ifConFields = field_lbls,
+                         ifConArgTys = args, ifConFields = my_lbls,
                          ifConStricts = if_stricts,
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
@@ -539,7 +542,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                         -- The IfBang field can mention
                         -- the type itself; hence inside forkM
                 ; return (eq_spec, theta, arg_tys, stricts) }
-        ; lbl_names <- mapM lookupIfaceTop field_lbls
+
+        -- Look up the field labels for this constructor; note that
+        -- they should be in the same order as my_lbls!
+        ; let lbl_names = map find_lbl my_lbls
+              find_lbl x = case find (\ fl -> nameOccName (flSelector fl) == x) field_lbls of
+                             Just fl -> fl
+                             Nothing -> error $ "find_lbl missing " ++ occNameString x
 
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon