import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
+ instDeclATs, isIdxTyDecl,
LIE )
import RnEnv
import IfaceEnv ( ifaceExportNames )
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,
import Util ( notNull )
import List ( partition )
import IO ( openFile, IOMode(..) )
+import Monad ( liftM, when )
\end{code}
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])
*** 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]
-> 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 (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 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)
+ rn_exports <- mapM (wrapLocM rnExport) exports
+ return (Just rn_exports)
mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all
-> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
| 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
check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
| name `elemNameSet` used_names
, Just deprec_txt <- lookupDeprec dflags hpt pit name
- = setSrcSpan (importSpecLoc imp_spec) $
- addWarn (sep [ptext SLIT("Deprecated use of") <+>
+ = addWarnAt (importSpecLoc imp_spec)
+ (sep [ptext SLIT("Deprecated use of") <+>
pprNonVarNameSpace (occNameSpace (nameOccName name)) <+>
quotes (ppr name),
(parens imp_msg) <> colon,
= 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