import RdrName ( GlobalRdrEnv )
import NameSet
import VarSet
-import Bag ( Bag, isEmptyBag, emptyBag )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
-import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
- errorsFound, WarnMsg )
+import ErrUtils ( doIfSet, dumpIfSet_dyn )
import ListSetOps ( insertList )
import Outputable
-import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
%************************************************************************
\begin{code}
-deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
+deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
tcg_binds = binds,
tcg_fords = fords,
tcg_rules = rules,
- tcg_insts = insts })
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts })
= do { showPass dflags "Desugar"
-- Desugar the program
- ; ((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
; 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
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
-- sort to get into canonical order
mod_guts = ModGuts {
- 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_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 }
- ; return (warns, Just mod_guts)
- }}
+ ; return (Just mod_guts)
+ }}}
where
- dflags = hsc_dflags hsc_env
- ghci_mode = ghcMode (hsc_dflags hsc_env)
+ dflags = hsc_dflags hsc_env
+ ghci_mode = ghcMode (hsc_dflags hsc_env)
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
- -> IO CoreExpr
+ -> IO (Maybe CoreExpr)
+-- Prints its own errors; returns Nothing if error occurred
+
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
- = do { showPass dflags "Desugar"
- ; us <- mkSplitUniqSupply 'd'
+ = do { let dflags = hsc_dflags hsc_env
+ ; showPass dflags "Desugar"
-- Do desugaring
- ; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
- dsLExpr tc_expr
+ ; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
+ dsLExpr tc_expr
- -- 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 {
- -- Dump output
- ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
-
- ; return core_expr
- }
- where
- dflags = hsc_dflags hsc_env
+ -- Dump output
+ dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+ ; return (Just expr) } } }
-- addExportFlags
-- Set the no-discard flag if either
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
- Nothing -> do { dsWarn msg; return Nothing } ;
+ Nothing -> do { warnDs msg; return Nothing } ;
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
+
+ -- A rule is an orphan only if none of the variables
+ -- mentioned on its left-hand side are locally defined
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n:ns) -> Just (nameOccName n)
[] -> Nothing