Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263

42 files changed, 171 insertions, 117 deletions

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 5f3775b26f..b5a25f8bd9 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 1b60ed7193..c2c9b2ad89 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 263d0d4856..bc64ed6eae 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 39a4798ee4..17212bb3af 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 0fb90b0d77..532965c084 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 df3720cd2d..42d26662b9 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 f501be5941..14f5fb8269 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 1e9a5ba97b..af6b1ed311 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 bcb59ce032..6683de4c8b 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 ae4fa1b623..ee1983c34b 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 96b9e316c4..2a0716ed24 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 550c42de60..dbcb540751 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 2d45eb35d2..4e04e04980 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 8f3c343568..f28336b2c6 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 6abb66362e..65fe457f8f 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 64c1917cf9..98517ae15b 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 3d30c07f13..8ca0bfc289 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 95c8c91092..84bdfecf78 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 9bae01e84d..8b64c981d9 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 60647a6acc..72a62a66de 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 27f6cdda06..e468fe905b 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 400f8bdf0b..2aa1aa2ea9 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 5a7e78d860..d120f18d53 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 f4971cd7cd..394965a850 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 52ff90692c..76bbeb2760 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 12b12e350c..34e459386d 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 794459c458..44972d5d36 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 357616bfb9..26c85bdc2c 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 32d4c4c379..c459b70c5b 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 9e57f9f8f6..f2cecf9b01 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 18c61917c2..eae66a89e0 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 3814f239b6..4f1f32c0f9 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 ffd2893a5e..6120621095 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 bef5ec742b..376385aaa6 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 cf29748561..11e202be9b 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 63c13e35db..bbb76a4a23 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 e5e16fc392..743320554d 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 cbfec74cff..11f3b12317 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 c51c2329ca..3c7600515a 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 305e30eed7..b81b2e8fde 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 733eda1700..9b364aebb7 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 a49a68d623..4f78aabc24 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