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}
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)
-> 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
where n = ifName d
-- strongly-connected groups of declarations, in dependency order
- groups = stronglyConnComp edges
+ groups = stronglyConnCompFromEdgedVertices edges
global_hash_fn = mkHashFun hsc_env eps
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
-- 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]
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
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifOpenSyn = syn_isOpen,
- ifSynRhs = toIfaceType syn_tyki,
+ ifSynRhs = syn_rhs,
+ ifSynKind = syn_ki,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
}
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
- (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
- OpenSynTyCon ki _ -> (True , ki)
- SynonymTyCon ty -> (False, ty)
+ (syn_rhs, syn_ki)
+ = case synTyConRhs tycon of
+ OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
+ SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)