\begin{code}
#include "HsVersions.h"
-module RnSource ( rnSource, rnPolyType ) where
+module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
import Ubiq
-import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
import HsSyn
import HsPragmas
import RnHsSyn
import RnMonad
import RnBinds ( rnTopBinds, rnMethodBinds )
+import RnUtils ( lookupGlobalRnEnv, lubExportFlag )
-import Bag ( bagToList )
+import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Class ( derivableClassKeys )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
+import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
-import Name ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
+import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
+ nameImportFlag, RdrName, pprNonSym )
+import Outputable -- ToDo:rm
+import PprStyle -- ToDo:rm
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
-import UniqFM ( addListToUFM, listToUFM )
+import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isn'tIn, panic, assertPanic )
-
-rnExports mods Nothing = returnRn (\n -> ExportAll)
-rnExports mods (Just exps) = returnRn (\n -> ExportAll)
+import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
rnSource `renames' the source module and export list.
\begin{code}
-rnSource :: [Module] -- imported modules
- -> Bag RenamedFixityDecl -- fixity info for imported names
+rnSource :: [Module]
+ -> Bag (Module,RnName) -- unqualified imports from module
+ -> Bag RenamedFixityDecl -- fixity info for imported names
-> RdrNameHsModule
-> RnM s (RenamedHsModule,
Name -> ExportFlag, -- export info
Bag (RnName, RdrName)) -- occurrence info
-rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
- ty_decls specdata_sigs class_decls
- inst_decls specinst_sigs defaults
- binds _ src_loc)
+rnSource imp_mods unqual_imps imp_fixes
+ (HsModule mod version exports _ fixes
+ ty_decls specdata_sigs class_decls
+ inst_decls specinst_sigs defaults
+ binds _ src_loc)
= pushSrcLocRn src_loc $
- rnExports (mod:imp_mods) exports `thenRn` \ exported_fn ->
- rnFixes fixes `thenRn` \ src_fixes ->
+ rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
+ rnFixes fixes `thenRn` \ src_fixes ->
let
- pair_name (InfixL n i) = (n, i)
- pair_name (InfixR n i) = (n, i)
- pair_name (InfixN n i) = (n, i)
+ pair_name inf = (nameFixDecl inf, inf)
- imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
- all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
+ all_fixes = src_fixes ++ bagToList imp_fixes
+ all_fixes_fm = listToUFM (map pair_name all_fixes)
in
- setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $
+ setExtraRn all_fixes_fm $
mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
returnRn (
HsModule mod version
- trashed_exports trashed_imports
- {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
+ 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,
occ_info
)
where
- trashed_exports = panic "rnSource:trashed_exports"
- trashed_imports = panic "rnSource:trashed_imports"
+ trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
+ trashed_imports = {-trace "rnSource:trashed_imports"-} []
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Export list}
+%* *
+%*********************************************************
+
+\begin{code}
+rnExports :: [Module]
+ -> Bag (Module,RnName)
+ -> Maybe [RdrNameIE]
+ -> RnM s (Name -> ExportFlag)
+
+rnExports mods unqual_imps Nothing
+ = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+
+rnExports mods unqual_imps (Just exps)
+ = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
+ let
+ exp_names = bagToList (unionManyBags exp_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
+ 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, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods
+
+ mod_fm = addListToFM_C unionBags emptyFM
+ [(mod, unitBag (getName rn, nameImportFlag (getName rn)))
+ | (mod,rn) <- bagToList unqual_imps]
+
+ add_mod_names (exp_map, empty) mod
+ = case lookupFM mod_fm mod of
+ Nothing -> (exp_map, mod:empty)
+ Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty)
+
+ pair_fst p@(f,_) = (f,p)
+ 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
+ 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
+ in
+ getSrcLocRn `thenRn` \ src_loc ->
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
+ mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
+ mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
+ returnRn exp_fn
+
+
+rnIE mods (IEVar name)
+ = lookupValue name `thenRn` \ rn ->
+ checkIEVar rn `thenRn` \ exps ->
+ returnRn (Nothing, exps)
+ where
+ checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll))
+ checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (classOpExportErr rn src_loc)
+ checkIEVar rn = returnRn 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 rn = returnRn emptyBag
+
+rnIE mods (IEThingAll name)
+ = lookupTyConOrClass name `thenRn` \ rn ->
+ checkIEAll rn `thenRn` \ exps ->
+ checkImportAll rn `thenRn_`
+ returnRn (Nothing, exps)
+ where
+ 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 = returnRn emptyBag
+
+ exp_all n = (n, ExportAll)
+
+rnIE mods (IEThingWith name names)
+ = lookupTyConOrClass name `thenRn` \ rn ->
+ mapRn lookupValue names `thenRn` \ rns ->
+ checkIEWith rn rns `thenRn` \ exps ->
+ checkImportAll rn `thenRn_`
+ returnRn (Nothing, exps)
+ where
+ checkIEWith rn@(RnData n cons fields) rns
+ | same_names (cons++fields) rns
+ = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
+ | otherwise
+ = rnWithErr "constructrs (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 rn@(RnSyn _) rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEWith rn rns
+ = returnRn emptyBag
+
+ exp_all n = (n, ExportAll)
+
+ same_names has rns
+ = all (not.isRnUnbound) rns &&
+ sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
+
+ rnWithErr str rn has rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
+
+rnIE mods (IEModuleContents mod)
+ | isIn "rnIE:IEModule" mod mods
+ = returnRn (Just mod, emptyBag)
+ | otherwise
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
+
+
+checkImportAll rn
+ = case nameImportFlag (getName rn) of
+ ExportAll -> returnRn ()
+ exp -> getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (importAllErr rn src_loc)
\end{code}
%*********************************************************
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}
%*********************************************************
-%* *
+%* *
\subsection{SPECIALIZE data pragmas}
-%* *
+%* *
%*********************************************************
\begin{code}
rnSpecDataSig (SpecDataSig tycon ty src_loc)
= pushSrcLocRn src_loc $
let
- tyvars = extractMonoTyNames ty
+ tyvars = extractMonoTyNames is_tyvar_name ty
in
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
lookupTyCon tycon `thenRn` \ tycon' ->
rnMonoType tv_env ty `thenRn` \ ty' ->
returnRn (SpecDataSig tycon' ty' src_loc)
+
+is_tyvar_name n = isLexVarId (getLocalName n)
\end{code}
%*********************************************************
rnSpecInstSig (SpecInstSig clas ty src_loc)
= pushSrcLocRn src_loc $
let
- tyvars = extractMonoTyNames ty
+ tyvars = extractMonoTyNames is_tyvar_name ty
in
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
lookupClass clas `thenRn` \ new_clas ->
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 = nameFixDecl fix1 `cmp` nameFixDecl 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
+ -> 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)
-
+
+nameFixDecl (InfixL name i) = name
+nameFixDecl (InfixR name i) = name
+nameFixDecl (InfixN name i) = name
\end{code}
%*********************************************************
rnPolyType tv_env (HsForAllTy tvs ctxt ty)
= rn_poly_help tv_env tvs ctxt ty
-rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
+rnPolyType tv_env (HsPreForAllTy ctxt ty)
= rn_poly_help tv_env forall_tyvars ctxt ty
where
- mentioned_tyvars = extract_poly_ty_names poly_ty
- forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
-
-------------
-extract_poly_ty_names (HsPreForAllTy ctxt ty)
- = extractCtxtTyNames ctxt
- `unionLists`
- extractMonoTyNames ty
+ 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))) $
+ mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
------------
rn_poly_help :: TyVarNamesEnv
-> RnM_Fixes s RenamedPolyType
rn_poly_help tv_env tyvars ctxt ty
- = getSrcLocRn `thenRn` \ src_loc ->
+ = --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 ->
+ rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
rnMonoType tv_env2 ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
rnMonoType tv_env (MonoTyApp name tys)
= let
- lookup_fn = if isAvarid (getLocalName name)
+ lookup_fn = if isLexVarId (getLocalName name)
then lookupTyVarName tv_env
else lookupTyCon
in
- lookup_fn name `thenRn` \ name' ->
+ lookup_fn name `thenRn` \ name' ->
mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
returnRn (MonoTyApp name' tys')
\end{code}
\begin{code}
-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,_):_)
+ = addShortErrLocLine 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 class"])
+
+synAllExportErr syn locn
+ = addShortErrLocLine 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:", ppPStr mod])
+
+dupModExportWarn locn mods@(mod:_)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+
+emptyModExportWarn locn mod
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
+
+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
+ 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)
-undefinedFixityDeclErr decl sty
- = ppHang (ppStr "Fixity declaration for unknown operator")
- 4 (ppr sty decl)
+dupFixityDeclErr locn dups
+ = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
+ ppAboves (map (ppr sty) dups))
\end{code}
projects / ghc-hetmet.git / blobdiff