import Id
import IdInfo
import NewDemand
+import Annotations
import CoreSyn
import CoreFVs
import Class
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}
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
+ md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
mi_fixities = fixities,
mi_warns = warns,
+ mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
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
| otherwise
= case nameModule_maybe name of
Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
- Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+ Just mod -> -- We use this fiddly lambda function rather than
+ -- (++) as the argument to extendModuleEnv_C to
+ -- avoid quadratic behaviour (trac #2680)
+ extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
-- We want to create a Usage for a home module if
\end{code}
\begin{code}
+mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
+mkIfaceAnnotations = map mkIfaceAnnotation
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
+ ifAnnotatedTarget = fmap nameOccName target,
+ ifAnnotatedValue = serialized
+ }
+\end{code}
+
+\begin{code}
mkIfaceExports :: [AvailInfo]
-> [(Module, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- 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)
| 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