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

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

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

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)

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

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 }
 

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 }

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) }

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}
 
 %************************************************************************

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) })

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)

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 }
 

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

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")

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]

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}

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

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

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'
 

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

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