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>

1 files changed, 24 insertions, 12 deletions

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