import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Class ( derivableClassKeys )
-import ErrUtils ( addErrLoc, addShortErrLocLine )
+import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
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 Outputable -- ToDo:rm
+import PprStyle -- ToDo:rm
+import PrelInfo ( consDataCon )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
\begin{code}
-rnSource :: [Module]
+rnSource :: [Module] -- imported modules
-> Bag (Module,RnName) -- unqualified imports from module
-> Bag RenamedFixityDecl -- fixity info for imported names
-> RdrNameHsModule
rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
rnFixes fixes `thenRn` \ src_fixes ->
let
- pair_name inf = (nameFixDecl inf, inf)
+ all_fixes = src_fixes ++ bagToList imp_fixes
+ all_fixes_fm = listToUFM (map pair_name all_fixes)
- all_fixes = src_fixes ++ bagToList imp_fixes
- all_fixes_fm = listToUFM (map pair_name all_fixes)
+ pair_name inf = (fixDeclName inf, inf)
in
setExtraRn all_fixes_fm $
mod_fm = addListToFM_C unionBags emptyFM
[(mod, unitBag (getName rn, nameImportFlag (getName rn)))
- | (mod,rn) <- bagToList unqual_imps]
+ | (mod,rn) <- bagToList unqual_imps, isRnDecl rn]
add_mod_names (exp_map, empty) mod
= case lookupFM mod_fm mod of
checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
`unionBags` listToBag (map exp_all fields))
checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
- checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
- warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEAll rn@(RnSyn n) = getSrcLocRn `thenRn` \ src_loc ->
+ warnAndContinueRn (unitBag (n, ExportAbs))
+ (synAllExportErr False{-warning-} rn src_loc)
checkIEAll rn = returnRn emptyBag
exp_all n = (n, ExportAll)
= rnWithErr "class ops" rn ops rns
checkIEWith rn@(RnSyn _) rns
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (synAllExportErr rn src_loc)
+ failButContinueRn emptyBag (synAllExportErr True{-error-} rn src_loc)
checkIEWith rn rns
= returnRn emptyBag
= getSrcLocRn `thenRn` \ src_loc ->
let
(_, dup_fixes) = removeDups cmp_fix fixities
- cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
+ cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
rn_fixity fix@(InfixL name i)
= rn_fixity_pieces InfixL name i fix
mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
returnRn (catMaybes fixes_maybe)
-
-nameFixDecl (InfixL name i) = name
-nameFixDecl (InfixR name i) = name
-nameFixDecl (InfixN name i) = name
\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]
- -- ) $
+ = {-
+ 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
\begin{code}
dupNameExportWarn locn names@((n,_):_)
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
dupLocalsExportErr locn locals@((str,_):_)
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
-synAllExportErr syn locn
- = addShortErrLocLine locn (\ sty ->
+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 "'"],
+ 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)] ])
badModExportErr mod locn
= addShortErrLocLine locn (\ sty ->
- ppCat [ ppStr "unknown module in export list:", ppPStr mod])
-
-dupModExportWarn locn mods@(mod:_)
- = addShortErrLocLine locn (\ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+ ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
emptyModExportWarn locn mod
- = addShortErrLocLine locn (\ sty ->
+ = 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])