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 -- XXX
+ ; 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)
mkHashFun hsc_env eps
= \name ->
let
- mod = nameModule name
+ mod = ASSERT2( isExternalName name, ppr name ) nameModule name
occ = nameOccName name
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
-> 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
, let out = localOccs $ freeNamesDeclABI abi
]
+ name_module n = ASSERT( isExternalName n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
- . filter ((== this_mod) . nameModule)
+ . filter ((== this_mod) . name_module)
. nameSetToList
where getParent occ = lookupOccEnv parent_map occ `orElse` occ
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
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
- = let hash | nameModule name /= this_mod = global_hash_fn name
+ = ASSERT( isExternalName name )
+ let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
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]
-- used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
-putNameLiterally bh name = do
- put_ bh $! nameModule name
- put_ bh $! nameOccName name
+putNameLiterally bh name = ASSERT( isExternalName name )
+ do { put_ bh $! nameModule name
+ ; put_ bh $! nameOccName name }
computeFingerprint :: Binary a
=> DynFlags
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
-- else the plusFM will simply discard one! They
-- should have been combined by now.
add env (Avail n)
- = add_one env (nameModule n) (Avail (nameOccName n))
+ = ASSERT( isExternalName n )
+ add_one env (nameModule n) (Avail (nameOccName n))
add env (AvailTC tc ns)
- = foldl add_for_mod env mods
+ = ASSERT( all isExternalName ns )
+ foldl add_for_mod env mods
where
tc_occ = nameOccName tc
mods = nub (map nameModule ns)
-- 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
| 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)
do_rough (Just n) = Just (toIfaceTyCon_name n)
dfun_name = idName dfun_id
- mod = nameModule dfun_name
+ mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
is_local name = nameIsLocalOrFrom mod name
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
projects / ghc-hetmet.git / blobdiff