X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=f953107165adbe1b72ed5023cba38c7144725013;hb=7a7cb61b0de4a82d959fa3e8f2a3befba21ac0f8;hp=79c09a8d6e2b4b393f8d74817ea3e6b661198cf1;hpb=b8ec0390d59c80b14ec8f8564a09cfa91a8a2d7a;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 79c09a8..f953107 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -92,12 +92,14 @@ import Maybes import ListSetOps import Binary import Fingerprint +import Bag import Panic import Control.Monad import Data.List import Data.IORef import System.FilePath +import System.Exit ( exitWith, ExitCode(..) ) \end{code} @@ -126,11 +128,11 @@ mkIface hsc_env maybe_old_fingerprint mod_details mg_dir_imps = dir_imp_mods, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = deprecs, + mg_warns = warns, mg_hpc_info = hpc_info } = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env - fix_env deprecs hpc_info dir_imp_mods mod_details + fix_env warns hpc_info dir_imp_mods mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -147,7 +149,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details tcg_imports = imports, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, - tcg_deprecs = deprecs, + tcg_warns = warns, tcg_hpc = other_hpc_info } = do @@ -156,7 +158,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details let hpc_info = emptyHpcInfo other_hpc_info mkIface_ hsc_env maybe_old_fingerprint this_mod (isHsBoot hsc_src) used_names deps rdr_env - fix_env deprecs hpc_info (imp_mods imports) mod_details + fix_env warns hpc_info (imp_mods imports) mod_details mkUsedNames :: TcGblEnv -> IO NameSet @@ -208,12 +210,12 @@ mkDependencies mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameSet -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Deprecations -> HpcInfo + -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> ModDetails -> IO (ModIface, Bool) mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info + this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info dir_imp_mods ModDetails{ md_insts = insts, md_fam_insts = fam_insts, @@ -240,7 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - ; deprecs = src_deprecs + ; warns = src_warns ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -262,7 +264,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_vect_info = iface_vect_info, mi_fixities = fixities, - mi_deprecs = deprecs, + mi_warns = warns, mi_globals = Just rdr_env, -- Left out deliberately: filled in by addVersionInfo @@ -278,21 +280,36 @@ mkIface_ hsc_env maybe_old_fingerprint mi_hpc = isHpcUsed hpc_info, -- And build the cached values - mi_dep_fn = mkIfaceDepCache deprecs, + mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities } } - ; (new_iface, no_change_at_all, pp_orphs) + ; (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} addFingerprints hsc_env maybe_old_fingerprint intermediate_iface decls - -- Debug printing - ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) - (printDump (expectJust "mkIface" pp_orphs)) + -- Warn about orphans + ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans + | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns + | otherwise = emptyBag + errs_and_warns = (orph_warnings, emptyBag) + unqual = mkPrintUnqualified dflags rdr_env + inst_warns = listToBag [ instOrphWarn unqual d + | (d,i) <- insts `zip` iface_insts + , isNothing (ifInstOrph i) ] + rule_warns = listToBag [ ruleOrphWarn unqual this_mod r + | r <- iface_rules + , isNothing (ifRuleOrph r) ] + + ; when (not (isEmptyBag orph_warnings)) + (do { printErrorsAndWarnings dflags errs_and_warns + ; when (errorsFound dflags errs_and_warns) + (exitWith (ExitFailure 1)) }) -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) - + + -- Debug printing ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -373,9 +390,8 @@ addFingerprints -> ModIface -- The new interface (lacking decls) -> [IfaceDecl] -- The new decls -> IO (ModIface, -- Updated interface - Bool, -- True <=> no changes at all; + Bool) -- True <=> no changes at all; -- no need to write Iface - Maybe SDoc) -- Warnings about orphans addFingerprints hsc_env mb_old_fingerprint iface0 new_decls = do @@ -522,7 +538,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls (map fst sorted_decls, export_hash, orphan_hash, - mi_deprecs iface0) + mi_warns iface0) -- The interface hash depends on: -- - the ABI hash, plus @@ -548,7 +564,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_decls = sorted_decls, mi_hash_fn = lookupOccEnv local_env } -- - return (final_iface, no_change_at_all, pp_orphs) + return (final_iface, no_change_at_all) where this_mod = mi_module iface0 @@ -560,7 +576,6 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- non-orphans? fam_insts = mi_fam_insts iface0 fix_fn = mi_fix_fn iface0 - pp_orphs = pprOrphans orph_insts orph_rules getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] @@ -720,18 +735,19 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc -pprOrphans insts rules - | null insts && null rules = Nothing - | otherwise - = Just $ vcat [ - if null insts then empty else - hang (ptext (sLit "Warning: orphan instances:")) - 2 (vcat (map ppr insts)), - if null rules then empty else - hang (ptext (sLit "Warning: orphan rules:")) - 2 (vcat (map ppr rules)) - ] +instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg +instOrphWarn unqual inst + = mkWarnMsg (getSrcSpan inst) unqual $ + hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) + +ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg +ruleOrphWarn unqual mod rule + = mkWarnMsg silly_loc unqual $ + ptext (sLit "Orphan rule:") <+> ppr rule + where + silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0) + -- We don't have a decent SrcSpan for a Rule, not even the CoreRule + -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to ---------------------- -- mkOrphMap partitions instance decls or rules into @@ -1116,13 +1132,13 @@ needInterface mod continue -- Instead, get an Either back which we can test case mb_iface of - Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"), - ppr mod])); - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain: it might - -- just be that the current module doesn't need that - -- import and it's been deleted - Succeeded iface -> continue iface + Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"), + ppr mod])) + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> continue iface checkModUsage :: PackageId ->Usage -> IfG RecompileRequired