import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
IE(..), ieName,
- ForeignDecl(..), ForKind(..), isDynamic,
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), Sig(..), ImportDecl(..),
collectTopBinders
)
import PrelInfo ( main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, catMaybes )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
isLocallyDefined, setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance
)
-import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import OccName ( setOccNameSpace, dataName )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
-> RnMG (Maybe (ExportEnv,
GlobalRdrEnv,
FixityEnv, -- Fixities for local decls only
- NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ AvailEnv -- Maps a name to its parent AvailInfo
-- Just for in-scope things only
))
-- Nothing => no need to recompile
-getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
+getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
isQual rdr_name]) `thenRn_`
-- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails gbl_env
- `thenRn` \ exported_avails ->
+ exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
-- DONE
returnRn (gbl_env, exported_avails, Just all_avails)
| FixitySig name fixity _ <- nameEnvElts local_fixity_env,
isLocallyDefined name
]
- in
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
- --- TIDY UP
- let
- export_env = ExportEnv exported_avails exported_fixities
+ -- CONSTRUCT RESULTS
+ export_mods = case exports of
+ Nothing -> []
+ Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod]
+
+ export_env = ExportEnv exported_avails exported_fixities export_mods
(_, global_avail_env) = all_avails
in
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
+
returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env))
}
where
-- Unchanged source, and no errors yet; see if usage info
-- up to date, and exit if so
checkUpToDate mod `thenRn` \ up_to_date ->
- putDocRn (text "Compilation" <+>
- text (if up_to_date then "IS NOT" else "IS") <+>
- text "required") `thenRn_`
+ (if up_to_date
+ then putDocRn (text "Compilation IS NOT required")
+ else returnRn ()) `thenRn_`
returnRn up_to_date
\end{code}
getFixities acc (FixD fix)
= fix_decl acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _))
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities acc other_decl
-> RnMG ([AvailInfo], -- What's actually imported
[AvailInfo], -- What's to be hidden
-- (the unqualified version, that is)
+ -- (We need to return both the above sets, because
+ -- the qualified version is never hidden; so we can't
+ -- implement hiding by reducing what's imported.)
NameSet) -- What was imported explicitly
-- Complains if import spec mentions things that the module doesn't export
= returnRn (imports, [], emptyNameSet)
filterImports mod (Just (want_hiding, import_items)) avails
- = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits ->
+ = flatMapRn get_item import_items `thenRn` \ avails_w_explicits ->
let
(item_avails, explicits_s) = unzip avails_w_explicits
explicits = foldl addListToNameSet emptyNameSet explicits_s
-- they won't make any difference because naked entities like T
-- in an import list map to TcOccs, not VarOccs.
- check_item item@(IEModuleContents _)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
+ bale_out item = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn []
+
+ get_item item@(IEModuleContents _) = bale_out item
+
+ get_item item@(IEThingAll _)
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn [(avail, [availName avail])]
+ Just avail -> returnRn [(avail, [availName avail])]
+
+ get_item item@(IEThingAbs n)
+ | want_hiding -- hiding( C )
+ -- Here the 'C' can be a data constructor *or* a type/class
+ = case catMaybes [check_item item, check_item (IEThingAbs data_n)] of
+ [] -> bale_out item
+ avails -> returnRn [(a, []) | a <- avails]
+ -- The 'explicits' list is irrelevant when hiding
+ where
+ data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName)
+
+ get_item item
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail -> returnRn [(avail, availNames avail)]
+
+ ok_dotdot_item (AvailTC _ [n]) = False
+ ok_dotdot_item other = True
check_item item
| not (maybeToBool maybe_in_import_avails) ||
not (maybeToBool maybe_filtered_avail)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
-
- | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
- returnRn (Just (filtered_avail, explicits))
+ = Nothing
- | otherwise = returnRn (Just (filtered_avail, explicits))
+ | otherwise
+ = Just filtered_avail
where
wanted_occ = rdrNameOcc (ieName item)
Just avail = maybe_in_import_avails
maybe_filtered_avail = filterAvail item avail
Just filtered_avail = maybe_filtered_avail
- explicits | dot_dot = [availName filtered_avail]
- | otherwise = availNames filtered_avail
-
- dot_dot = case item of
- IEThingAll _ -> True
- other -> False
-
- dodgy_import = case (item, avail) of
- (IEThingAll _, AvailTC _ [n]) -> True
- -- This occurs when you import T(..), but
- -- only export T abstractly. The single [n]
- -- in the AvailTC is the type or class itself
-
- other -> False
\end{code}
-- the main worker function in exportsFromAvail
= ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
- NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
+ AvailEnv) -- The accumulated exported stuff, kept in an env
-- so we can common-up related AvailInfos
type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
(mod_avail_env, entity_avail_env)
global_name_env
= foldlRn exports_from_item
- ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ ([], emptyFM, emptyAvailEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
let
export_avails :: [AvailInfo]
export_avails = nameEnvElts export_avail_map
Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
`thenRn` \ occs' ->
let
- avails' = foldl add_avail avails mod_avails
+ avails' = foldl addAvail avails mod_avails
in
returnRn (mod:mods, occs', avails')
= failWithRn acc (exportItemErr ie)
| otherwise -- Phew! It's OK! Now to check the occurrence stuff!
- = check_occs ie occs export_avail `thenRn` \ occs' ->
- returnRn (mods, occs', add_avail avails export_avail)
+
+
+ = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
+ check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', addAvail avails export_avail)
where
rdr_name = ieName ie
enough_avail = maybeToBool maybe_export_avail
Just export_avail = maybe_export_avail
-add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+ ok_item (IEThingAll _) (AvailTC _ [n]) = False
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ ok_item _ _ = True
check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
check_occs ie occs avail
= sep [ptext SLIT("Module"), quotes (pprModuleName mod),
ptext SLIT("does not export"), quotes (ppr ie)]
-dodgyImportWarn mod (IEThingAll tc)
- = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod)
- <+> ptext SLIT("exports") <+> quotes (ppr tc),
- ptext SLIT("with no constructors/class operations;"),
- ptext SLIT("yet it is imported with a (..)")]
+dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
+dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item
+dodgyMsg kind item@(IEThingAll tc)
+ = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item),
+ ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"),
+ ptext SLIT("but it has none; it is a type synonym or abstract type or class") ]
+
modExportErr mod
= hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
exportItemErr export_item
- = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
+ = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
+ ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
exportClashErr occ_name ie1 ie2
= hsep [ptext SLIT("The export items"), quotes (ppr ie1)
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
-
\end{code}