summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs9
-rw-r--r--compiler/main/GHC.hs19
-rw-r--r--compiler/main/HscMain.hs16
-rw-r--r--compiler/main/HscTypes.lhs27
-rw-r--r--compiler/main/InteractiveEval.hs2
-rw-r--r--compiler/main/PprTyThing.hs12
-rw-r--r--compiler/main/TidyPgm.lhs12
7 files changed, 68 insertions, 29 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 72ebb38fc2..ec0b540012 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -581,6 +581,7 @@ data ExtensionFlag
| Opt_LambdaCase
| Opt_MultiWayIf
| Opt_NegativeLiterals
+ | Opt_OverloadedRecordFields
| Opt_EmptyCase
| Opt_PatternSynonyms
deriving (Eq, Enum, Show)
@@ -2877,6 +2878,7 @@ xFlags = [
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "PackageImports", Opt_PackageImports, nop ),
( "NegativeLiterals", Opt_NegativeLiterals, nop ),
+ ( "OverloadedRecordFields", Opt_OverloadedRecordFields, nop ),
( "EmptyCase", Opt_EmptyCase, nop ),
( "PatternSynonyms", Opt_PatternSynonyms, nop )
]
@@ -2960,6 +2962,13 @@ impliedFlags
, (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances)
, (Opt_JavaScriptFFI, turnOn, Opt_InterruptibleFFI)
+
+ -- 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)
]
optLevelFlags :: [([Int], GeneralFlag)]
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 7694bc9821..e263ef4030 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -68,6 +68,7 @@ module GHC (
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
+ modInfoExportsWithSelectors,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
@@ -152,7 +153,7 @@ module GHC (
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
- recordSelectorFieldLabel,
+ recordSelectorTyCon,
-- ** Type constructors
TyCon,
@@ -826,7 +827,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,
@@ -1054,7 +1055,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,
@@ -1090,14 +1091,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,
@@ -1119,7 +1119,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,
@@ -1138,7 +1138,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.
@@ -1146,7 +1149,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 748f7480ec..4411d230f6 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -111,10 +111,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
@@ -1401,6 +1401,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
@@ -1440,19 +1441,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)
@@ -1562,6 +1567,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 6fcf8e24a7..5f5c0258df 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1000,6 +1000,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
@@ -1193,12 +1196,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]
@@ -1247,6 +1253,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
@@ -1290,6 +1301,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
@@ -1606,12 +1618,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 ede519982a..85a1d8eece 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -56,6 +56,7 @@ import Name hiding ( varName )
import NameSet
import Avail
import RdrName
+import TcRnMonad
import VarSet
import VarEnv
import ByteCodeInstr
@@ -73,7 +74,6 @@ import BreakArray
import RtClosureInspect
import Outputable
import FastString
-import MonadUtils
import System.Mem.Weak
import System.Directory
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 1fd5d0cbcf..2fa4783063 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -228,7 +228,7 @@ pprAlgTyCon ss tyCon
datacons = tyConDataCons tyCon
gadt = any (not . isVanillaDataCon) datacons
- ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
+ ok_con dc = showSub ss dc || any (showSub ss . flSelector) (dataConFieldLabels dc)
show_con dc
| ok_con dc = Just (pprDataConDecl ss gadt dc)
| otherwise = Nothing
@@ -262,9 +262,10 @@ pprDataConDecl ss gadt_style dataCon
user_ify (HsUnpack {}) = HsUserBang (Just True) True
user_ify bang = bang
- maybe_show_label (lbl,bty)
- | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty)
- | otherwise = Nothing
+ maybe_show_label (fl, bty)
+ | showSub ss (flSelector fl)
+ = Just (ppr_bndr_occ (mkVarOccFS (flLabel fl)) <+> dcolon <+> pprBangTy bty)
+ | otherwise = Nothing
ppr_fields [ty1, ty2]
| dataConIsInfix dataCon && null labels
@@ -331,6 +332,9 @@ add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
ppr_bndr :: NamedThing a => a -> SDoc
ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a))
+ppr_bndr_occ :: OccName -> SDoc
+ppr_bndr_occ a = parenSymOcc a (ppr a)
+
showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b20658b073..d4c13a9b08 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -130,7 +130,8 @@ mkBootModDetailsTc hsc_env
tcg_type_env = type_env, -- just for the Ids
tcg_tcs = tcs,
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
@@ -139,10 +140,11 @@ mkBootModDetailsTc hsc_env
; dfun_ids = map instanceDFunId insts'
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
(typeEnvIds type_env) tcs fam_insts
- ; type_env2 = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
- ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids
+ ; type_env2 = extendTypeEnvList type_env1 (map ACoAxiom axioms)
+ ; type_env3 = extendTypeEnvWithPatSyns type_env2 (typeEnvPatSyns type_env)
+ ; type_env4 = extendTypeEnvWithIds type_env3 dfun_ids
}
- ; return (ModDetails { md_types = type_env'
+ ; return (ModDetails { md_types = type_env4
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
@@ -296,6 +298,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
@@ -314,6 +317,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) ++
View Lorry Controller Status