diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DynFlags.hs | 10 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 19 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 16 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 27 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 2 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 10 |
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) ++ |