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>

5 files changed, 79 insertions, 57 deletions

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e412d7ef30..170edfe591 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -129,7 +129,7 @@ mkNewTyConRhs tycon_name tycon con
 buildDataCon :: FamInstEnvs 
             -> Name -> Bool
 	    -> [HsBang] 
-	    -> [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.lhs b/compiler/iface/IfaceSyn.lhs
index 1283b095fd..853fafc0ed 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -40,8 +40,10 @@ import IfaceType
 import PprCore()            -- Printing DFunArgs
 import Demand
 import Class
+import TyCon
+import FieldLabel
 import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
 import Name
 import CostCentre
 import Literal
@@ -356,29 +358,29 @@ instance Binary IfaceAxBranch where
         return (IfaceAxBranch a1 a2 a3 a4 a5)
 
 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] [FieldLbl OccName] -- Data type decls
+  | IfNewTyCon  IfaceConDecl   [FieldLbl OccName] -- Newtype decls
 
 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 fs) = putByte bh 2 >> put_ bh cs >> put_ bh fs
+    put_ bh (IfNewTyCon c fs)   = putByte bh 3 >> put_ bh c >> 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 -> liftM2 IfDataTyCon (get bh) (get bh)
+            _ -> liftM2 IfNewTyCon (get bh) (get bh)
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfDataFamTyCon      = []
-visibleIfConDecls (IfDataTyCon cs)     = cs
-visibleIfConDecls (IfNewTyCon c)       = [c]
+visibleIfConDecls IfDataFamTyCon       = []
+visibleIfConDecls (IfDataTyCon cs _)   = cs
+visibleIfConDecls (IfNewTyCon c _)     = [c]
 
 data IfaceConDecl
   = IfCon {
@@ -390,7 +392,7 @@ data IfaceConDecl
         ifConEqSpec  :: [(OccName,IfaceType)],  -- Equality constraints
         ifConCtxt    :: IfaceContext,           -- Non-stupid context
         ifConArgTys  :: [IfaceType],            -- Arg types
-        ifConFields  :: [OccName],              -- ...ditto... (field labels)
+        ifConFields  :: [OccName],              -- Field labels
         ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
                                                 -- or 1-1 corresp with arg tys
 
@@ -969,7 +971,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
 -- Newtype
 ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
                               ifCons = IfNewTyCon (
-                                        IfCon { ifConOcc = con_occ })})
+                                        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)
@@ -977,7 +979,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
@@ -1086,9 +1088,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
             | otherwise = ptext (sLit "Not promotable")
     pp_nd = case condecls of
                 IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
-                IfDataFamTyCon     -> ptext (sLit "data family")
-                IfDataTyCon _       -> ptext (sLit "data")
-                IfNewTyCon _        -> ptext (sLit "newtype")
+                IfDataFamTyCon      -> ptext (sLit "data family")
+                IfDataTyCon _ _     -> ptext (sLit "data")
+                IfNewTyCon _ _      -> ptext (sLit "newtype")
 
 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
                           ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
@@ -1153,9 +1155,9 @@ pprIfaceDeclHead context thing tyvars
 
 pp_condecls :: OccName -> IfaceConDecls -> SDoc
 pp_condecls _  (IfAbstractTyCon {}) = empty
-pp_condecls _  IfDataFamTyCon      = empty
-pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
+pp_condecls _  IfDataFamTyCon       = empty
+pp_condecls tc (IfNewTyCon c _)     = equals <+> pprIfaceConDecl tc c
+pp_condecls tc (IfDataTyCon cs _)   = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
 mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
@@ -1430,9 +1432,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 =
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index d787794326..6ac7dde010 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -772,14 +772,17 @@ When printing export lists, we print like this:
 
 \begin{code}
 pprExport :: IfaceExport -> SDoc
-pprExport (Avail n)      = ppr n
-pprExport (AvailTC _ []) = empty
-pprExport (AvailTC n (n':ns)) 
-  | n==n'     = ppr n <> pp_export ns
-  | otherwise = ppr n <> char '|' <> pp_export (n':ns)
-  where  
-    pp_export []    = empty
-    pp_export names = braces (hsep (map ppr names))
+pprExport (Avail n)         = ppr n
+pprExport (AvailTC _ [] []) = empty
+pprExport (AvailTC n (n':ns) fs)
+  | n==n'     = ppr n <> pp_export ns fs
+  | otherwise = ppr n <> char '|' <> pp_export (n':ns) fs
+pprExport (AvailTC n [] fs) = ppr n <> char '|' <> pp_export [] fs
+
+pp_export :: [Name] -> AvailFields -> SDoc
+pp_export []    [] = empty
+pp_export names fs = braces (hsep (map ppr names ++ map pprAvailField fs))
+
 
 pprUsage :: Usage -> SDoc
 pprUsage usage@UsagePackageModule{}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index bb51cdae9d..93386e5c04 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -104,6 +104,7 @@ import UniqFM
 import Unique
 import Util             hiding ( eqListBy )
 import FastString
+import FastStringEnv
 import Maybes
 import ListSetOps
 import Binary
@@ -1069,11 +1070,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 :: AvailFields -> AvailFields
+    sort_flds = sortBy (stableNameCmp `on` fst)
 \end{code}
 
 Note [Orignal module]
@@ -1572,7 +1576,7 @@ tyConToIfaceDecl env tycon
                 ifTyVars  = toIfaceTvBndrs tyvars,
                 ifRoles   = tyConRoles tycon,
                 ifCtxt    = tidyToIfaceContext 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),
@@ -1596,10 +1600,10 @@ tyConToIfaceDecl env tycon
     to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
 
 
-    ifaceConDecls (NewTyCon { data_con = con })     = IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls (DataFamilyTyCon {})              = IfDataFamTyCon
-    ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
+    ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceFields flds)
+    ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceFields flds)
+    ifaceConDecls (DataFamilyTyCon {})             _    = IfDataFamTyCon
+    ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The last case happens when a TyCon has been trimmed during tidying
         -- Furthermore, tyThingToIfaceDecl is also used
         -- in TcRnDriver for GHCi, when browsing a module, in which case the
@@ -1614,8 +1618,7 @@ tyConToIfaceDecl env tycon
                     ifConEqSpec  = to_eq_spec eq_spec,
                     ifConCtxt    = tidyToIfaceContext env2 theta,
                     ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
-                    ifConFields  = map getOccName
-                                       (dataConFieldLabels data_con),
+                    ifConFields  = map (nameOccName . flSelector) (dataConFieldLabels data_con),
                     ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
@@ -1627,6 +1630,8 @@ tyConToIfaceDecl env tycon
           to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
                             | (tv,ty) <- spec]
 
+    ifaceFields flds = map (fmap nameOccName) $ fsEnvElts flds
+
 toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cc45648ea2..9c1e6701b6 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -69,9 +69,10 @@ import DynFlags
 import Util
 import FastString
 
+import Data.List
+import Data.Traversable (traverse)
 import Control.Monad
 import qualified Data.Map as Map
-import Data.Traversable ( traverse )
 \end{code}
 
 This module takes
@@ -632,16 +633,21 @@ tcIfaceDataCons tycon_name tycon _ 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 fs -> do  { field_lbls <- mapM tc_field_lbl fs
+                                   ; data_cons <- mapM (tc_con_decl field_lbls) cons
+                                   ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon con   fs -> do  { field_lbls <- mapM tc_field_lbl fs
+                                   ; data_con <- (tc_con_decl field_lbls) con
+                                   ; mkNewTyConRhs tycon_name tycon data_con }
   where
-    tc_con_decl (IfCon { ifConInfix = is_infix,
-                         ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
-                         ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
-                         ifConArgTys = args, ifConFields = field_lbls,
-                         ifConStricts = if_stricts})
+    tc_field_lbl :: FieldLbl OccName -> IfL FieldLabel
+    tc_field_lbl = traverse lookupIfaceTop
+
+    tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
+                                    ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+                                    ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
+                                    ifConArgTys = args, ifConFields = my_lbls,
+                                    ifConStricts = if_stricts})
      = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
@@ -660,7 +666,13 @@ tcIfaceDataCons tycon_name tycon _ 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 my_field_lbls = 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
@@ -668,7 +680,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
 
         ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
                        name is_infix
-                       stricts lbl_names
+                       stricts my_field_lbls
                        univ_tyvars ex_tyvars
                        eq_spec theta
                        arg_tys orig_res_ty tycon