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>

7 files changed, 23 insertions, 18 deletions

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index c0fe9c03e3..fb63a95c53 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -755,9 +755,9 @@ tidy_con con (RecCon (HsRecFields fs _))
 
      -- pad out all the missing fields with WildPats.
     field_pats = case con of
-        RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc)
+        RealDataCon dc -> map (\ f -> (flSelector f, nlWildPat)) (dataConFieldLabels dc)
         PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"
-    all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
+    all_pats = foldr (\ x acc -> insertNm (getName (unLoc (hsRecFieldId x))) (hsRecFieldArg x) acc)
                      field_pats fs
 
     insertNm nm p [] = [(nm,p)]
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 6bdc61d9c2..58b3d30c80 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -889,9 +889,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
   = do  { fields' <- mapM process fields
         ; return (HsRecFields fields' dd) }
   where
-    process (HsRecField ids expr doc)
+    process (HsRecField lbl sel expr doc)
         = do { expr' <- addTickLHsExpr expr
-             ; return (HsRecField ids expr' doc) }
+             ; return (HsRecField lbl sel expr' doc) }
 
 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 addTickArithSeqInfo (From e1) =
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index cd75de9a3a..4c7857ce3c 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -91,6 +91,7 @@ deSugar hsc_env
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
+                            tcg_axioms       = axioms,
                             tcg_hpc          = other_hpc_info })
 
   = do { let dflags = hsc_dflags hsc_env
@@ -185,6 +186,7 @@ deSugar hsc_env
                 mg_tcs          = tcs,
                 mg_insts        = insts,
                 mg_fam_insts    = fam_insts,
+                mg_axioms       = axioms,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
                 mg_patsyns      = map snd . filter (isExportedId . fst) $ final_patsyns,
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 859309d592..4bd482800a 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -20,6 +20,7 @@ import DsArrows
 import DsMonad
 import Name
 import NameEnv
+import RdrName
 import FamInstEnv( topNormaliseType )
 
 #ifdef GHCI
@@ -419,11 +420,11 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
         -- A newtype in the corner should be opaque; 
         -- hence TcType.tcSplitFunTys
 
-        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
-          = case findField (rec_flds rbinds) lbl of
+        mk_arg (arg_ty, fl)
+          = case findField (rec_flds rbinds) (flLabel fl) of
               (rhs:rhss) -> ASSERT( null rhss )
                             dsLExpr rhs
-              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
+              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
 
         labels = dataConFieldLabels (idDataCon data_con_id)
@@ -523,8 +524,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                          (dataConFieldLabels con) arg_ids
-                 mk_val_arg field_name pat_arg_id 
-                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
+                 mk_val_arg fl pat_arg_id
+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
                         -- Reconstruct with the WrapId so that unpacking happens
                  wrap = mkWpEvVarApps theta_vars          <.>
@@ -609,12 +610,13 @@ dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
 dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
 dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
+dsExpr (HsOverloadedRecFld {}) = panic "dsExpr: HsOverloadedRecFld"
+dsExpr (HsSingleRecFld     {}) = panic "dsExpr: HsOverloadedRecFld"
 
 
-findField :: [HsRecField Id arg] -> Name -> [arg]
-findField rbinds lbl 
-  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
-         , lbl == idName (unLoc id) ]
+findField :: [HsRecField Id arg] -> FieldLabelString -> [arg]
+findField rbinds lbl
+  = [hsRecFieldArg x | x <- rbinds, occNameFS (rdrNameOcc (unLoc (hsRecFieldLbl x))) == lbl]
 \end{code}
 
 %--------------------------------------------------------------------
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 73c1adfdc8..bdfd015bee 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -61,8 +61,8 @@ import DynFlags
 import FastString
 import ForeignCall
 import Util
+import Maybes
 
-import Data.Maybe
 import Control.Monad
 import Data.List
 
@@ -112,7 +112,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
  = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
-            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
+            ; bndrs = tv_bndrs ++ fst (hsGroupBinders group) } ;
         ss <- mkGenSyms bndrs ;
 
         -- Bind all the names mainly to avoid repeated use of explicit strings.
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index b590f4b2d2..cd58f10ceb 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -45,6 +45,7 @@ import TcIface
 import LoadIface
 import Finder
 import PrelNames
+import RnNames
 import RdrName
 import HscTypes
 import Bag
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 2b51638bf3..746adeb941 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -144,7 +144,7 @@ matchOneConLike vars ty (eqn1 : eqns)	-- All eqns for a single constructor
 	        pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
 	      = firstPat eqn1
     fields1 = case con1 of
-        RealDataCon dcon1 -> dataConFieldLabels dcon1
+	RealDataCon dcon1 -> map flSelector $ dataConFieldLabels dcon1
 	PatSynCon{} -> []
 
     arg_tys  = inst inst_tys
@@ -211,8 +211,8 @@ compatible_pats _                 _                 = True -- Prefix or infix co
 
 same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
 same_fields flds1 flds2 
-  = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
-	 (rec_flds flds1) (rec_flds flds2)
+  = all2 (\f1 f2 -> hsRecFieldSel f1 == hsRecFieldSel f2)
+         (rec_flds flds1) (rec_flds flds2)
 
 
 -----------------