X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=2d608011fae6960cb124e3b33ea5839cb10d7647;hb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;hp=16cd50637312c720518640900f8a111ef361ef1a;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 16cd506..2d60801 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -6,10 +6,10 @@ \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 @@ -17,21 +17,24 @@ import RdrHsSyn 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. @@ -49,31 +52,31 @@ Checks the (..) etc constraints in the 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 -> @@ -87,8 +90,7 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes 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, @@ -96,8 +98,152 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes 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} %********************************************************* @@ -179,41 +325,49 @@ rnConDecls tv_env con_decls 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} @@ -223,12 +377,14 @@ rnSpecDataSig :: RdrNameSpecDataSig 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} %********************************************************* @@ -343,7 +499,7 @@ rnSpecInstSig :: RdrNameSpecInstSig 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 -> @@ -384,23 +540,32 @@ rnDefaultDecl defs@(d:ds) 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} %********************************************************* @@ -417,17 +582,13 @@ rnPolyType :: TyVarNamesEnv 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 @@ -437,12 +598,17 @@ 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} @@ -470,11 +636,11 @@ rnMonoType tv_env (MonoTupleTy tys) 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} @@ -493,17 +659,62 @@ rnContext tv_env ctxt \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}