%
\begin{code}
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
-
module MkIface (
- mkUsageInfo, -- Construct the usage info for a module
-
+ mkUsedNames,
+ mkDependencies,
mkIface, -- Build a ModIface from a ModGuts,
-- including computing version information
+ mkIfaceTc,
+
writeIfaceFile, -- Write the interface file
checkOldIface, -- See if recompilation is required, by
compiled:
import B <n> ;
to record the fact that A does import B indirectly. This is used to decide
-to look to look for B.hi rather than B.hi-boot when compiling a module that
+to look for B.hi rather than B.hi-boot when compiling a module that
imports A. This line says that A imports B, but uses nothing in it.
So we'll get an early bale-out when compiling A if B's version changes.
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O. I think this is the case.]
+SimonM [30/11/2007]: I believe the above is all out of date; the
+current implementation doesn't do it this way. Instead, when any of
+the dependencies of a declaration changes, the version of the
+declaration itself changes.
\begin{code}
#include "HsVersions.h"
import VarEnv
import Var
import Name
+import RdrName
import NameEnv
import NameSet
import OccName
import ErrUtils
import Digraph
import SrcLoc
-import PackageConfig hiding ( Version )
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
-import UniqFM
+import LazyUniqFM
import Util hiding ( eqListBy )
import FiniteMap
import FastString
import Maybes
+import ListSetOps
import Control.Monad
import Data.List
+import Data.IORef
+import System.FilePath
\end{code}
\begin{code}
mkIface :: HscEnv
-> Maybe ModIface -- The old interface, if we have it
- -> ModGuts -- Usages, deprecations, etc
-> ModDetails -- The trimmed, tidied interface
+ -> ModGuts -- Usages, deprecations, etc
-> IO (ModIface, -- The new one, complete with decls and versions
Bool) -- True <=> there was an old Iface, and the new one
-- is identical, so no need to write it
-mkIface hsc_env maybe_old_iface
- (ModGuts{ mg_module = this_mod,
+mkIface hsc_env maybe_old_iface mod_details
+ ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
- mg_usages = usages,
+ mg_used_names = used_names,
mg_deps = deps,
+ mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
- mg_deprecs = src_deprecs,
- mg_hpc_info = hpc_info })
- (ModDetails{ md_insts = insts,
+ mg_deprecs = deprecs,
+ mg_hpc_info = hpc_info }
+ = mkIface_ hsc_env maybe_old_iface
+ this_mod is_boot used_names deps rdr_env
+ fix_env deprecs 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
+-- object code at all ('HscNothing').
+mkIfaceTc :: HscEnv
+ -> Maybe ModIface -- The old interface, if we have it
+ -> ModDetails -- gotten from mkBootModDetails, probably
+ -> TcGblEnv -- Usages, deprecations, etc
+ -> IO (ModIface,
+ Bool)
+mkIfaceTc hsc_env maybe_old_iface mod_details
+ tc_result@TcGblEnv{ tcg_mod = this_mod,
+ tcg_src = hsc_src,
+ tcg_imports = imports,
+ tcg_rdr_env = rdr_env,
+ tcg_fix_env = fix_env,
+ tcg_deprecs = deprecs,
+ tcg_hpc = other_hpc_info
+ }
+ = do
+ used_names <- mkUsedNames tc_result
+ deps <- mkDependencies tc_result
+ let hpc_info = emptyHpcInfo other_hpc_info
+ mkIface_ hsc_env maybe_old_iface
+ this_mod (isHsBoot hsc_src) used_names deps rdr_env
+ fix_env deprecs hpc_info (imp_mods imports) mod_details
+
+
+mkUsedNames :: TcGblEnv -> IO NameSet
+mkUsedNames
+ TcGblEnv{ tcg_inst_uses = dfun_uses_var,
+ tcg_dus = dus
+ }
+ = do
+ dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
+ return (allUses dus `unionNameSets` dfun_uses)
+
+mkDependencies :: TcGblEnv -> IO Dependencies
+mkDependencies
+ TcGblEnv{ tcg_mod = mod,
+ tcg_imports = imports,
+ tcg_th_used = th_var
+ }
+ = do
+ th_used <- readIORef th_var -- Whether TH is used
+ let
+ dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
+ -- M.hi-boot can be in the imp_dep_mods, but we must remove
+ -- it before recording the modules on which this one depends!
+ -- (We want to retain M.hi-boot in imp_dep_mods so that
+ -- loadHiBootInterface can see if M's direct imports depend
+ -- on M.hi-boot, and hence that we should do the hi-boot consistency
+ -- check.)
+
+ -- Modules don't compare lexicographically usually,
+ -- but we want them to do so here.
+ le_mod :: Module -> Module -> Bool
+ le_mod m1 m2 = moduleNameFS (moduleName m1)
+ <= moduleNameFS (moduleName m2)
+
+ le_dep_mod :: (ModuleName, IsBootInterface)
+ -> (ModuleName, IsBootInterface) -> Bool
+ le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
+
+
+ pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs imports
+
+ return Deps { dep_mods = sortLe le_dep_mod dep_mods,
+ dep_pkgs = sortLe (<=) pkgs,
+ dep_orphs = sortLe le_mod (imp_orphs imports),
+ dep_finsts = sortLe le_mod (imp_finsts imports) }
+ -- sort to get into canonical order
+
+
+mkIface_ :: HscEnv -> Maybe ModIface -> Module -> IsBootInterface
+ -> NameSet -> Dependencies -> GlobalRdrEnv
+ -> NameEnv FixItem -> Deprecations -> HpcInfo
+ -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
+ -> ModDetails
+ -> IO (ModIface, Bool)
+mkIface_ hsc_env maybe_old_iface
+ this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
+ dir_imp_mods
+ ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_vect_info = vect_info,
md_types = type_env,
- md_exports = exports })
-
+ md_exports = exports }
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want
-- to expose in the interface
- = do { eps <- hscEPS hsc_env
+ = do {eps <- hscEPS hsc_env
+
+ ; usages <- mkUsageInfo hsc_env dir_imp_mods (dep_mods deps) used_names
+
; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
nameIsLocalOrFrom this_mod name ]
-- Sigh: see Note [Root-main Id] in TcRnDriver
- ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
- ; deprecs = mkIfaceDeprec src_deprecs
+ ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+ ; deprecs = src_deprecs
; iface_rules = map (coreRuleToIfaceRule this_mod) rules
; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
- ; return (new_iface, no_change_at_all) }
+ -- bug #1617: on reload we weren't updating the PrintUnqualified
+ -- correctly. This stems from the fact that the interface had
+ -- not changed, so addVersionInfo returns the old ModIface
+ -- with the old GlobalRdrEnv (mi_globals).
+ ; let final_iface = new_iface{ mi_globals = Just rdr_env }
+
+ ; return (final_iface, no_change_at_all) }
where
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
-----------------------------
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
- = do createDirectoryHierarchy (directoryOf hi_file_path)
+ = do createDirectoryHierarchy (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
SDoc, -- Differences
Maybe SDoc) -- Warnings about orphans
-addVersionInfo ver_fn Nothing new_iface new_decls
+addVersionInfo _ Nothing new_iface new_decls
-- No old interface, so definitely write a new one!
= (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
, mi_finsts = not . null $ mi_fam_insts new_iface
new_decls)
},
False,
- ptext SLIT("No old interface file"),
+ ptext (sLit "No old interface file"),
pprOrphans orph_insts orph_rules)
where
orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
new_iface@(ModIface { mi_fix_fn = new_fixities })
new_decls
| no_change_at_all
- = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs)
+ = (old_iface, True, ptext (sLit "Interface file unchanged"), pp_orphs)
| otherwise
- = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
+ = (final_iface, False, vcat [ptext (sLit "Interface file has changed"),
nest 2 pp_diffs], pp_orphs)
where
final_iface = new_iface {
pp_change no_deprec_change "Deprecations" empty,
pp_change no_other_changes "Usages" empty,
pp_decl_diffs]
- pp_change True what info = empty
- pp_change False what info = text what <+> ptext SLIT("changed") <+> info
+ pp_change True _ _ = empty
+ pp_change False what info = text what <+> ptext (sLit "changed") <+> info
-------------------
old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
= same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
- eq_indirects other = Equal -- Synonyms and foreign declarations
+ eq_indirects _ = Equal -- Synonyms and foreign declarations
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
eq_ind_occ occ = same_fixity occ &&& same_rules occ
pp_decl_diffs
| isEmptyOccSet changed_occs = empty
| otherwise
- = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs),
- ptext SLIT("Version change for these decls:"),
+ = vcat [ptext (sLit "Changed occs:") <+> ppr (occSetElts changed_occs),
+ ptext (sLit "Version change for these decls:"),
nest 2 (vcat (map show_change new_decls))]
eq_env = mkOccEnv eq_info
where
occ = ifName new_decl
why = case lookupOccEnv eq_env occ of
- Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names,
+ Just (EqBut names) -> sep [ppr occ <> colon, ptext (sLit "Free vars (only) changed:") <> ppr names,
nest 2 (braces (fsep (map ppr (occSetElts
(occs `intersectOccSet` changed_occs)))))]
where occs = mkOccSet (map nameOccName (nameSetToList names))
Just NotEqual
| Just old_decl <- lookupOccEnv old_decl_env occ
- -> vcat [ptext SLIT("Old:") <+> ppr old_decl,
- ptext SLIT("New:") <+> ppr new_decl]
+ -> vcat [ptext (sLit "Old:") <+> ppr old_decl,
+ ptext (sLit "New:") <+> ppr new_decl]
| otherwise
- -> ppr occ <+> ptext SLIT("only in new interface")
- other -> pprPanic "MkIface.show_change" (ppr occ)
+ -> ppr occ <+> ptext (sLit "only in new interface")
+ _ -> pprPanic "MkIface.show_change" (ppr occ)
pp_orphs = pprOrphans new_orph_insts new_orph_rules
+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:"))
+ hang (ptext (sLit "Warning: orphan instances:"))
2 (vcat (map ppr insts)),
if null rules then empty else
- hang (ptext SLIT("Warning: orphan rules:"))
+ hang (ptext (sLit "Warning: orphan rules:"))
2 (vcat (map ppr rules))
]
-- return True if an external name has changed
name_changed :: Name -> Bool
name_changed nm
- | Just ents <- lookupUFM usg_modmap (moduleName mod)
- = case lookupUFM ents parent_occ of
- Nothing -> pprPanic "computeChangedOccs" (ppr nm)
- Just v -> v < new_version
+ | isWiredInName nm -- Wired-in things don't get into interface
+ = False -- files and hence don't get into the ver_fn
+ | Just ents <- lookupUFM usg_modmap (moduleName mod),
+ Just v <- lookupUFM ents parent_occ
+ = v < new_version
+ | modulePackageId mod == this_pkg
+ = WARN(True, ptext (sLit "computeChangedOccs") <+> ppr nm) True
+ -- should really be a panic, see #1959. The problem is that the usages doesn't
+ -- contain all the names that might be referred to by unfoldings. So as a
+ -- conservative workaround we just assume these names have changed.
| otherwise = False -- must be in another package
where
mod = nameModule nm
(parent_occ, new_version) = ver_fn nm
+ this_pkg = modulePackageId this_module
+
-- Turn the usages from the old ModIface into a mapping
- usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg))
+ usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
| usg <- old_usages ]
- get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet
+ get_local_eq_info :: GenIfaceEq Name -> GenIfaceEq OccName
get_local_eq_info Equal = Equal
get_local_eq_info NotEqual = NotEqual
get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
| node@(occ, iface_eq) <- local_eq_infos
, let occs = case iface_eq of
EqBut occ_set -> occSetElts occ_set
- other -> [] ]
+ _ -> [] ]
-- Changes in declarations
add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet
-- One of this group has changed
= extendOccSetList so_far occs
where (occs, iface_eqs) = unzip pairs
- add_changes so_far other = so_far
+ add_changes so_far _ = so_far
-type OccIfaceEq = GenIfaceEq OccSet
+type OccIfaceEq = GenIfaceEq OccName
changedWrt :: OccSet -> OccIfaceEq -> Bool
-changedWrt so_far Equal = False
-changedWrt so_far NotEqual = True
+changedWrt _ Equal = False
+changedWrt _ NotEqual = True
changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
changedWrtNames :: OccSet -> IfaceEq -> Bool
-changedWrtNames so_far Equal = False
-changedWrtNames so_far NotEqual = True
+changedWrtNames _ Equal = False
+changedWrtNames _ NotEqual = True
changedWrtNames so_far (EqBut kids) =
so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids))
and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq
Equal `and_occifeq` x = x
-NotEqual `and_occifeq` x = NotEqual
+NotEqual `and_occifeq` _ = NotEqual
EqBut nms `and_occifeq` Equal = EqBut nms
-EqBut nms `and_occifeq` NotEqual = NotEqual
+EqBut _ `and_occifeq` NotEqual = NotEqual
EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2)
----------------------
| otherwise = (non_orphs, d:orphs)
----------------------
-mkIfaceDeprec :: Deprecations -> IfaceDeprecs
-mkIfaceDeprec NoDeprecs = NoDeprecs
-mkIfaceDeprec (DeprecAll t) = DeprecAll t
-mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env))
-
-----------------------
bump_unless :: Bool -> Version -> Version
bump_unless True v = v -- True <=> no change
bump_unless False v = bumpVersion v
-- Usually just one, but see Note [Original module]
add_for_mod env mod
- = add_one env mod (AvailTC tc_occ names_from_mod)
+ = add_one env mod (AvailTC tc_occ (sort names_from_mod))
+ -- NB. sort the children, we need a canonical order
where
names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
\end{code}
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
}
+check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
+ -> IfG (Bool, Maybe ModIface)
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
= do -- CHECK WHETHER THE SOURCE HAS CHANGED
- { ifM (not source_unchanged)
+ { when (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- If the source has changed and we're in interactive mode, avoid reading
-- We have got the old iface; check its versions
{ traceIf (text "Read the interface file" <+> text iface_path)
; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
- ; returnM (recomp, Just iface)
+ ; return (recomp, Just iface)
}}}}}
\end{code}
\begin{code}
type RecompileRequired = Bool
+upToDate, outOfDate :: Bool
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-> IfG RecompileRequired
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
- = returnM outOfDate
+ = return outOfDate
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ mod) = do
- find_res <- ioToIOEnv $ findImportedModule hsc_env mod Nothing
+ find_res <- liftIO $ findImportedModule hsc_env mod Nothing
case find_res of
Found _ mod
| pkg == this_pkg
usg_rules = old_rule_vers,
usg_exports = maybe_old_export_vers,
usg_entities = old_decl_vers })
- = -- Load the imported interface is possible
- let
- doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
- in
- traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
+ = do -- Load the imported interface is possible
+ let doc_str = sep [ptext (sLit "need version info for"), ppr mod_name]
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name)
- let
- mod = mkModule this_pkg mod_name
- in
- loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface ->
+ let mod = mkModule this_pkg mod_name
+
+ mb_iface <- loadInterface doc_str mod ImportBySystem
-- Load the interface, but don't complain on failure;
-- Instead, get an Either back which we can test
case mb_iface of {
- Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ Failed _ -> (out_of_date (sep [ptext (sLit "Can't find version number for module"),
ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
new_rule_vers = mi_rule_vers iface
in
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
+ checkModuleVersion old_mod_vers new_mod_vers >>= \ recompile ->
if not recompile then
- returnM upToDate
+ return upToDate
else
-- CHECK EXPORT LIST
if checkExportList maybe_old_export_vers new_export_vers then
- out_of_date_vers (ptext SLIT(" Export list changed"))
+ out_of_date_vers (ptext (sLit " Export list changed"))
(expectJust "checkModUsage" maybe_old_export_vers)
new_export_vers
else
-- CHECK RULES
if old_rule_vers /= new_rule_vers then
- out_of_date_vers (ptext SLIT(" Rules changed"))
+ out_of_date_vers (ptext (sLit " Rules changed"))
old_rule_vers new_rule_vers
else
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] >>= \ recompile ->
if recompile then
- returnM outOfDate -- This one failed, so just bail out now
+ return outOfDate -- This one failed, so just bail out now
else
- up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
+ up_to_date (ptext (sLit " Great! The bits I use are up to date"))
}
------------------------
+checkModuleVersion :: Version -> Version -> IfG Bool
checkModuleVersion old_mod_vers new_mod_vers
| new_mod_vers == old_mod_vers
- = up_to_date (ptext SLIT("Module version unchanged"))
+ = up_to_date (ptext (sLit "Module version unchanged"))
| otherwise
- = out_of_date_vers (ptext SLIT(" Module version has changed"))
+ = out_of_date_vers (ptext (sLit " Module version has changed"))
old_mod_vers new_mod_vers
------------------------
-checkExportList Nothing new_vers = upToDate
+checkExportList :: Maybe Version -> Version -> Bool
+checkExportList Nothing _ = upToDate
checkExportList (Just v) new_vers = v /= new_vers
------------------------
+checkEntityUsage :: (OccName -> Maybe (OccName, Version))
+ -> (OccName, Version)
+ -> IfG Bool
checkEntityUsage new_vers (name,old_vers)
= case new_vers name of
Nothing -> -- We used it before, but it ain't there now
- out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
+ out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
Just (_, new_vers) -- It's there, but is it up to date?
- | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
- returnM upToDate
- | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
+ | new_vers == old_vers -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers))
+ return upToDate
+ | otherwise -> out_of_date_vers (ptext (sLit " Out of date:") <+> ppr name)
old_vers new_vers
-up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
-out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+up_to_date, out_of_date :: SDoc -> IfG Bool
+up_to_date msg = traceHiDiffs msg >> return upToDate
+out_of_date msg = traceHiDiffs msg >> return outOfDate
+
+out_of_date_vers :: SDoc -> Version -> Version -> IfG Bool
out_of_date_vers msg old_vers new_vers
- = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
+ = out_of_date (hsep [msg, ppr old_vers, ptext (sLit "->"), ppr new_vers])
----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
-checkList [] = returnM upToDate
-checkList (check:checks) = check `thenM` \ recompile ->
- if recompile then
- returnM outOfDate
- else
- checkList checks
+checkList [] = return upToDate
+checkList (check:checks) = do recompile <- check
+ if recompile
+ then return outOfDate
+ else checkList checks
\end{code}
%************************************************************************
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+getFS :: NamedThing a => a -> FastString
getFS x = occNameFS (getOccName x)
--------------------------
instanceToIfaceInst :: Instance -> IfaceInst
-instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
- is_cls = cls_name, is_tcs = mb_tcs })
+instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
+ is_cls = cls_name, is_tcs = mb_tcs })
= ASSERT( cls_name == className cls )
IfaceInst { ifDFun = dfun_name,
ifOFlag = oflag,
-- that is not in the "determined" arguments
mb_ns | null fds = [choose_one arg_names]
| otherwise = map do_one fds
- do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
- , not (tv `elem` rtvs)]
+ do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
+ , not (tv `elem` rtvs)]
choose_one :: [NameSet] -> Maybe OccName
choose_one nss = case nameSetToList (unionManyNameSets nss) of
- [] -> Nothing
- (n:ns) -> Just (nameOccName n)
+ [] -> Nothing
+ (n : _) -> Just (nameOccName n)
--------------------------
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon,
- fi_fam = fam, fi_tcs = mb_tcs })
+famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
+ fi_fam = fam,
+ fi_tcs = mb_tcs })
= IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
, ifFamInstFam = fam
, ifFamInstTys = map do_rough mb_tcs }
do_rough (Just n) = Just (toIfaceTyCon_name n)
--------------------------
+toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
prag_info
------------ Worker --------------
work_info = workerInfo id_info
- has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
+ has_worker = workerExists work_info
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity ->
Just (HsWorker ((idName work_id)) wrap_arity)
--------------------------
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
-coreRuleToIfaceRule mod (BuiltinRule { ru_fn = fn})
+coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
-- exprsFreeNames finds only External names
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
- (n:ns) -> Just (nameOccName n)
- [] -> Nothing
+ (n : _) -> Just (nameOccName n)
+ [] -> Nothing
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
- = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
+ = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
---------------------
+toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
+toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
---------------------
+toIfaceAlt :: (AltCon, [Var], CoreExpr)
+ -> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
---------------------
+toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
| otherwise = IfaceDataAlt (getName dc)
where
toIfaceCon DEFAULT = IfaceDefault
---------------------
+toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
tup_args = map toIfaceExpr val_args
tc = dataConTyCon dc
- other -> mkIfaceApps (toIfaceVar v) as
+ _ -> mkIfaceApps (toIfaceVar v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
+mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
---------------------
projects / ghc-hetmet.git / blobdiff