import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
-import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS )
+import Module
+import UniqFM ( eltsUFM, delFromUFM )
+import PackageConfig ( thPackageId )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
-import Packages ( PackageState(thPackageId), PackageIdH(..) )
-import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
- errorsFound, WarnMsg )
+import ErrUtils ( doIfSet, dumpIfSet_dyn )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
- ; ((all_prs, ds_rules, ds_fords), warns)
- <- case ghcMode (hsc_dflags hsc_env) of
- JustTypecheck -> return (([], [], NoStubs), emptyBag)
+ ; mb_res <- case ghcMode dflags of
+ JustTypecheck -> return (Just ([], [], NoStubs))
_ -> initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
_ -> initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords)
}
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords)
}
-
- -- If warnings are considered errors, leave.
- ; if errorsFound dflags (warns, emptyBag)
- then return (warns, Nothing)
- else do
+ ; case mb_res of {
+ Nothing -> return Nothing ;
+ Just (all_prs, ds_rules, ds_fords) -> do
; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
; th_used <- readIORef th_var -- Whether TH is used
; let used_names = allUses dus `unionNameSets` dfun_uses
; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
; th_used <- readIORef th_var -- Whether TH is used
; let used_names = allUses dus `unionNameSets` dfun_uses
- thPackage = thPackageId (pkgState dflags)
- pkgs | ExtPackage th_id <- thPackage, th_used
- = insertList th_id (imp_dep_pkgs imports)
- | otherwise
- = imp_dep_pkgs imports
+ pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs imports
-- 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
-- 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
; let
-- Modules don't compare lexicographically usually,
-- but we want them to do so here.
le_mod :: Module -> Module -> Bool
; let
-- Modules don't compare lexicographically usually,
-- but we want them to do so here.
le_mod :: Module -> Module -> Bool
- le_mod m1 m2 = moduleFS m1 <= moduleFS m2
- le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool
- le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
+ 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
deps = Deps { dep_mods = sortLe le_dep_mod dep_mods,
dep_pkgs = sortLe (<=) pkgs,
deps = Deps { dep_mods = sortLe le_dep_mod dep_mods,
dep_pkgs = sortLe (<=) pkgs,
- mg_module = mod,
- mg_boot = isHsBoot hsc_src,
- mg_exports = exports,
- mg_deps = deps,
- mg_home_mods = home_mods,
- mg_usages = usages,
- mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
- mg_rdr_env = rdr_env,
- mg_fix_env = fix_env,
- mg_deprecs = deprecs,
- mg_types = type_env,
- mg_insts = insts,
- mg_rules = ds_rules,
- mg_binds = ds_binds,
- mg_foreign = ds_fords }
+ mg_module = mod,
+ mg_boot = isHsBoot hsc_src,
+ mg_exports = exports,
+ mg_deps = deps,
+ mg_usages = usages,
+ mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = deprecs,
+ mg_types = type_env,
+ mg_insts = insts,
+ mg_fam_insts = fam_insts,
+ mg_rules = ds_rules,
+ mg_binds = ds_binds,
+ mg_foreign = ds_fords }
- -- Display any warnings
- -- Note: if -Werror is used, we don't signal an error here.
- ; doIfSet (not (isEmptyBag ds_warns))
- (printBagOfWarnings dflags ds_warns)
+ ; case mb_core_expr of {
+ Nothing -> return Nothing ;
+ Just expr -> do {
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly,
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly,
lhs_names = fn_name : nameSetToList (exprsFreeNames args)
-- No need to delete bndrs, because
-- exprsFreeNames finds only External names
lhs_names = fn_name : nameSetToList (exprsFreeNames args)
-- No need to delete bndrs, because
-- exprsFreeNames finds only External names