#include "HsVersions.h"
-import DynFlags ( DynFlag(..), GhcMode(..) )
+import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
+ instDeclATs,
LIE )
import RnEnv
import IfaceEnv ( ifaceExportNames )
import TcRnMonad hiding (LIE)
import FiniteMap
-import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual )
-import Module ( Module, moduleString, unitModuleEnv,
- lookupModuleEnv, moduleEnvElts, foldModuleEnv )
+import PrelNames
+import Module
import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName,
nameParent, nameParent_maybe, isExternalName,
isBuiltInSyntax )
extendOccEnv )
import HscTypes ( GenAvailInfo(..), AvailInfo,
HomePackageTable, PackageIfaceTable,
- unQualInScope,
+ mkPrintUnqualified,
Deprecs(..), ModIface(..), Dependencies(..),
- lookupIface, ExternalPackageState(..)
+ lookupIfaceByModule, ExternalPackageState(..)
)
-import Packages ( PackageIdH(..) )
import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace,
GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts,
Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance )
import Outputable
+import UniqFM
import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse )
import SrcLoc ( Located(..), mkGeneralSrcSpan,
unLoc, noLoc, srcLocSpan, SrcSpan )
import Util ( notNull )
import List ( partition )
import IO ( openFile, IOMode(..) )
+import Monad ( liftM )
\end{code}
| otherwise = [preludeImportDecl]
explicit_prelude_import
= notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports,
- unLoc mod == pRELUDE ]
+ unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl RdrName
preludeImportDecl
= L loc $
- ImportDecl (L loc pRELUDE)
+ ImportDecl (L loc pRELUDE_NAME)
False {- Not a boot interface -}
False {- Not qualified -}
Nothing {- No "as" -}
return $ ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,rn_import_items))
where
srcSpanWrapper (L span ieRdr)
- = setSrcSpan span $
- case get_item ieRdr of
+ = case get_item ieRdr of
Nothing
- -> do addErr (badImportItemErr iface decl_spec ieRdr)
+ -> do addErrAt span (badImportItemErr iface decl_spec ieRdr)
return Nothing
Just ieNames
-> return (Just [L span ie | ie <- ieNames])
let
-- Compute new transitive dependencies
- orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) )
- imp_mod_name : dep_orphs deps
+ orphans | is_orph = ASSERT( not (imp_mod `elem` dep_orphs deps) )
+ imp_mod : dep_orphs deps
| otherwise = dep_orphs deps
+ pkg = modulePackageId (mi_module iface)
+
(dependent_mods, dependent_pkgs)
- = case mi_package iface of
- HomePackage ->
+ | pkg == thisPackage dflags =
-- Imported module is from the home package
-- Take its dependent modules and add imp_mod itself
-- Take its dependent packages unchanged
-- check. See LoadIface.loadHiBootInterface
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
- ExtPackage pkg ->
+ | otherwise =
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
-- module M ( module P ) where ...
-- Then we must export whatever came from P unqualified.
imports = ImportAvails {
- imp_env = unitModuleEnv qual_mod_name avail_env,
+ imp_env = unitUFM qual_mod_name avail_env,
imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc),
imp_orphs = orphans,
imp_dep_mods = mkModDeps dependent_mods,
returnM (gbl_env, imports)
warnRedundantSourceImport mod_name
- = ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
+ = ptext SLIT("Unnecessary {-# SOURCE #-} in the import of module")
<+> quotes (ppr mod_name)
\end{code}
; this_mod = tcg_mod gbl_env
; imports = emptyImportAvails {
- imp_env = unitModuleEnv this_mod $
+ imp_env = unitUFM (moduleName this_mod) $
mkNameSet filtered_names
}
}
*** See "THE NAMING STORY" in HsDecls ****
+Associated data types: Instances declarations may contain definitions of
+associated data types whose data constructors we need to collect, too.
+However, we need to be careful with the handling of the data type constructor
+of each asscociated type, as it is already defined in the corresponding
+class. We make a new name for it, but don't return it in the 'AvailInfo' (to
+avoid raising a duplicate declaration error; see the helper
+'unavail_main_name').
+
\begin{code}
getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name]
getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
hs_fords = foreign_decls })
= do { tc_names_s <- mappM new_tc tycl_decls
+ ; at_names_s <- mappM inst_ats inst_decls
; val_names <- mappM new_simple val_bndrs
- ; return (foldr (++) val_names tc_names_s) }
+ ; return (foldr (++) val_names (tc_names_s ++ concat at_names_s)) }
where
mod = tcg_mod gbl_env
is_hs_boot = isHsBoot (tcg_src gbl_env) ;
sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs]
val_hs_bndrs = collectHsBindLocatedBinders val_decls
- for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
+ for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
new_tc tc_decl
= do { main_name <- newTopSrcBinder mod Nothing main_rdr
; return (main_name : sub_names) }
where
(main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+
+ inst_ats inst_decl
+ = mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl))
+ -- drop main_rdr (already declared in class)
\end{code}
\begin{code}
type ExportAccum -- The type of the accumulating parameter of
-- the main worker function in rnExports
- = ([Module], -- 'module M's seen so far
+ = ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
NameSet) -- The accumulated exported stuff
emptyExportAccum = ([], emptyOccEnv, emptyNameSet)
rnExports (Just exports)
= do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv
let sub_env :: NameEnv [Name] -- Classify each name by its parent
- sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env)
+ sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
rnExport (IEVar rdrName)
= do name <- lookupGlobalOccRn rdrName
return (IEVar name)
return exports
where
sub_env :: NameEnv [Name] -- Classify each name by its parent
- sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env)
+ sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
do_litem :: ExportAccum -> (LIE Name, LIE RdrName) -> RnM ExportAccum
do_litem acc (ieName, ieRdr)
returnM acc }
| otherwise
- = case lookupModuleEnv imp_env mod of
+ = case lookupUFM imp_env mod of
Nothing -> do addErr (modExportErr mod)
return acc
Just names
| otherwise -- Same occ name but different names: an error
-> do { global_env <- getGlobalRdrEnv ;
- addErr (exportClashErr global_env name name' ie ie') ;
+ addErr (exportClashErr global_env name' name ie' ie) ;
returnM occs }
where
name_occ = nameOccName name
%*********************************************************
\begin{code}
-reportDeprecations :: TcGblEnv -> RnM ()
-reportDeprecations tcg_env
+reportDeprecations :: DynFlags -> TcGblEnv -> RnM ()
+reportDeprecations dflags tcg_env
= ifOptM Opt_WarnDeprecations $
do { (eps,hpt) <- getEpsAndHpt
-- By this time, typechecking is complete,
check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
| name `elemNameSet` used_names
- , Just deprec_txt <- lookupDeprec hpt pit name
- = setSrcSpan (importSpecLoc imp_spec) $
- addWarn (sep [ptext SLIT("Deprecated use of") <+>
+ , Just deprec_txt <- lookupDeprec dflags hpt pit name
+ = addWarnAt (importSpecLoc imp_spec)
+ (sep [ptext SLIT("Deprecated use of") <+>
pprNonVarNameSpace (occNameSpace (nameOccName name)) <+>
quotes (ppr name),
(parens imp_msg) <> colon,
name_mod = nameModule name
imp_mod = importSpecModule imp_spec
imp_msg = ptext SLIT("imported from") <+> ppr imp_mod <> extra
- extra | imp_mod == name_mod = empty
+ extra | imp_mod == moduleName name_mod = empty
| otherwise = ptext SLIT(", but defined in") <+> ppr name_mod
check hpt pit ok_gre = returnM () -- Local, or not used, or not deprectated
-- the defn of a non-deprecated thing, when changing a module's
-- interface
-lookupDeprec :: HomePackageTable -> PackageIfaceTable
+lookupDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable
-> Name -> Maybe DeprecTxt
-lookupDeprec hpt pit n
- = case lookupIface hpt pit (nameModule n) of
+lookupDeprec dflags hpt pit n
+ = case lookupIfaceByModule dflags hpt pit (nameModule n) of
Just iface -> mi_dep_fn iface n `seqMaybe` -- Bleat if the thing, *or
mi_dep_fn iface (nameParent n) -- its parent*, is deprec'd
Nothing
-- into a bunch of avails, so they are properly grouped
--
-- BUG WARNING: this does not deal properly with qualified imports!
- minimal_imports :: FiniteMap Module AvailEnv
+ minimal_imports :: FiniteMap ModuleName AvailEnv
minimal_imports0 = foldr add_expall emptyFM expall_mods
minimal_imports1 = foldr add_name minimal_imports0 defined_and_used
minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods
| otherwise = Avail n
add_inst_mod (mod,_,_) acc
- | mod `elemFM` acc = acc -- We import something already
- | otherwise = addToFM acc mod emptyAvailEnv
+ | mod_name `elemFM` acc = acc -- We import something already
+ | otherwise = addToFM acc mod_name emptyAvailEnv
where
+ mod_name = moduleName mod
-- Add an empty collection of imports for a module
-- from which we have sucked only instance decls
--
-- BUG WARNING: does not deal correctly with multiple imports of the same module
-- becuase direct_import_mods has only one entry per module
- unused_imp_mods = [(mod,loc) | (mod,no_imp,loc) <- direct_import_mods,
- not (mod `elemFM` minimal_imports1),
+ unused_imp_mods = [(mod_name,loc) | (mod,no_imp,loc) <- direct_import_mods,
+ let mod_name = moduleName mod,
+ not (mod_name `elemFM` minimal_imports1),
mod /= pRELUDE,
not no_imp]
-- The not no_imp part is not to complain about
-- import M (), which is an idiom for importing
-- instance declarations
- module_unused :: Module -> Bool
+ module_unused :: ModuleName -> Bool
module_unused mod = any (((==) mod) . fst) unused_imp_mods
---------------------
selectiveImpItem (ImpSome {}) = True
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
-printMinimalImports :: FiniteMap Module AvailEnv -- Minimal imports
+printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports
-> RnM ()
printMinimalImports imps
= ifOptM Opt_D_dump_minimal_imports $ do {
this_mod <- getModule ;
rdr_env <- getGlobalRdrEnv ;
ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ;
- printForUser h (unQualInScope rdr_env)
+ printForUser h (mkPrintUnqualified rdr_env)
(vcat (map ppr_mod_ie mod_ies)) })
}
where
- mkFilename this_mod = moduleString this_mod ++ ".imports"
+ mkFilename this_mod = moduleNameString (moduleName this_mod) ++ ".imports"
ppr_mod_ie (mod_name, ies)
- | mod_name == pRELUDE
+ | mod_name == moduleName pRELUDE
= empty
| null ies -- Nothing except instances comes from here
= ptext SLIT("import") <+> ppr mod_name <> ptext SLIT("() -- Instances only")
to_ie (AvailTC n ns)
= loadSrcInterface doc n_mod False `thenM` \ iface ->
case [xs | (m,as) <- mi_exports iface,
- m == n_mod,
+ moduleName m == n_mod,
AvailTC x xs <- as,
x == nameOccName n] of
[xs] | all_used xs -> returnM (IEThingAll n)
where
all_used avail_occs = all (`elem` map nameOccName ns) avail_occs
doc = text "Compute minimal imports from" <+> ppr n
- n_mod = nameModule n
+ n_mod = moduleName (nameModule n)
\end{code}
projects / ghc-hetmet.git / blobdiff