#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, isIdxTyDecl,
LIE )
import RnEnv
+import RnHsDoc ( rnHsDoc )
import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
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 )
+ isBuiltInSyntax, isTyConName )
import NameSet
import NameEnv
import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace,
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, when )
\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,
; 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 ****
+Instances of indexed types
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Indexed data/newtype instances contain data constructors that we need to
+collect, too. Moreover, we need to descend into the data/newtypes instances
+of associated families.
+
+We need to be careful with the handling of the type constructor of each type
+instance as the family constructor is already defined, and we want to avoid
+raising a duplicate declaration error. So, we make a new name for it, but
+don't return it in the 'AvailInfo'.
+
\begin{code}
getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name]
-getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
+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
+ | isIdxTyDecl (unLoc tc_decl)
+ = do { main_name <- lookupFamInstDeclBndr mod main_rdr
+ ; sub_names <-
+ mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
+ ; return sub_names } -- main_name is not declared here!
+ | otherwise
= do { main_name <- newTopSrcBinder mod Nothing main_rdr
- ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
+ ; sub_names <-
+ mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
; return (main_name : sub_names) }
- where
- (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+ where
+ (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+
+ inst_ats inst_decl
+ = mappM new_tc (instDeclATs (unLoc inst_decl))
\end{code}
= succeed_with True [name]
get_item (IEThingWith name names)
- = succeed_with True (name:names)
+ = do { optIdxTypes <- doptM Opt_IndexedTypes
+ ; when (not optIdxTypes && any isTyConName names) $
+ addErr (typeItemErr (head . filter isTyConName $ names )
+ (text "in import list"))
+ ; succeed_with True (name:names) }
get_item (IEVar name)
= succeed_with True [name]
-
+ get_item (IEGroup _ _)
+ = succeed_with False []
+ get_item (IEDoc _)
+ = succeed_with False []
+ get_item (IEDocNamed _)
+ = succeed_with False []
\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)
-> RnM (Maybe [LIE Name])
rnExports Nothing = return Nothing
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)
- rnExport (IEVar rdrName)
- = do name <- lookupGlobalOccRn rdrName
- return (IEVar name)
- rnExport (IEThingAbs rdrName)
- = do name <- lookupGlobalOccRn rdrName
- return (IEThingAbs name)
- rnExport (IEThingAll rdrName)
- = do name <- lookupGlobalOccRn rdrName
- return (IEThingAll name)
- rnExport ie@(IEThingWith rdrName rdrNames)
- = do name <- lookupGlobalOccRn rdrName
- if isUnboundName name
- then return (IEThingWith name [])
- else do
- let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name]
- mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames
- if any isNothing mb_names
- then do addErr (exportItemErr ie)
- return (IEThingWith name [])
- else return (IEThingWith name (catMaybes mb_names))
- rnExport (IEModuleContents mod)
- = return (IEModuleContents mod)
- rn_exports <- mapM (wrapLocM rnExport) exports
- return (Just rn_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 (foldUFM unionNameSets emptyNameSet imp_env)
+ rnExport (IEVar rdrName)
+ = do name <- lookupGlobalOccRn rdrName
+ return (IEVar name)
+ rnExport (IEThingAbs rdrName)
+ = do name <- lookupGlobalOccRn rdrName
+ return (IEThingAbs name)
+ rnExport (IEThingAll rdrName)
+ = do name <- lookupGlobalOccRn rdrName
+ return (IEThingAll name)
+ rnExport ie@(IEThingWith rdrName rdrNames)
+ = do name <- lookupGlobalOccRn rdrName
+ if isUnboundName name
+ then return (IEThingWith name [])
+ else do
+ let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name]
+ mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames
+ if any isNothing mb_names
+ then do addErr (exportItemErr ie)
+ return (IEThingWith name [])
+ else do let names = catMaybes mb_names
+ optIdxTypes <- doptM Opt_IndexedTypes
+ when (not optIdxTypes && any isTyConName names) $
+ addErr (typeItemErr ( head
+ . filter isTyConName
+ $ names )
+ (text "in export list"))
+ return (IEThingWith name names)
+ rnExport (IEModuleContents mod)
+ = return (IEModuleContents mod)
+ rnExport (IEGroup lev doc)
+ = do rn_doc <- rnHsDoc doc
+ return (IEGroup lev rn_doc)
+ rnExport (IEDoc doc)
+ = do rn_doc <- rnHsDoc doc
+ return (IEDoc rn_doc)
+ rnExport (IEDocNamed str)
+ = return (IEDocNamed str)
+
+ rn_exports <- mapM (wrapLocM rnExport) exports
+ return (Just rn_exports)
+
+filterOutDocs = filter notDoc
+ where
+ notDoc (L _ (IEGroup _ _)) = False
+ notDoc (L _ (IEDoc _)) = False
+ notDoc (L _ (IEDocNamed _)) = False
+ notDoc _ = True
mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all
-> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
return (Just ([noLoc (IEVar mainName)]
,[noLoc (IEVar main_RDR_Unqual)]))
-- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope
- exports_from_avail real_exports rdr_env imports
+
+ -- we don't want to include Haddock comments
+ let real_exports' = fmap (\(a,b) -> (filterOutDocs a, filterOutDocs b)) real_exports
+
+ exports_from_avail real_exports' rdr_env imports
exports_from_avail Nothing rdr_env imports
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}
= sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
+typeItemErr name wherestr
+ = sep [ ptext SLIT("Using 'type' tag on") <+> quotes (ppr name) <+> wherestr,
+ ptext SLIT("Use -findexed-types to enable this extension") ]
+
exportClashErr global_env name1 name2 ie1 ie2
= vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon
, ppr_export ie1 name1
projects / ghc-hetmet.git / blobdiff