ghc: implement OverloadedRecordFieldswip/orf-new

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.

6 files changed, 60 insertions, 24 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 7ae04ee1ea..5abb30213c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -587,6 +587,7 @@ data ExtensionFlag
    | Opt_MultiWayIf
    | Opt_BinaryLiterals
    | Opt_NegativeLiterals
+   | Opt_OverloadedRecordFields
    | Opt_EmptyCase
    | Opt_PatternSynonyms
    deriving (Eq, Enum, Show)
@@ -2915,6 +2916,7 @@ xFlags = [
   ( "PackageImports",                   Opt_PackageImports, nop ),
   ( "BinaryLiterals",                   Opt_BinaryLiterals, nop ),
   ( "NegativeLiterals",                 Opt_NegativeLiterals, nop ),
+  ( "OverloadedRecordFields",           Opt_OverloadedRecordFields, nop ),
   ( "EmptyCase",                        Opt_EmptyCase, nop ),
   ( "PatternSynonyms",                  Opt_PatternSynonyms, nop )
   ]
@@ -3001,6 +3003,14 @@ impliedFlags
 
     , (Opt_DeriveTraversable, turnOn, Opt_DeriveFunctor)
     , (Opt_DeriveTraversable, turnOn, Opt_DeriveFoldable)
+
+    -- Overloaded record fields require field disambiguation (well
+    -- duh), and flexible contexts and constraint kinds (for the Has
+    -- class encoding and desugaring of r { f :: t } syntax).
+    , (Opt_OverloadedRecordFields, turnOn, Opt_DisambiguateRecordFields)
+    , (Opt_OverloadedRecordFields, turnOn, Opt_FlexibleContexts)
+    , (Opt_OverloadedRecordFields, turnOn, Opt_ConstraintKinds)
+    , (Opt_OverloadedRecordFields, turnOn, Opt_DataKinds)
   ]
 
 optLevelFlags :: [([Int], GeneralFlag)]
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 9ab52ebf1d..50f85fe2c9 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -69,6 +69,7 @@ module GHC (
         modInfoTyThings,
         modInfoTopLevelScope,
         modInfoExports,
+        modInfoExportsWithSelectors,
         modInfoInstances,
         modInfoIsExportedName,
         modInfoLookupName,
@@ -153,7 +154,7 @@ module GHC (
         isPrimOpId, isFCallId, isClassOpId_maybe,
         isDataConWorkId, idDataCon,
         isBottomingId, isDictonaryId,
-        recordSelectorFieldLabel,
+        recordSelectorTyCon,
 
         -- ** Type constructors
         TyCon, 
@@ -828,7 +829,7 @@ typecheckModule pmod = do
        tm_checked_module_info =
          ModuleInfo {
            minf_type_env  = md_types details,
-           minf_exports   = availsToNameSet $ md_exports details,
+           minf_exports   = md_exports details,
            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
            minf_instances = md_insts details,
            minf_iface     = Nothing,
@@ -1019,7 +1020,7 @@ getPrintUnqual = withSession $ \hsc_env ->
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
         minf_type_env  :: TypeEnv,
-        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
+        minf_exports   :: [AvailInfo],
         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
         minf_instances :: [ClsInst],
         minf_iface     :: Maybe ModIface,
@@ -1055,14 +1056,13 @@ getPackageModuleInfo hsc_env mdl
         iface <- hscGetModuleInterface hsc_env mdl
         let 
             avails = mi_exports iface
-            names  = availsToNameSet avails
             pte    = eps_PTE eps
             tys    = [ ty | name <- concatMap availNames avails,
                             Just ty <- [lookupTypeEnv pte name] ]
         --
         return (Just (ModuleInfo {
                         minf_type_env  = mkTypeEnv tys,
-                        minf_exports   = names,
+                        minf_exports   = avails,
                         minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
                         minf_instances = error "getModuleInfo: instances for package module unimplemented",
                         minf_iface     = Just iface,
@@ -1084,7 +1084,7 @@ getHomeModuleInfo hsc_env mdl =
           iface   = hm_iface hmi
       return (Just (ModuleInfo {
                         minf_type_env  = md_types details,
-                        minf_exports   = availsToNameSet (md_exports details),
+                        minf_exports   = md_exports details,
                         minf_rdr_env   = mi_globals $! hm_iface hmi,
                         minf_instances = md_insts details,
                         minf_iface     = Just iface,
@@ -1103,7 +1103,10 @@ modInfoTopLevelScope minf
   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
 
 modInfoExports :: ModuleInfo -> [Name]
-modInfoExports minf = nameSetToList $! minf_exports minf
+modInfoExports minf = concatMap availNames $! minf_exports minf
+
+modInfoExportsWithSelectors :: ModuleInfo -> [Name]
+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
 
 -- | Returns the instances defined by the specified module.
 -- Warning: currently unimplemented for package modules.
@@ -1111,7 +1114,7 @@ modInfoInstances :: ModuleInfo -> [ClsInst]
 modInfoInstances = minf_instances
 
 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
-modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
 
 mkPrintUnqualifiedForModule :: GhcMonad m =>
                                ModuleInfo
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 15d67fc882..6acb8b3013 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -113,10 +113,10 @@ import SrcLoc
 import TcRnDriver
 import TcIface          ( typecheckIface )
 import TcRnMonad
-import IfaceEnv         ( initNameCache )
 import LoadIface        ( ifaceStats, initExternalPackageState )
 import PrelInfo
 import MkIface
+import IfaceEnv
 import Desugar
 import SimplCore
 import TidyPgm
@@ -1410,6 +1410,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     -- (ic_instances) for more details.
     let finsts = tcg_fam_insts tc_gblenv
         insts  = tcg_insts     tc_gblenv
+        axioms = tcg_axioms    tc_gblenv
 
     let defaults = tcg_default tc_gblenv
 
@@ -1449,19 +1450,23 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
 
         ext_ids = [ id | id <- bindersOfBinds core_binds
                        , isExternalName (idName id)
-                       , not (isDFunId id || isImplicitId id) ]
+                       , not (isInstDFunId id || isImplicitId id) ]
             -- We only need to keep around the external bindings
             -- (as decided by TidyPgm), since those are the only ones
             -- that might be referenced elsewhere.
-            -- The DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
+            -- Most DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
             -- Implicit Ids are implicit in tcs
 
+        isInstDFunId id = isDFunId id && id `elem` map is_dfun insts
+
         tythings =  map AnId ext_ids ++ map ATyCon tcs
+                 ++ map ACoAxiom axioms
 
     let icontext = hsc_IC hsc_env
         ictxt1   = extendInteractiveContext icontext tythings
-        ictxt    = ictxt1 { ic_instances = (insts, finsts)
-                          , ic_default   = defaults }
+        ictxt    = ictxt1 { ic_instances = (insts, finsts),
+                            ic_axioms    = axioms,
+                            ic_default   = defaults }
 
     return (tythings, ictxt)
 
@@ -1571,6 +1576,7 @@ mkModGuts mod safe binds =
         mg_tcs          = [],
         mg_insts        = [],
         mg_fam_insts    = [],
+        mg_axioms       = [],
         mg_patsyns      = [],
         mg_rules        = [],
         mg_vect_decls   = [],
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 123b0777fc..9a5ad1f0a9 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1003,6 +1003,9 @@ data ModGuts
         mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module
         mg_fam_insts :: ![FamInst],
                                          -- ^ Family instances declared in this module
+        mg_axioms    :: ![CoAxiom Branched],
+                                         -- ^ Axioms without family instances
+                                         -- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
         mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains
                                          -- See Note [Overall plumbing for rules] in Rules.lhs
@@ -1197,12 +1200,15 @@ The ic_tythings field contains
     *don't* come from 'implicitTyThings', notably:
        - record selectors
        - class ops
+       - DFunIds for OverloadedRecordFields classes
     The implicitTyThings are readily obtained from the TyThings
     but record selectors etc are not
 
 It does *not* contain
-  * DFunIds (they can be gotten from ic_instances)
-  * CoAxioms (ditto)
+  * CoAxioms (they can be gotten from ic_instances)
+  * DFunIds (ditto), except for OverloadedRecordFields classes
+    (see Note [Instance scoping for OverloadedRecordFields] in TcFldInsts)
+
 
 See also Note [Interactively-bound Ids in GHCi]
 
@@ -1251,6 +1257,11 @@ data InteractiveContext
              -- time we update the context, we just take the results
              -- from the instance code that already does that.
 
+         ic_axioms     :: [CoAxiom Branched],
+             -- ^ Axioms created during this session without a type family
+             -- (see Note [Instance scoping for OverloadedRecordFields]
+             -- in TcFldInsts).
+
          ic_fix_env :: FixityEnv,
             -- ^ Fixities declared in let statements
 
@@ -1294,6 +1305,7 @@ emptyInteractiveContext dflags
        ic_mod_index  = 1,
        ic_tythings   = [],
        ic_instances  = ([],[]),
+       ic_axioms     = [],
        ic_fix_env    = emptyNameEnv,
        ic_monad      = ioTyConName,  -- IO monad by default
        ic_int_print  = printName,    -- System.IO.print by default
@@ -1659,12 +1671,13 @@ tyThingAvailInfo :: TyThing -> AvailInfo
 tyThingAvailInfo (ATyCon t)
    = case tyConClass_maybe t of
         Just c  -> AvailTC n (n : map getName (classMethods c)
-                  ++ map getName (classATs c))
+                                 ++ map getName (classATs c))
+                             []
              where n = getName c
-        Nothing -> AvailTC n (n : map getName dcs ++
-                                   concatMap dataConFieldLabels dcs)
-             where n = getName t
-                   dcs = tyConDataCons t
+        Nothing -> AvailTC n (n : map getName dcs) (fieldLabelsToAvailFields flds)
+             where n    = getName t
+                   dcs  = tyConDataCons t
+                   flds = tyConFieldLabels t
 tyThingAvailInfo t
    = Avail (getName t)
 \end{code}
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index f25ed75b48..37beb2f4c7 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -58,6 +58,7 @@ import Name             hiding ( varName )
 import NameSet
 import Avail
 import RdrName
+import TcRnMonad
 import VarSet
 import VarEnv
 import ByteCodeInstr
@@ -75,7 +76,6 @@ import BreakArray
 import RtClosureInspect
 import Outputable
 import FastString
-import MonadUtils
 
 import System.Mem.Weak
 import System.Directory
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 55efca1c8c..385afac8d4 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -135,7 +135,8 @@ mkBootModDetailsTc hsc_env
                   tcg_tcs       = tcs,
                   tcg_patsyns   = pat_syns,
                   tcg_insts     = insts,
-                  tcg_fam_insts = fam_insts
+                  tcg_fam_insts = fam_insts,
+                  tcg_axioms    = axioms
                 }
   = do  { let dflags = hsc_dflags hsc_env
         ; showPass dflags CoreTidy
@@ -146,9 +147,10 @@ mkBootModDetailsTc hsc_env
               ; pat_syns'   = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
               ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1
               ; dfun_ids    = map instanceDFunId insts'
-              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
+              ; type_env3  = extendTypeEnvWithIds type_env2 dfun_ids
+              ; type_env4  = extendTypeEnvList type_env3 (map ACoAxiom axioms)
               }
-        ; return (ModDetails { md_types     = type_env'
+        ; return (ModDetails { md_types     = type_env4
                              , md_insts     = insts'
                              , md_fam_insts = fam_insts
                              , md_rules     = []
@@ -302,6 +304,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_tcs       = tcs
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
+                              , mg_axioms    = axioms
                               , mg_binds     = binds
                               , mg_patsyns   = patsyns
                               , mg_rules     = imp_rules
@@ -320,6 +323,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; showPass dflags CoreTidy
 
         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
+                               `extendTypeEnvList` map ACoAxiom axioms
 
               ; implicit_binds
                   = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++