#endif
-import CmdLineOpts ( opt_TyConPruning )
+import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls, opt_PprUserLength )
import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..),
HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..),
- FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo,
- IE(..), NewOrData(..), hsDeclName
+ FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), HsIdInfo,
+ IE(..), hsDeclName
)
import HsPragmas ( noGenPragmas )
+import BasicTypes ( SYN_IE(Version), NewOrData(..) )
import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
RdrName, rdrNameOcc
)
fmToList, eltsFM
)
import Name ( Name {-instance NamedThing-}, Provenance, OccName(..),
- modAndOcc, occNameString, moduleString, pprModule, isLocallyDefined,
+ nameModule, occNameString, moduleString, pprModule, isLocallyDefined,
NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
- minusNameSet, mkNameSet, elemNameSet, nameUnique,
+ minusNameSet, mkNameSet, elemNameSet, nameUnique, addOneToNameSet,
isWiredInName, maybeWiredInTyConName, maybeWiredInIdName,
NamedThing(..)
)
-import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon )
+import Id ( GenId, Id(..), idType, dataConTyCon, isAlgCon )
import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type ( namesOfType )
import TyVar ( GenTyVar )
import Maybes ( MaybeErr(..), expectJust, maybeToBool )
import ListSetOps ( unionLists )
import Pretty
-import PprStyle ( PprStyle(..) )
+import Outputable ( PprStyle(..) )
import Unique ( Unique )
import Util ( pprPanic, pprTrace, Ord3(..) )
import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer )
import Outputable
+#if __GLASGOW_HASKELL__ >= 202
+import List (nub)
+#endif
\end{code}
getRnStats all_decls
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
n_mods = sizeFM mod_vers_map
decls_imported = filter is_imported_decl all_decls
loadInterface doc_str load_mod
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_vers_map export_envs decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
if maybeToBool (lookupFM export_envs load_mod)
new_export_envs = addToFM export_envs load_mod ([],[])
new_ifaces = Ifaces this_mod mod_vers_map
new_export_envs
- decls all_names imp_names insts deferred_data_decls inst_mods
+ decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
(addToFM export_envs load_mod export_env)
new_decls
all_names imp_names
- new_insts
+ (new_insts, tycls_names)
deferred_data_decls
new_inst_mods
in
in
-- We find the gates by renaming the instance type with in a
-- and returning the occurrence pool.
- initRnMS emptyRnEnv mod_name InterfaceMode (
+ initRnMS emptyRnEnv mod_name (InterfaceMode Compulsory) (
findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)
) `thenRn` \ gate_names ->
returnRn (((mod_name, decl), gate_names) `consBag` insts)
importDecl name necessity
= checkSlurped name `thenRn` \ already_slurped ->
if already_slurped then
- -- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
+ traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
returnRn Nothing -- Already dealt with
else
if isWiredInName name then
- getWiredInDecl name
+ getWiredInDecl name necessity
else
getIfacesRn `thenRn` \ ifaces ->
let
Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
- (mod,_) = modAndOcc name
+ mod = nameModule name
in
if mod == this_mod then -- Don't bring in decls from
pprTrace "importDecl wierdness:" (ppr PprDebug name) $
-- Special case for data/newtype type declarations
Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
-> getNonWiredDataDecl needed_name version avail ty_decl `thenRn` \ (avail', maybe_decl) ->
- recordSlurp (Just version) avail' `thenRn_`
+ recordSlurp (Just version) necessity avail' `thenRn_`
returnRn maybe_decl
Just (version,avail,decl)
- -> recordSlurp (Just version) avail `thenRn_`
+ -> recordSlurp (Just version) necessity avail `thenRn_`
returnRn (Just decl)
Nothing -> -- Can happen legitimately for "Optional" occurrences
returnRn Nothing
where
doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name]
- (mod,_) = modAndOcc needed_name
+ mod = nameModule needed_name
is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
is_data_or_newtype other = False
that we know just what instances to bring into scope.
\begin{code}
-getWiredInDecl name
- = get_wired `thenRn` \ avail ->
- recordSlurp Nothing avail `thenRn_`
+getWiredInDecl name necessity
+ = initRnMS emptyRnEnv mod_name (InterfaceMode necessity)
+ get_wired `thenRn` \ avail ->
+ recordSlurp Nothing necessity avail `thenRn_`
-- Force in the home module in case it has instance decls for
-- the thing we are interested in.
let
main_name = availName avail
main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
- (mod,_) = modAndOcc main_name
+ mod = nameModule main_name
doc_str = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
in
(if not main_is_tc || mod == gHC__ then
get_wired | is_tycon -- ... a type constructor
= get_wired_tycon the_tycon
- | (isDataCon the_id) -- ... a wired-in data constructor
+ | (isAlgCon the_id) -- ... a wired-in data constructor
= get_wired_tycon (dataConTyCon the_id)
| otherwise -- ... a wired-in non data-constructor
= get_wired_id the_id
+ mod_name = nameModule name
maybe_wired_in_tycon = maybeWiredInTyConName name
is_tycon = maybeToBool maybe_wired_in_tycon
maybe_wired_in_id = maybeWiredInIdName name
avail@(AvailTC tycon_name _)
ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
| needed_name == tycon_name
- && opt_TyConPruning
+ && opt_PruneTyDecls
&& not (nameUnique needed_name `elem` cCallishTyKeys) -- Hack! Don't prune these tycons whose constructors
-- the desugarer must be able to see when desugaring
-- a CCall. Ugh!
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
-- An instance decl is ungated if all its gates have been slurped
select_ungated :: IfaceInst -- A gated inst decl
| otherwise
= (ungated_decls, (decl, remaining_gates) : gated_decls)
where
- remaining_gates = filter (not . (`elemNameSet` slurped_names)) gates
+ remaining_gates = filter (not . (`elemNameSet` tycls_names)) gates
(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
- (listToBag still_gated_insts)
+ ((listToBag still_gated_insts), tycls_names)
+ -- NB: don't throw away tycls_names; we may comre across more instance decls
deferred_data_decls
inst_mods
in
+ traceRn (sep [text "getInstDecls:", fsep (map (ppr PprDebug) (nameSetToList tycls_names))]) `thenRn_`
setIfacesRn new_ifaces `thenRn_`
returnRn un_gated_insts
where
add_mv mv_map v@(name, version)
= addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v]
where
- (mod,_) = modAndOcc name
+ mod = nameModule name
add_mod mv_map mod = addToFM mv_map mod []
\end{code}
in
returnRn slurped_names
-recordSlurp maybe_version avail
- = -- traceRn (sep [text "Record slurp:", pprAvail PprDebug avail]) `thenRn_`
+recordSlurp maybe_version necessity avail
+ = traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
+ -- NB PprForDebug prints export flag, which is too
+ -- strict; it's a knot-tied thing in RnNames
+ case necessity of {Compulsory -> text "comp"; Optional -> text "opt"}]) `thenRn_`
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
new_slurped_names = addAvailToNameSet slurped_names avail
new_imp_names = case maybe_version of
- Just version -> (availName avail, version) : imp_names
+ Just version -> (availName avail, version) : imp_names
Nothing -> imp_names
+ -- Add to the names that will let in instance declarations;
+ -- but only (a) if it's a type/class
+ -- (b) if it's compulsory (unless the test flag opt_PruneInstDecls is off)
+ new_tycls_names = case avail of
+ AvailTC tc _ | not opt_PruneInstDecls ||
+ case necessity of {Optional -> False; Compulsory -> True }
+ -> tycls_names `addOneToNameSet` tc
+ otherwise -> tycls_names
+
new_ifaces = Ifaces this_mod mod_vers export_envs decls
new_slurped_names
new_imp_names
- insts
+ (insts, new_tycls_names)
deferred_data_decls
inst_mods
in
getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (AvailTC tycon_name (tycon_name : sub_names))
+ returnRn (AvailTC tycon_name (tycon_name : nub sub_names))
+ -- The "nub" is because getConFieldNames can legitimately return duplicates,
+ -- when a record declaration has the same field in multiple constructors
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
projects / ghc-hetmet.git / commitdiff