From 9d0c8f842e35dde3d570580cf62a32779f66a6de Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Wed, 1 Jul 2009 20:03:44 +0000 Subject: [PATCH] Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263 --- compiler/cmm/CmmCPSZ.hs | 8 ++-- compiler/cmm/CmmLint.hs | 6 +-- compiler/cmm/DFMonad.hs | 3 +- compiler/cmm/ZipDataflow.hs | 12 ++--- compiler/codeGen/CgCon.lhs | 2 +- compiler/codeGen/CgHeapery.lhs | 2 +- compiler/codeGen/CgLetNoEscape.lhs | 2 +- compiler/codeGen/CgMonad.lhs | 5 +- compiler/codeGen/CgStackery.lhs | 12 ++--- compiler/codeGen/StgCmm.hs | 4 +- compiler/codeGen/StgCmmExpr.hs | 4 +- compiler/codeGen/StgCmmMonad.hs | 4 +- compiler/coreSyn/CoreLint.lhs | 18 ++++--- compiler/cprAnalysis/CprAnalyse.lhs | 1 + compiler/deSugar/DsExpr.lhs | 88 ++++++++++++++++++++++++++--------- compiler/ghci/Debugger.hs | 2 +- compiler/ghci/Linker.lhs | 2 +- compiler/ghci/RtClosureInspect.hs | 4 +- compiler/hsSyn/Convert.lhs | 7 +-- compiler/iface/BinIface.hs | 4 +- compiler/iface/LoadIface.lhs | 2 +- compiler/main/DriverMkDepend.hs | 2 +- compiler/main/DriverPipeline.hs | 6 +-- compiler/main/DynFlags.hs | 12 +++-- compiler/main/GHC.hs | 6 +-- compiler/main/HscMain.lhs | 2 +- compiler/main/InteractiveEval.hs | 2 +- compiler/main/SysTools.lhs | 4 +- compiler/rename/RnExpr.lhs | 4 +- compiler/stgSyn/StgLint.lhs | 2 +- compiler/typecheck/TcBinds.lhs | 4 +- compiler/typecheck/TcClassDcl.lhs | 2 +- compiler/typecheck/TcHsSyn.lhs | 2 +- compiler/typecheck/TcPat.lhs | 6 +-- compiler/typecheck/TcSimplify.lhs | 4 +- compiler/typecheck/TcSplice.lhs | 10 ++-- compiler/typecheck/TcUnify.lhs | 6 +-- compiler/utils/Binary.hs | 4 +- compiler/utils/Exception.hs | 6 +-- compiler/utils/IOEnv.hs | 2 +- compiler/utils/MonadUtils.hs | 6 ++- compiler/utils/Panic.lhs | 4 +- docs/users_guide/flags.xml | 14 ++++++ docs/users_guide/using.xml | 56 +++++++++++++++++++++- ghc/GhciMonad.hs | 7 ++- ghc/InteractiveUI.hs | 34 +++++++------- ghc/Main.hs | 2 +- utils/ghc-pkg/Main.hs | 10 ++-- utils/hpc/Main.hs | 2 +- 49 files changed, 266 insertions(+), 147 deletions(-) diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 5f3775b..b5a25f8 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -124,17 +124,17 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = dump Opt_D_dump_cmmz "procpoint map" procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l args (stackInfo, g)) - mapM (dump Opt_D_dump_cmmz "after splitting") gs + mapM_ (dump Opt_D_dump_cmmz "after splitting") gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs mbpprTrace "localCAFs" (ppr localCAFs) $ return () gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs - mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs + mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES let gs' = map (setInfoTableStackMap slotEnv areaMap) gs - mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' + mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' let gs'' = map (bundleCAFs cafEnv) gs' - mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' + mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' return (localCAFs, gs'') where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 1b60ed7..c2c9b2a 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -69,7 +69,7 @@ lintCmmBlock labels (BasicBlock id stmts) lintCmmExpr :: CmmExpr -> CmmLint CmmType lintCmmExpr (CmmLoad expr rep) = do - lintCmmExpr expr + _ <- lintCmmExpr expr when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ cmmCheckWordAddress expr return rep @@ -126,8 +126,8 @@ lintCmmStmt labels = lint then return () else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do - lintCmmExpr l - lintCmmExpr r + _ <- lintCmmExpr l + _ <- lintCmmExpr r return () lint (CmmCall target _res args _ _) = lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index 263d0d4..bc64ed6 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -167,8 +167,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where text "changed from", nest 4 (ppr old_a), text "to", nest 4 (ppr new), text "after supposedly reaching fixed point;", - text "env is", pprFacts facts]) - ; setFact id a } + text "env is", pprFacts facts]) } } where pprFacts env = vcat (map pprFact (blockEnvToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 39a4798..17212bb 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -505,7 +505,7 @@ forward_sol check_maybe = forw forw rewrite name start_facts transfers rewrites = let anal_f :: DFM a b -> a -> Graph m l -> DFM a b anal_f finish in' g = - do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish } + do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish } solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel) solve finish in_fact (Graph entry blockenv) fuel = @@ -609,7 +609,7 @@ forward_rew check_maybe = forw in_fact `seq` g `seq` let Graph entry blockenv = g blocks = G.postorder_dfs_from blockenv entry - in do { solve depth name start transfers rewrites in_fact g fuel + in do { _ <- solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel @@ -618,7 +618,7 @@ forward_rew check_maybe = forw ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } don't_rewrite facts finish in_fact g fuel = - do { solve depth name facts transfers rewrites in_fact g fuel + do { _ <- solve depth name facts transfers rewrites in_fact g fuel ; a <- finish ; return (a, g, fuel) } @@ -684,8 +684,8 @@ forward_rew check_maybe = forw either_last rewrites in' (LastOther l) = fr_last rewrites l in' check_facts in' (LastOther l) = let LastOutFacts last_outs = ft_last_outs transfers l in' - in mapM (uncurry checkFactMatch) last_outs - check_facts _ LastExit = return [] + in mapM_ (uncurry checkFactMatch) last_outs + check_facts _ LastExit = return () in fixed_pt_and_fuel lastOutFacts :: DFM f (LastOutFacts f) @@ -781,7 +781,7 @@ backward_sol check_maybe = back my_trace "analysis rewrites last node" (ppr l <+> pprGraph g') $ subsolve g exit_fact fuel - ; set_head_fact h a fuel + ; _ <- set_head_fact h a fuel ; return fuel } in do { fuel <- run "backward" name set_block_fact blocks fuel diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 0fb90b0..532965c 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -439,7 +439,7 @@ cgDataCon data_con = do { code_blks <- getCgStmts the_code ; emitClosureCodeAndInfoTable cl_info [] code_blks } where - the_code = do { ticky_code + the_code = do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; body_code } diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index df3720c..42d2666 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -78,7 +78,7 @@ initHeapUsage :: (VirtualHpOffset -> Code) -> Code initHeapUsage fcode = do { orig_hp_usage <- getHpUsage ; setHpUsage initHpUsage - ; fixC (\heap_usage2 -> do + ; fixC_(\heap_usage2 -> do { fcode (heapHWM heap_usage2) ; getHpUsage }) ; setHpUsage orig_hp_usage } diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index f501be5..14f5fb8 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -168,7 +168,7 @@ cgLetNoEscapeClosure -- Ignore the label that comes back from -- mkRetDirectTarget. It must be conjured up elswhere - ; emitReturnTarget (idName bndr) abs_c + ; _ <- emitReturnTarget (idName bndr) abs_c ; return () }) ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 1e9a5ba..af6b1ed 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -13,7 +13,7 @@ module CgMonad ( FCode, -- type initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, - returnFC, fixC, checkedAbsC, + returnFC, fixC, fixC_, checkedAbsC, stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC, newUnique, newUniqSupply, @@ -443,6 +443,9 @@ fixC fcode = FCode ( in result ) + +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () \end{code} %************************************************************************ diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index bcb59ce..6683de4 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -198,25 +198,23 @@ allocPrimStack rep Allocate a chunk ON TOP OF the stack. \begin{code} -allocStackTop :: WordOff -> FCode VirtualSpOffset +allocStackTop :: WordOff -> FCode () allocStackTop size = do { stk_usg <- getStkUsage ; let push_virt_sp = virtSp stk_usg + size ; setStkUsage (stk_usg { virtSp = push_virt_sp, - hwSp = hwSp stk_usg `max` push_virt_sp }) - ; return push_virt_sp } + hwSp = hwSp stk_usg `max` push_virt_sp }) } \end{code} Pop some words from the current top of stack. This is used for de-allocating the return address in a case alternative. \begin{code} -deAllocStackTop :: WordOff -> FCode VirtualSpOffset +deAllocStackTop :: WordOff -> FCode () deAllocStackTop size = do { stk_usg <- getStkUsage ; let pop_virt_sp = virtSp stk_usg - size - ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) - ; return pop_virt_sp } + ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) } \end{code} \begin{code} @@ -231,7 +229,7 @@ A knot-tying beast. \begin{code} getFinalStackHW :: (VirtualSpOffset -> Code) -> Code getFinalStackHW fcode - = do { fixC (\hw_sp -> do + = do { fixC_ (\hw_sp -> do { fcode hw_sp ; stk_usg <- getStkUsage ; return (hwSp stk_usg) }) diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index ae4fa1b..ee1983c 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -113,7 +113,7 @@ cgTopBinding dflags (StgRec pairs, _srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; fixC (\ new_binds -> do + ; fixC_(\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; return () } @@ -334,7 +334,7 @@ cgDataCon data_con mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) - do { ticky_code + do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) ; emitReturn [cmmOffsetB (CmmReg nodeReg) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 96b9e31..2a0716e 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -296,7 +296,7 @@ cgCase scrut bndr srt alt_type alts ; restoreCurrentCostCentre mb_cc -- JD: We need Note: [Better Alt Heap Checks] - ; bindArgsToRegs ret_bndrs + ; _ <- bindArgsToRegs ret_bndrs ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- @@ -408,7 +408,7 @@ cgAltRhss gc_plan bndr alts cg_alt (con, bndrs, _uses, rhs) = getCodeR $ maybeAltHeapCheck gc_plan $ - do { bindConArgs con base_reg bndrs + do { _ <- bindConArgs con base_reg bndrs ; cgExpr rhs ; return con } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 550c42d..dbcb540 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -10,7 +10,7 @@ module StgCmmMonad ( FCode, -- type initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, - returnFC, fixC, nopC, whenC, + returnFC, fixC, fixC_, nopC, whenC, newUnique, newUniqSupply, emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, @@ -149,6 +149,8 @@ fixC fcode = FCode ( result ) +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () -------------------------------------------------------- -- The code generator environment diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 2d45eb3..4e04e04 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -56,17 +56,17 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endPass = dumpAndLint dumpIfSet_core -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endPassIf cond = dumpAndLint (dumpIf_core cond) -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endIteration = dumpAndLint dumpIfSet_dyn dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] + -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () dumpAndLint dump dflags pass_name dump_flag binds = do -- Report result size if required @@ -79,8 +79,6 @@ dumpAndLint dump dflags pass_name dump_flag binds -- Type check lintCoreBindings dflags pass_name binds - - return binds \end{code} @@ -303,7 +301,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body) lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> - do { mapM (lintSingleBinding NotTopLevel Recursive) pairs + do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs @@ -353,7 +351,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = else lintAndScopeId var ; scope $ \_ -> do { -- Check the alternatives - mapM (lintCoreAlt scrut_ty alt_ty) alts + mapM_ (lintCoreAlt scrut_ty alt_ty) alts ; checkCaseAlts e scrut_ty alts ; return alt_ty } } where @@ -552,7 +550,7 @@ lintBinder var linterF | isTyVar var = lint_ty_bndr | otherwise = lintIdBndr var linterF where - lint_ty_bndr = do { lintTy (tyVarKind var) + lint_ty_bndr = do { _ <- lintTy (tyVarKind var) ; subst <- getTvSubst ; let (subst', tv') = substTyVarBndr subst var ; updateTvSubst subst' (linterF tv') } @@ -719,7 +717,7 @@ lookupIdInScope id = do { subst <- getTvSubst ; case lookupInScope (getTvInScope subst) id of Just v -> return v - Nothing -> do { addErrL out_of_scope + Nothing -> do { _ <- addErrL out_of_scope ; return id } } where out_of_scope = ppr id <+> ptext (sLit "is out of scope") diff --git a/compiler/cprAnalysis/CprAnalyse.lhs b/compiler/cprAnalysis/CprAnalyse.lhs index 8f3c343..f28336b 100644 --- a/compiler/cprAnalysis/CprAnalyse.lhs +++ b/compiler/cprAnalysis/CprAnalyse.lhs @@ -143,6 +143,7 @@ cprAnalyse dflags binds let { binds_plus_cpr = do_prog binds } ; endPass dflags "Constructed Product analysis" Opt_D_dump_cpranal binds_plus_cpr + return binds_plus_cpr } where do_prog :: [CoreBind] -> [CoreBind] diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6abb663..65fe457 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -61,6 +61,8 @@ import Util import Bag import Outputable import FastString + +import Control.Monad \end{code} @@ -662,23 +664,27 @@ dsDo :: [LStmt Id] -> DsM CoreExpr dsDo stmts body _result_ty - = go (map unLoc stmts) + = goL stmts where - go [] = dsLExpr body - - go (ExprStmt rhs then_expr _ : stmts) + goL [] = dsLExpr body + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts) + + go (ExprStmt rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs - ; then_expr2 <- dsExpr then_expr - ; rest <- go stmts + ; case tcSplitAppTy_maybe (exprType rhs2) of + Just (container_ty, returning_ty) -> warnDiscardedDoBindings container_ty returning_ty + _ -> return () + ; then_expr2 <- dsExpr then_expr + ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } - go (LetStmt binds : stmts) - = do { rest <- go stmts + go (LetStmt binds) stmts + = do { rest <- goL stmts ; dsLocalBinds binds rest } - go (BindStmt pat rhs bind_op fail_op : stmts) + go (BindStmt pat rhs bind_op fail_op) stmts = - do { body <- go stmts + do { body <- goL stmts ; rhs' <- dsLExpr rhs ; bind_op' <- dsExpr bind_op ; var <- selectSimpleMatchVarL pat @@ -719,8 +725,11 @@ dsMDo :: PostTcTable -> DsM CoreExpr dsMDo tbl stmts body result_ty - = go (map unLoc stmts) + = goL stmts where + goL [] = dsLExpr body + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) mfix_id = lookupEvidence tbl mfixName return_id = lookupEvidence tbl returnMName @@ -729,19 +738,18 @@ dsMDo tbl stmts body result_ty fail_id = lookupEvidence tbl failMName ctxt = MDoExpr tbl - go [] = dsLExpr body - - go (LetStmt binds : stmts) - = do { rest <- go stmts + go _ (LetStmt binds) stmts + = do { rest <- goL stmts ; dsLocalBinds binds rest } - go (ExprStmt rhs _ rhs_ty : stmts) + go _ (ExprStmt rhs _ rhs_ty) stmts = do { rhs2 <- dsLExpr rhs - ; rest <- go stmts + ; warnDiscardedDoBindings m_ty rhs_ty + ; rest <- goL stmts ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } - go (BindStmt pat rhs _ _ : stmts) - = do { body <- go stmts + go _ (BindStmt pat rhs _ _) stmts + = do { body <- goL stmts ; var <- selectSimpleMatchVarL pat ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat result_ty (cantFailMatchResult body) @@ -753,13 +761,13 @@ dsMDo tbl stmts body result_ty ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, rhs', Lam var match_code]) } - go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts) + go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts = ASSERT( length rec_ids > 0 ) ASSERT( length rec_ids == length rec_rets ) - go (new_bind_stmt : let_stmt : stmts) + goL (new_bind_stmt : let_stmt : stmts) where - new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app - let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) + new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) -- Remove the later_ids that appear (without fancy coercions) @@ -803,3 +811,37 @@ dsMDo tbl stmts body result_ty mk_ret_tup [r] = r mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed \end{code} + + +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + +\begin{code} +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: Type -> Type -> DsM () +warnDiscardedDoBindings container_ty returning_ty = do + -- Warn about discarding non-() things in 'monadic' binding + warn_unused <- doptDs Opt_WarnUnusedDoBind + when (warn_unused && not (returning_ty `tcEqType` unitTy)) $ + warnDs (unusedMonadBind returning_ty) + + -- Warn about discarding m a things in 'monadic' binding of the same type + warn_wrong <- doptDs Opt_WarnWrongDoBind + case tcSplitAppTy_maybe returning_ty of + Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ + warnDs (wrongMonadBind returning_ty) + _ -> return () + +unusedMonadBind :: Type -> SDoc +unusedMonadBind returning_ty + = ptext (sLit "A do-notation statement threw away a result of a type which appears to contain something other than (), namely") <+> ppr returning_ty <> + ptext (sLit ". You can suppress this warning by explicitly binding the result to _") + +wrongMonadBind :: Type -> SDoc +wrongMonadBind returning_ty + = ptext (sLit "A do-notation statement threw away a result of a type that like a monadic action waiting to execute, namely") <+> ppr returning_ty <> + ptext (sLit ". You can suppress this warning by explicitly binding the result to _") +\end{code} diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 64c1917..98517ae 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -171,7 +171,7 @@ showTerm term = do -- with the changed error handling and logging? let noop_log _ _ _ _ = return () expr = "show " ++ showSDoc (ppr bname) - GHC.setSessionDynFlags dflags{log_action=noop_log} + _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLinkEnv [(bname, val)] (GHC.compileExpr expr) let myprec = 10 -- application precedence. TODO Infix constructors diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3d30c07..8ca0bfc 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -744,7 +744,7 @@ dynLinkObjs dflags objs pls1 = pls { objs_loaded = objs_loaded' } unlinkeds = concatMap linkableUnlinked new_objs - mapM loadObj (map nameOfObject unlinkeds) + mapM_ loadObj (map nameOfObject unlinkeds) -- Link the all together ok <- resolveObjs diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 95c8c91..84bdfec 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -856,7 +856,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do (ty_tvs, _, _) <- tcInstType return ty (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty) - getLIE(boxyUnify rtti_ty' ty') + _ <- getLIE(boxyUnify rtti_ty' ty') tvs1_contents <- zonkTcTyVars ty_tvs' let subst = (uncurry zipTopTvSubst . unzip) [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents @@ -1096,7 +1096,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') text " in presence of newtype evidence " <> ppr new_tycon) vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars - liftTcM (boxyUnify ty (repType ty')) + _ <- liftTcM (boxyUnify ty (repType ty')) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 9bae01e..8b64c98 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -83,8 +83,8 @@ instance Monad CvtM where initCvt :: SrcSpan -> CvtM a -> Either Message a initCvt loc (CvtM m) = m loc -force :: a -> CvtM a -force a = a `seq` return a +force :: a -> CvtM () +force a = a `seq` return () failWith :: Message -> CvtM a failWith m = CvtM (\_ -> Left full_msg) @@ -817,9 +817,10 @@ tconName n = cvtName OccName.tcClsName n cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName ctxt_ns (TH.Name occ flavour) | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) - | otherwise = force (thRdrName ctxt_ns occ_str flavour) + | otherwise = force rdr_name >> return rdr_name where occ_str = TH.occString occ + rdr_name = thRdrName ctxt_ns occ_str flavour okOcc :: OccName.NameSpace -> String -> Bool okOcc _ [] = False diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 60647a6..72a62a6 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -149,7 +149,7 @@ writeBinIface dflags hi_path mod_iface = do -- The version and way descriptor go next put_ bh (show opt_HiVersion) way_descr <- getWayDescr - put bh way_descr + put_ bh way_descr -- Remember where the symbol table pointer will go symtab_p_p <- tellBin bh @@ -681,7 +681,7 @@ instance (Binary name) => Binary (IPName name) where instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType - put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p) + put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p) get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr) instance Binary Demand where diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 27f6cdd..e468fe9 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -131,7 +131,7 @@ loadInterfaceForName doc name loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) - do loadSysInterface doc (nameModule name); return () + do _ <- loadSysInterface doc (nameModule name); return () where doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 400f8bd..2aa1aa2 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -73,7 +73,7 @@ doMkDependHS srcs = do -- and complaining about cycles hsc_env <- getSession root <- liftIO getCurrentDirectory - mapM (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted -- If -ddump-mod-cycles, show cycles in the module graph liftIO $ dumpModCycles dflags mod_summaries diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5a7e78d..d120f18 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -187,7 +187,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -> return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. _other - -> do runPipeline StopLn hsc_env' (output_fn,Nothing) + -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) @@ -264,7 +264,7 @@ compileStub hsc_env mod location = do let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location - runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing (SpecificFile stub_o) Nothing{-no ModLocation-} return stub_o @@ -1234,7 +1234,7 @@ runPhase_MoveBinary dflags input_fn dep_packages pvm_executable_base = "=" ++ input_fn pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base -- nuke old binary; maybe use configur'ed names for cp and rm? - tryIO (removeFile pvm_executable) + _ <- tryIO (removeFile pvm_executable) -- move the newly created binary into PVM land copy dflags "copying PVM executable" input_fn pvm_executable -- generate a wrapper script for running a parallel prg under PVM diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f4971cd..394965a 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,4 +1,3 @@ - -- | -- Dynamic flags -- @@ -192,6 +191,9 @@ data DynFlag | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports | Opt_WarnLazyUnliftedBindings + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + -- language opts | Opt_OverlappingInstances @@ -909,7 +911,8 @@ standardWarnings Opt_WarnMissingMethods, Opt_WarnDuplicateExports, Opt_WarnLazyUnliftedBindings, - Opt_WarnDodgyForeignImports + Opt_WarnDodgyForeignImports, + Opt_WarnWrongDoBind ] minusWOpts :: [DynFlag] @@ -929,7 +932,8 @@ minusWallOpts Opt_WarnNameShadowing, Opt_WarnMissingSigs, Opt_WarnHiShadows, - Opt_WarnOrphans + Opt_WarnOrphans, + Opt_WarnUnusedDoBind ] -- minuswRemovesOpts should be every warning option @@ -1664,6 +1668,8 @@ fFlags = [ ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, const Supported ), ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, const $ Deprecated "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"), + ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, const Supported ), + ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, const Supported ), ( "print-explicit-foralls", Opt_PrintExplicitForalls, const Supported ), ( "strictness", Opt_Strictness, const Supported ), ( "static-argument-transformation", Opt_StaticArgumentTransformation, const Supported ), diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 52ff906..76bbeb2 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -784,7 +784,7 @@ load2 how_much mod_graph = do (flattenSCCs mg2_with_srcimps) stable_mods - liftIO $ evaluate pruned_hpt + _ <- liftIO $ evaluate pruned_hpt -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, @@ -1208,7 +1208,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing hscWriteIface iface changed modSummary - hscGenHardCode cgguts modSummary + _ <- hscGenHardCode cgguts modSummary return () -- Makes a "vanilla" ModGuts. @@ -1242,7 +1242,7 @@ compileCore simplify fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget target - load LoadAllTargets + _ <- load LoadAllTargets -- Then find dependencies modGraph <- depanal [] True case find ((== fn) . msHsFilePath) modGraph of diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 12b12e3..34e4593 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -773,7 +773,7 @@ hscCmmFile hsc_env filename = do parseCmmFile dflags filename cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] rawCmms <- liftIO $ cmmToRawCmm cmms - liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms + _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where no_mod = panic "hscCmmFile: no_mod" diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 794459c..44972d5 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -308,7 +308,7 @@ traceRunStatus expr bindings final_ids let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - liftIO $ evaluate history' + _ <- liftIO $ evaluate history' status <- withBreakAction True (hsc_dflags hsc_env) breakMVar statusMVar $ do diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 357616b..26c85bd 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -608,8 +608,8 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do -- and run a loop piping the output from the compiler to the log_action in DynFlags hSetBuffering hStdOut LineBuffering hSetBuffering hStdErr LineBuffering - forkIO (readerProc chan hStdOut filter_fn) - forkIO (readerProc chan hStdErr filter_fn) + _ <- forkIO (readerProc chan hStdOut filter_fn) + _ <- forkIO (readerProc chan hStdErr filter_fn) -- we don't want to finish until 2 streams have been completed -- (stdout and stderr) -- nor until 1 exit code has been retrieved. diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 32d4c4c..c459b70 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -569,7 +569,7 @@ rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) rnBracket (VarBr n) = do { name <- lookupOccRn n ; this_mod <- getModule ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { loadInterfaceForName msg name -- home interface is loaded, and this is the + do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the ; return () } -- only way that is going to happen ; return (VarBr name, unitFV name) } where @@ -794,7 +794,7 @@ rnParallelStmts ctxt segs thing_inside = do let (bndrs', dups) = removeDups cmpByOcc bndrs inner_env = extendLocalRdrEnv orig_lcl_env bndrs' - mapM dupErr dups + mapM_ dupErr dups (thing, fvs) <- setLocalRdrEnv inner_env thing_inside return (([], thing), fvs) diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 9e57f9f..f2cecf9 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -191,7 +191,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do lintStgExpr (StgSCC _ expr) = lintStgExpr expr lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do - MaybeT $ lintStgExpr scrut + _ <- MaybeT $ lintStgExpr scrut MaybeT $ liftM Just $ case alts_type of diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 18c6191..eae66a8 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -807,7 +807,7 @@ unifyCtxts :: [TcSigInfo] -> TcM [Inst] -- Post-condition: the returned Insts are full zonked unifyCtxts [] = panic "unifyCtxts []" unifyCtxts (sig1 : sigs) -- Argument is always non-empty - = do { mapM unify_ctxt sigs + = do { mapM_ unify_ctxt sigs ; theta <- zonkTcThetaType (sig_theta sig1) ; newDictBndrs (sig_loc sig1) theta } where @@ -866,7 +866,7 @@ checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] checkDistinctTyVars sig_tvs = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs - ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) + ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) ; return zonked_tvs } where check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 3814f23..4f1f32c 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -452,7 +452,7 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) group `lengthExceeds` 1] get_uniq (tc,_) = getUnique tc - mapM (addErrTc . dupGenericInsts) bad_groups + mapM_ (addErrTc . dupGenericInsts) bad_groups -- Check that there is an InstInfo for each generic type constructor let diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ffd2893..6120621 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1071,7 +1071,7 @@ mkArbitraryType warn tv , isLiftedTypeKind res -- Horrible hack to make less use = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon | otherwise - = do { warn (getSrcSpan tv) msg + = do { _ <- warn (getSrcSpan tv) msg ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } -- Same name as the tyvar, apart from making it start with a colon (sigh) -- I dread to think what will happen if this gets out into an diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index bef5ec7..376385a 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -181,7 +181,7 @@ tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty | Just mono_ty <- lookup_sig bndr_name = do { mono_name <- newLocalName bndr_name - ; boxyUnify mono_ty pat_ty + ; _ <- boxyUnify mono_ty pat_ty ; return (Id.mkLocalId mono_name mono_ty) } | otherwise @@ -238,7 +238,7 @@ unBoxArgType ty pp_this return ty' else do -- OpenTypeKind, so constrain it { ty2 <- newFlexiTyVarTy argTypeKind - ; unifyType ty' ty2 + ; _ <- unifyType ty' ty2 ; return ty' }} where msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple") @@ -373,7 +373,7 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside -- Check that the pattern has a lifted type ; pat_tv <- newBoxyTyVar liftedTypeKind - ; boxyUnify pat_ty (mkTyVarTy pat_tv) + ; _ <- boxyUnify pat_ty (mkTyVarTy pat_tv) ; return (LazyPat pat', [], res) } diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index cf29748..11e202b 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1637,7 +1637,7 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = do { tryHardCheckLoop doc wanteds + = do { _ <- tryHardCheckLoop doc wanteds ; return () } where doc = text "tcSimplifyBracket" @@ -2906,7 +2906,7 @@ disambigGroup default_tys dicts = do { mb_chosen_ty <- try_default default_tys ; case mb_chosen_ty of Nothing -> return () - Just chosen_ty -> do { unifyType chosen_ty (mkTyVarTy tyvar) + Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) ; warnDefault dicts chosen_ty } } where (_,_,tyvar) = ASSERT(not (null dicts)) head dicts -- Should be non-empty diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 63c13e3..bbb76a4 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -233,7 +233,7 @@ tcBracket brack res_ty ; tcSimplifyBracket lie -- Make the expected type have the right shape - ; boxyUnify meta_ty res_ty + ; _ <- boxyUnify meta_ty res_ty -- Return the original expression, not the type-decorated one ; pendings <- readMutVar pending_splices @@ -257,17 +257,17 @@ tc_bracket use_lvl (VarBr name) -- Note [Quoting names] tc_bracket _ (ExpBr expr) = do { any_ty <- newFlexiTyVarTy liftedTypeKind - ; tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that + ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that ; tcMetaTy expQTyConName } -- Result type is Expr (= Q Exp) tc_bracket _ (TypBr typ) - = do { tcHsSigTypeNC ThBrackCtxt typ + = do { _ <- tcHsSigTypeNC ThBrackCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) tc_bracket _ (DecBr decls) - = do { tcTopSrcDecls emptyModDetails decls + = do { _ <- tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -312,7 +312,7 @@ tcSpliceExpr (HsSplice name expr) res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - unBox res_ty + _ <- unBox res_ty meta_exp_ty <- tcMetaTy expQTyConName expr' <- setStage (Splice next_level) ( setLIEVar lie_var $ diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index e5e16fc..7433205 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -1039,8 +1039,8 @@ lists, when all the elts should be of the same type. unifyTypeList :: [TcTauType] -> TcM () unifyTypeList [] = return () unifyTypeList [_] = return () -unifyTypeList (ty1:tys@(ty2:_)) = do { unifyType ty1 ty2 - ; unifyTypeList tys } +unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2 + ; unifyTypeList tys } \end{code} %************************************************************************ @@ -1681,7 +1681,7 @@ zapToMonotype :: BoxySigmaType -> TcM TcTauType -- with that type. zapToMonotype res_ty = do { res_tau <- newFlexiTyVarTy liftedTypeKind - ; boxyUnify res_tau res_ty + ; _ <- boxyUnify res_tau res_ty ; return res_tau } unBox :: BoxyType -> TcM TcType diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index cbfec74..11f3b12 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -146,11 +146,11 @@ class Binary a where -- define one of put_, put. Use of put_ is recommended because it -- is more likely that tail-calls can kick in, and we rarely need the -- position return value. - put_ bh a = do put bh a; return () + put_ bh a = do _ <- put bh a; return () put bh a = do p <- tellBin bh; put_ bh a; return p putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put bh x; return () +putAt bh p x = do seekBin bh p; put_ bh x; return () getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index c51c232..3c76005 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -62,13 +62,13 @@ class Monad m => ExceptionMonad m where gblock (do a <- before r <- gunblock (thing a) `gonException` after a - after a + _ <- after a return r) a `gfinally` sequel = gblock (do r <- gunblock a `gonException` sequel - sequel + _ <- sequel return r) instance ExceptionMonad IO where @@ -89,6 +89,6 @@ ghandle = flip gcatch -- second argument is executed and the exception is raised again. gonException :: (ExceptionMonad m) => m a -> m b -> m a gonException ioA cleanup = ioA `gcatch` \e -> - do cleanup + do _ <- cleanup throw (e :: SomeException) diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 305e30e..b81b2e8 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -66,7 +66,7 @@ thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; unIOEnv (f r) env }) thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b -thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env }) +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) failM :: IOEnv env a failM = IOEnv (\ _ -> throwIO IOEnvFailure) diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 733eda1..9b364ae 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -18,7 +18,7 @@ module MonadUtils , concatMapM , mapMaybeM , anyM, allM - , foldlM, foldrM + , foldlM, foldlM_, foldrM , maybeMapM ) where @@ -146,6 +146,10 @@ allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a foldlM = foldM +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ = foldM_ + -- | Monadic version of foldr foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a foldrM _ z [] = return z diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index a49a68d..4f78aab 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -190,8 +190,8 @@ installSignalHandlers = do (thread:_) -> throwTo thread interrupt_exn -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing return () #else -- GHC 6.3+ has support for console events on Windows diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 978ddf7..f96edbf 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1175,6 +1175,20 @@ + + + warn about do bindings that appear to throw away values of types other than () + dynamic + + + + + + warn about do bindings that appear to throw away monadic values that you should have bound instead + dynamic + + + diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 478a6bc..024a4e7 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -845,7 +845,8 @@ ghc -c Foo.hs , , , - , and + , + , and . The following flags are simple ways to select standard “packages” of warnings: @@ -877,7 +878,8 @@ ghc -c Foo.hs , , , - , and + , + , and . @@ -1365,6 +1367,56 @@ f "2" = 2 + + : + + + unused do binding, warning + do binding, unused + + Report expressions occuring in do and mdo blocks + that appear to silently throw information away. + For instance do { mapM popInt xs ; return 10 } would report + the first statement in the do block as suspicious, + as it has the type StackM [Int] and not StackM (), but that + [Int] value is not bound to anything. The warning is suppressed by + explicitly mentioning in the source code that your program is throwing something away: + + do { _ <- mapM popInt xs ; return 10 } + + Of course, in this particular situation you can do even better: + + do { mapM_ popInt xs ; return 10 } + + + + + + + : + + + apparently erroneous do binding, warning + do binding, apparently erroneous + + Report expressions occuring in do and mdo blocks + that appear to lack a binding. + For instance do { return (popInt 10) ; return 10 } would report + the first statement in the do block as suspicious, + as it has the type StackM (StackM Int) (which consists of two nested applications + of the same monad constructor), but which is not then "unpacked" by binding the result. + The warning is suppressed by explicitly mentioning in the source code that your program is throwing something away: + + do { _ <- return (popInt 10) ; return 10 } + + For almost all sensible programs this will indicate a bug, and you probably intended to write: + + do { popInt 10 ; return 10 } + + + + + If you're feeling really paranoid, the diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index ff34963..fb76d47 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -262,7 +262,7 @@ setLogAction :: InputT GHCi () setLogAction = do encoder <- getEncoder dflags <- GHC.getSessionDynFlags - GHC.setSessionDynFlags dflags {log_action = logAction encoder} + _ <- GHC.setSessionDynFlags dflags {log_action = logAction encoder} return () where logAction encoder severity srcSpan style msg = case severity of @@ -369,9 +369,8 @@ initInterpBuffering = do -- make sure these are linked let f ref (Just ptr) = writeIORef ref ptr f _ Nothing = panic "interactiveUI:setBuffering2" - zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] - [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] - return () + zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] flushInterpBuffers :: GHCi () flushInterpBuffers diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 8eb94f1..1c84846 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -311,9 +311,9 @@ interactiveUI srcs maybe_exprs = do -- it refers to might be finalized, including the standard Handles. -- This sounds like a bug, but we don't have a good solution right -- now. - liftIO $ newStablePtr stdin - liftIO $ newStablePtr stdout - liftIO $ newStablePtr stderr + _ <- liftIO $ newStablePtr stdin + _ <- liftIO $ newStablePtr stdout + _ <- liftIO $ newStablePtr stderr -- Initialise buffering for the *interpreted* I/O system initInterpBuffering @@ -620,7 +620,7 @@ runOneCommand eh getCmd = do -- QUESTION: is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion + doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion return False enqueueCommands :: [String] -> GHCi () @@ -641,7 +641,7 @@ runStmt stmt step -- are really two stdin Handles. So we flush any bufferred data in -- GHCi's stdin Handle here (only relevant if stdin is attached to -- a file, otherwise the read buffer can't be flushed). - liftIO $ IO.try $ hFlushAll stdin + _ <- liftIO $ IO.try $ hFlushAll stdin #endif result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result @@ -875,7 +875,7 @@ changeDirectory dir = do outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" prev_context <- GHC.getContext GHC.setTargets [] - GHC.load LoadAllTargets + _ <- GHC.load LoadAllTargets lift $ setContextAfterLoad prev_context False [] GHC.workingDirectoryChanged dir <- expandPath dir @@ -894,7 +894,7 @@ editFile str = let cmd = editor st when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") - io $ system (cmd ++ ' ':file) + _ <- io $ system (cmd ++ ' ':file) return () -- The user didn't specify a file so we pick one for them. @@ -989,17 +989,17 @@ loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) loadModule_ :: [FilePath] -> InputT GHCi () -loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () +loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return () loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule' files = do prev_context <- GHC.getContext -- unload first - GHC.abandonAll + _ <- GHC.abandonAll lift discardActiveBreakPoints GHC.setTargets [] - GHC.load LoadAllTargets + _ <- GHC.load LoadAllTargets let (filenames, phases) = unzip files exp_filenames <- mapM expandPath filenames @@ -1036,7 +1036,7 @@ checkModule m = do reloadModule :: String -> InputT GHCi () reloadModule m = do prev_context <- GHC.getContext - doLoad True prev_context $ + _ <- doLoad True prev_context $ if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) return () @@ -1454,7 +1454,7 @@ newDynFlags minus_opts = do when (packageFlags dflags /= pkg_flags) $ do io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." GHC.setTargets [] - GHC.load LoadAllTargets + _ <- GHC.load LoadAllTargets io (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context setContextAfterLoad ([],[]) False [] @@ -1798,7 +1798,7 @@ pprintCommand bind force str = do stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep -stepCmd expression = do runStmt expression GHC.SingleStep; return () +stepCmd expression = runStmt expression GHC.SingleStep >> return () stepLocalCmd :: String -> GHCi () stepLocalCmd [] = do @@ -1836,7 +1836,7 @@ enclosingTickSpan mod src = do traceCmd :: String -> GHCi () traceCmd [] = doContinue (const True) GHC.RunAndLogSteps -traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return () +traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion @@ -1845,7 +1845,7 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do runResult <- resume pred step - afterRunStmt pred runResult + _ <- afterRunStmt pred runResult return () abandonCmd :: String -> GHCi () @@ -2231,7 +2231,7 @@ lookupModule modName discardActiveBreakPoints :: GHCi () discardActiveBreakPoints = do st <- getGHCiState - mapM (turnOffBreak.snd) (breaks st) + mapM_ (turnOffBreak.snd) (breaks st) setGHCiState $ st { breaks = [] } deleteBreak :: Int -> GHCi () @@ -2243,7 +2243,7 @@ deleteBreak identity = do then printForUser (text "Breakpoint" <+> ppr identity <+> text "does not exist") else do - mapM (turnOffBreak.snd) this + mapM_ (turnOffBreak.snd) this setGHCiState $ st { breaks = rest } turnOffBreak :: BreakLocation -> GHCi Bool diff --git a/ghc/Main.hs b/ghc/Main.hs index bdf9e63..c078cdb 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -164,7 +164,7 @@ main = liftIO $ showBanner cli_mode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags dflags2 + _ <- GHC.setSessionDynFlags dflags2 dflags3 <- GHC.getSessionDynFlags hsc_env <- GHC.getSession diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index d5baf9f..5f6f0b9 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -360,7 +360,7 @@ parseGlobPackageId = parse +++ (do n <- parse - string "-*" + _ <- string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -506,7 +506,7 @@ readParseDatabase mb_user_conf filename | otherwise = do str <- readFile filename let packages = map convertPackageInfoIn $ read str - Exception.evaluate packages + _ <- Exception.evaluate packages `catchError` \e-> die ("error while parsing " ++ filename ++ ": " ++ show e) return (filename,packages) @@ -813,7 +813,7 @@ checkConsistency my_flags = do else do when (not simple_output) $ do reportError ("There are problems in package " ++ display (package p) ++ ":") - reportValidateErrors es " " Nothing + _ <- reportValidateErrors es " " Nothing return () return [p] @@ -1247,8 +1247,8 @@ installSignalHandlers = do (Exception.ErrorCall "interrupted") -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing return () #elif __GLASGOW_HASKELL__ >= 603 -- GHC 6.3+ has support for console events on Windows diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs index da859d0..419a519 100644 --- a/utils/hpc/Main.hs +++ b/utils/hpc/Main.hs @@ -56,7 +56,7 @@ dispatch (txt:args0) = do case getOpt Permute (options plugin []) args of (_,_,errs) | not (null errs) -> do putStrLn "hpc failed:" - sequence [ putStr (" " ++ err) + sequence_ [ putStr (" " ++ err) | err <- errs ] putStrLn $ "\n" -- 1.7.10.4