module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
-import Ubiq
-import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMPORT_1_3(List(partition))
import HsSyn
import HsPragmas
import RnHsSyn
import RnMonad
import RnBinds ( rnTopBinds, rnMethodBinds )
-import RnUtils ( lubExportFlag )
+import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag )
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Class ( derivableClassKeys )
+import CmdLineOpts ( opt_CompilingGhcInternals )
+import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
+import Id ( isDataCon, GenId{-instance NamedThing-} )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
-import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
- nameImportFlag, RdrName, pprNonSym )
-import Outputable -- ToDo:rm
-import PprStyle -- ToDo:rm
+import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
+ nameImportFlag, RdrName, pprNonSym, Name )
+import Outputable ( Outputable(..){-instances-} )
+--import PprStyle -- ToDo:rm
import Pretty
import SrcLoc ( SrcLoc )
+import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} )
import Unique ( Unique )
-import UniqFM ( emptyUFM, addListToUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
-import UniqSet ( UniqSet(..) )
-import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, panic, assertPanic, pprTrace{-ToDo:rm-} )
-
+import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
+import UniqSet ( SYN_IE(UniqSet) )
+import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
+ panic, assertPanic{- , pprTrace ToDo:rm-} )
\end{code}
rnSource `renames' the source module and export list.
\begin{code}
-rnSource :: [Module]
+rnSource :: [Module] -- imported modules
-> Bag (Module,RnName) -- unqualified imports from module
-> Bag RenamedFixityDecl -- fixity info for imported names
-> RdrNameHsModule
-> RnM s (RenamedHsModule,
Name -> ExportFlag, -- export info
+ ([(Name, ExportFlag)], -- export module X stuff
+ [(Name, ExportFlag)]),
Bag (RnName, RdrName)) -- occurrence info
rnSource imp_mods unqual_imps imp_fixes
= pushSrcLocRn src_loc $
- rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
+ rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) ->
rnFixes fixes `thenRn` \ src_fixes ->
let
- pair_name inf@(InfixL n _) = (n, inf)
- pair_name inf@(InfixR n _) = (n, inf)
- pair_name inf@(InfixN n _) = (n, inf)
+ all_fixes = src_fixes ++ bagToList imp_fixes
+ all_fixes_fm = listToUFM (map pair_name all_fixes)
- imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
- all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
+ pair_name inf = (fixDeclName inf, inf)
in
setExtraRn all_fixes_fm $
returnRn (
HsModule mod version
- trashed_exports trashed_imports src_fixes
+ trashed_exports trashed_imports all_fixes
new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds [] src_loc,
- exported_fn,
+ exported_fn, module_dotdots,
occ_info
)
where
rnExports :: [Module]
-> Bag (Module,RnName)
-> Maybe [RdrNameIE]
- -> RnM s (Name -> ExportFlag)
+ -> RnM s (Name -> ExportFlag, -- main export-flag fun
+ ([(Name,ExportFlag)], -- info about "module X" exports
+ [(Name,ExportFlag)])
+ )
rnExports mods unqual_imps Nothing
- = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+ = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
+ , ([], [])
+ )
rnExports mods unqual_imps (Just exps)
- = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
+ = getModuleRn `thenRn` \ this_mod ->
+ getRnEnv `thenRn` \ rn_env ->
+ mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
let
- exp_names = bagToList (unionManyBags exp_bags)
+ (tc_bags, val_bags) = unzip exp_bags
+ tc_names = bagToList (unionManyBags tc_bags)
+ val_names = bagToList (unionManyBags val_bags)
exp_mods = catMaybes mod_maybes
-- Warn for duplicate names and modules
- (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names
- (uniq_exp_mods, dup_mods) = removeDups cmpPString exp_mods
+ (_, dup_tc_names) = removeDups cmp_fst tc_names
+ (_, dup_val_names) = removeDups cmp_fst val_names
cmp_fst (x,_) (y,_) = x `cmp` y
- -- Build finite map of exported names to export flag
- exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names)
- exp_map1 = foldl add_mod_names exp_map0 uniq_exp_mods
+ (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
+ (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
- mod_fm = addListToFM_C unionBags emptyFM
- [(mod, unitBag (getName rn, nameImportFlag (getName rn)))
- | (mod,rn) <- bagToList unqual_imps]
+ -- Get names for "module This_Mod" export
+ (this_tcs, this_vals)
+ = if null expmods_this
+ then ([], [])
+ else getLocalsFromRnEnv rn_env
- add_mod_names exp_map mod
- = case lookupFM mod_fm mod of
- Nothing -> exp_map
- Just mod_names -> addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names))
+ -- Get names for exported imported modules
+ (mod_tcs, mod_vals, empty_mods)
+ = case mapAndUnzip3 get_mod_names expmods_imps of
+ (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
+
+ (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
+
+ get_mod_names mod
+ = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
+ (tcs, vals, empty_mod)
+ where
+ tcs = [(getName rn, nameImportFlag (getName rn))
+ | (mod',rn) <- unqual_tcs, mod == mod']
+ vals = [(getName rn, nameImportFlag (getName rn))
+ | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
+ empty_mod = if null tcs && null vals
+ then Just mod
+ else Nothing
+
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
- pair_fst p@(f,_) = (f,p)
+ -- Build finite map of exported names to export flag
+ tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
+ tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
+ tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs)
+
+ val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
+ val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
+ val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals)
+
+ pair_fst pr@(n,_) = (n,pr)
+ exp_all rn = (getName rn, ExportAll)
lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
-- Check for exporting of duplicate local names
- exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1]
- (_, dup_locals) = removeDups cmp_local exp_locals
+ tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
+ val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
+ (_, dup_tc_locals) = removeDups cmp_local tc_locals
+ (_, dup_val_locals) = removeDups cmp_local val_locals
cmp_local (x,_) (y,_) = x `cmpPString` y
-
-- Build export flag function
- exp_fn n = case lookupUFM exp_map1 n of
- Nothing -> NotExported
- Just (_,flag) -> flag
+ final_exp_map = plusUFM tc_map val_map
+ exp_fn n = case lookupUFM final_exp_map n of
+ Nothing -> NotExported
+ Just (_,flag) -> flag
in
- getSrcLocRn `thenRn` \ src_loc ->
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
- mapRn (addWarnRn . dupModuleExportWarn src_loc) dup_mods `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
- returnRn exp_fn
-
+ getSrcLocRn `thenRn` \ src_loc ->
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
+ mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
+ mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
+ returnRn (exp_fn, (mod_vals, mod_tcs))
+
+------------------------------------
+-- rename an "IE" in the export list
+
+rnIE :: [Module] -- this module and all the (directly?) imported modules
+ -> RdrNameIE
+ -> RnM s (
+ Maybe Module, -- Just m => a "module X" export item
+ (Bag (Name, ExportFlag), -- Exported tycons/classes
+ Bag (Name, ExportFlag))) -- Exported values
rnIE mods (IEVar name)
= lookupValue name `thenRn` \ rn ->
checkIEVar rn `thenRn` \ exps ->
returnRn (Nothing, exps)
where
- checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll))
- checkIEVar (RnUnbound _) = returnRn emptyBag
+ checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll))
+ checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll))
checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (classOpExportErr rn src_loc)
- checkIEVar rn = panic "checkIEVar"
+ failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
+ checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc)
+ checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $
+ returnRn (emptyBag, emptyBag)
rnIE mods (IEThingAbs name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkIEAbs rn `thenRn` \ exps ->
returnRn (Nothing, exps)
where
- checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnData n _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnUnbound _) = returnRn emptyBag
- checkIEAbs rn = panic "checkIEAbs"
+ checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag)
+ checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $
+ returnRn (emptyBag, emptyBag)
rnIE mods (IEThingAll name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkImportAll rn `thenRn_`
returnRn (Nothing, exps)
where
- checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
- checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
- checkIEAll (RnUnbound _) = returnRn emptyBag
- checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
- warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
- checkIEAll rn = panic "checkIEAll"
+ checkIEAll (RnData n cons fields)
+ = returnRn (unitBag (exp_all n),
+ listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields))
+
+ checkIEAll (WiredInTyCon t)
+ = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons))
+ where
+ cons = map getName (tyConDataCons t)
+
+ checkIEAll (RnClass n ops)
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
+ checkIEAll rn@(RnSyn n)
+ = getSrcLocRn `thenRn` \ src_loc ->
+ warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
+ (synAllExportErr False{-warning-} rn src_loc)
+
+ checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
+ returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
checkImportAll rn `thenRn_`
returnRn (Nothing, exps)
where
- checkIEWith rn@(RnData n cons) rns
- | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
- | otherwise = rnWithErr "constructrs" rn cons rns
+ checkIEWith rn@(RnData n cons fields) rns
+ | same_names (cons++fields) rns
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
+ `unionBags`
+ listToBag (map exp_all fields))
+ | otherwise
+ = rnWithErr "constructors (and fields)" rn (cons++fields) rns
checkIEWith rn@(RnClass n ops) rns
- | same_names ops rns = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
- | otherwise = rnWithErr "class ops" rn ops rns
- checkIEWith (RnUnbound _) rns = returnRn emptyBag
- checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (synAllExportErr rn src_loc)
- checkIEWith rn rns = panic "checkIEWith"
+ | same_names ops rns
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
+ | otherwise
+ = rnWithErr "class ops" rn ops rns
+ checkIEWith rn@(RnSyn _) rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
+ checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
+ checkIEWith rn rns
+ = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
+ returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
rnWithErr str rn has rns
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
+ failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
rnIE mods (IEModuleContents mod)
| isIn "rnIE:IEModule" mod mods
- = returnRn (Just mod, emptyBag)
+ = returnRn (Just mod, (emptyBag, emptyBag))
| otherwise
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
+ failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
checkImportAll rn
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecls `thenRn` \ condecls' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecl `thenRn` \ condecl' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
rn_deriv tycon2 locn clas
= lookupClass clas `thenRn` \ clas_name ->
addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
- (derivingNonStdClassErr clas locn)
+ (derivingNonStdClassErr clas_name locn)
`thenRn_`
returnRn clas_name
where
where
rn_decl (ConDecl name tys src_loc)
= pushSrcLocRn src_loc $
- lookupValue name `thenRn` \ new_name ->
+ lookupConstr name `thenRn` \ new_name ->
mapRn rn_bang_ty tys `thenRn` \ new_tys ->
returnRn (ConDecl new_name new_tys src_loc)
rn_decl (ConOpDecl ty1 op ty2 src_loc)
= pushSrcLocRn src_loc $
- lookupValue op `thenRn` \ new_op ->
+ lookupConstr op `thenRn` \ new_op ->
rn_bang_ty ty1 `thenRn` \ new_ty1 ->
rn_bang_ty ty2 `thenRn` \ new_ty2 ->
returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
rn_decl (NewConDecl name ty src_loc)
= pushSrcLocRn src_loc $
- lookupValue name `thenRn` \ new_name ->
+ lookupConstr name `thenRn` \ new_name ->
rn_mono_ty ty `thenRn` \ new_ty ->
returnRn (NewConDecl new_name new_ty src_loc)
- rn_decl (RecConDecl con fields src_loc)
- = panic "rnConDecls:RecConDecl"
+ rn_decl (RecConDecl name fields src_loc)
+ = pushSrcLocRn src_loc $
+ lookupConstr name `thenRn` \ new_name ->
+ mapRn rn_field fields `thenRn` \ new_fields ->
+ returnRn (RecConDecl new_name new_fields src_loc)
+
+ rn_field (names, ty)
+ = mapRn lookupField names `thenRn` \ new_names ->
+ rn_bang_ty ty `thenRn` \ new_ty ->
+ returnRn (new_names, new_ty)
- ----------
rn_mono_ty = rnMonoType tv_env
+ rn_poly_ty = rnPolyType tv_env
rn_bang_ty (Banged ty)
- = rn_mono_ty ty `thenRn` \ new_ty ->
+ = rn_poly_ty ty `thenRn` \ new_ty ->
returnRn (Banged new_ty)
rn_bang_ty (Unbanged ty)
- = rn_mono_ty ty `thenRn` \ new_ty ->
+ = rn_poly_ty ty `thenRn` \ new_ty ->
returnRn (Unbanged new_ty)
\end{code}
rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
= pushSrcLocRn src_loc $
- mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
- rnContext tv_env context `thenRn` \ context' ->
- lookupClass cname `thenRn` \ cname' ->
- mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
- rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
+ lookupClass cname `thenRn` \ cname' ->
+ mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
+ rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
ASSERT(isNoClassPragmas pragmas)
returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
where
- rn_op clas tv_env (ClassOpSig op ty pragmas locn)
+ rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
= pushSrcLocRn locn $
lookupClassOp clas op `thenRn` \ op_name ->
rnPolyType tv_env ty `thenRn` \ new_ty ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-*** not_elem = isn'tIn "tcClassSigs"
-*** -- Check that the class type variable is mentioned
-*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
+ let
+ (HsForAllTy tvs ctxt op_ty) = new_ty
+ ctxt_tvs = extractCtxtTyNames ctxt
+ op_tvs = extractMonoTyNames is_tyvar_name op_ty
+ in
+ -- check that class tyvar appears in op_ty
+ ( if isIn "rn_op" clas_tyvar op_tvs
+ then returnRn ()
+ else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
+ ) `thenRn_`
+
+ -- check that class tyvar *doesn't* appear in the sig's context
+ ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
+ then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
+ else returnRn ()
+ ) `thenRn_`
ASSERT(isNoClassOpPragmas pragmas)
returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
rnFixes fixities
- = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
+ = getSrcLocRn `thenRn` \ src_loc ->
+ let
+ (_, dup_fixes) = removeDups cmp_fix fixities
+ cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
+
+ rn_fixity fix@(InfixL name i)
+ = rn_fixity_pieces InfixL name i fix
+ rn_fixity fix@(InfixR name i)
+ = rn_fixity_pieces InfixR name i fix
+ rn_fixity fix@(InfixN name i)
+ = rn_fixity_pieces InfixN name i fix
+
+ rn_fixity_pieces mk_fixity name i fix
+ = getRnEnv `thenRn` \ env ->
+ case lookupGlobalRnEnv env name of
+ Just res | isLocallyDefined res -- || opt_CompilingGhcInternals
+ -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
+ -- fixity decl to go through. It has a builtin name, which
+ -- doesn't respond to isLocallyDefined... sigh.
+ -> returnRn (Just (mk_fixity res i))
+ _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
+ in
+ mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
+ mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
returnRn (catMaybes fixes_maybe)
- where
- rn_fixity fix@(InfixL name i)
- = rn_fixity_pieces InfixL name i fix
- rn_fixity fix@(InfixR name i)
- = rn_fixity_pieces InfixR name i fix
- rn_fixity fix@(InfixN name i)
- = rn_fixity_pieces InfixN name i fix
-
- rn_fixity_pieces mk_fixity name i fix
- = lookupValueMaybe name `thenRn` \ maybe_res ->
- case maybe_res of
- Just res | isLocallyDefined res
- -> returnRn (Just (mk_fixity res i))
- _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
-
\end{code}
%*********************************************************
= rn_poly_help tv_env forall_tyvars ctxt ty
where
mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
- forall_tyvars = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
- --pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
+ forall_tyvars = {-
+ pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
+ pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
+ -}
mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
------------
-> RnM_Fixes s RenamedPolyType
rn_poly_help tv_env tyvars ctxt ty
- = --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
- -- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
- -- ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
- -- ppStr ";ty=", ppr PprShowAll ty]
- -- ) $
- getSrcLocRn `thenRn` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
+ = {-
+ pprTrace "rnPolyType:"
+ (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
+ ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
+ ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
+ ppStr ";ty=", ppr PprShowAll ty]) $
+ -}
+ getSrcLocRn `thenRn` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
let
tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
in
- rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
- rnMonoType tv_env2 ty `thenRn` \ new_ty ->
+ rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
+ rnMonoType tv_env2 ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
\end{code}
\begin{code}
-rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
-rnContext tv_env ctxt
- = mapRn rn_ctxt ctxt
+rnContext tv_env locn ctxt
+ = mapRn rn_ctxt ctxt `thenRn` \ result ->
+ let
+ (_, dup_asserts) = removeDups cmp_assert result
+ in
+ -- If this isn't an error, then it ought to be:
+ mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
+ returnRn result
where
rn_ctxt (clas, tyvar)
- = lookupClass clas `thenRn` \ clas_name ->
- lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
- returnRn (clas_name, tyvar_name)
+ = lookupClass clas `thenRn` \ clas_name ->
+ lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
+ returnRn (clas_name, tyvar_name)
+
+ cmp_assert (c1,tv1) (c2,tv2)
+ = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
\end{code}
\begin{code}
-dupNameExportWarn locn names@((n,_):_) sty
- = ppHang (ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times:"])
- 4 (ppr sty locn)
-
-dupModuleExportWarn locn mods@(mod:_) sty
- = ppHang (ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list:"])
- 4 (ppr sty locn)
-
-dupLocalsExportErr locn locals@((str,_):_) sty
- = ppHang (ppBesides [ppStr "Exported names have same local name `", ppPStr str, ppStr "': ", ppr sty locn])
- 4 (ppInterleave ppSP (map (pprNonSym sty . snd) locals))
-
-classOpExportErr op locn sty
- = ppHang (ppStr "Class operation can only be exported with class:")
- 4 (ppCat [ppr sty op, ppr sty locn])
-
-synAllExportErr syn locn sty
- = ppHang (ppStr "Type synonym should be exported abstractly:")
- 4 (ppCat [ppr sty syn, ppr sty locn])
-
-withExportErr str rn has rns locn sty
- = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn])
- 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)])
- (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)]))
-
-importAllErr rn locn sty
- = ppHang (ppCat [pprNonSym sty rn, ppStr "exported concretely but only imported abstractly"])
- 4 (ppr sty locn)
-
-badModExportErr mod locn sty
- = ppHang (ppStr "Unknown module in export list:")
- 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn])
-
-derivingNonStdClassErr clas locn sty
- = ppHang (ppStr "Non-standard class in deriving:")
- 4 (ppCat [ppr sty clas, ppr sty locn])
-
-dupDefaultDeclErr defs sty
- = ppHang (ppStr "Duplicate default declarations:")
- 4 (ppAboves (map pp_def_loc defs))
+dupNameExportWarn locn names@((n,_):_)
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
+
+dupLocalsExportErr locn locals@((str,_):_)
+ = addErrLoc locn "exported names have same local name" $ \ sty ->
+ ppInterleave ppSP (map (pprNonSym sty . snd) locals)
+
+classOpExportErr op locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"]
+
+fieldExportErr op locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"]
+
+synAllExportErr is_error syn locn
+ = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
+
+withExportErr str rn has rns locn
+ = addErrLoc locn "" $ \ sty ->
+ ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
+ ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
+
+importAllErr rn locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
+
+badModExportErr mod locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
+
+emptyModExportWarn locn mod
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
+
+dupModExportWarn locn mods@(mod:_)
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
+
+derivingNonStdClassErr clas locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
+
+dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
+ = ppAboves (item1 : map dup_item dup_things)
where
- pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
-
-undefinedFixityDeclErr decl sty
- = ppHang (ppStr "Fixity declaration for unknown operator:")
- 4 (ppr sty decl)
+ item1
+ = addShortErrLocLine locn1 (\ sty ->
+ ppStr "multiple default declarations") sty
+
+ dup_item (DefaultDecl _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppStr "here was another default declaration") sty
+
+undefinedFixityDeclErr locn decl
+ = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
+ ppr sty decl
+
+dupFixityDeclErr locn dups
+ = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
+ ppAboves (map (ppr sty) dups)
+
+classTyVarNotInOpTyErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+ 4 (ppr sty sig)
+
+classTyVarInOpCtxtErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
+ 4 (ppr sty sig)
+
+dupClassAssertWarn ctxt locn dups
+ = addShortWarnLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+ 4 (ppr sty ctxt)
\end{code}
projects / ghc-hetmet.git / blobdiff