Remove use of lambda with a refutable pattern

6 files changed, 41 insertions, 40 deletions

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 9330c7125b..7d6bc234f7 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1308,7 +1308,7 @@ mkMultiBranch maybe_ncons raw_ways
             = return (snd val)
             | otherwise
             = do label_neq <- getLabelBc
-                 return (mkTestEQ (fst val) label_neq 
+                 return (testEQ (fst val) label_neq 
    			  `consOL` (snd val
    			  `appOL`   unitOL (LABEL label_neq)
                           `appOL`   the_default))
@@ -1322,7 +1322,7 @@ mkMultiBranch maybe_ncons raw_ways
               label_geq <- getLabelBc
               code_lo <- mkTree vals_lo range_lo (dec v_mid)
               code_hi <- mkTree vals_hi v_mid range_hi
-              return (mkTestLT v_mid label_geq
+              return (testLT v_mid label_geq
                         `consOL` (code_lo
 			`appOL`   unitOL (LABEL label_geq)
 			`appOL`   code_hi))
@@ -1332,34 +1332,32 @@ mkMultiBranch maybe_ncons raw_ways
                             [(_, def)] -> def
                             _ -> panic "mkMultiBranch/the_default"
 
+         testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+         testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+         testLT (DiscrF i) fail_label = TESTLT_F i fail_label
+         testLT (DiscrD i) fail_label = TESTLT_D i fail_label
+         testLT (DiscrP i) fail_label = TESTLT_P i fail_label
+         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"
+
+         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
+         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
+         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
+         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"
+
          -- None of these will be needed if there are no non-default alts
-         (mkTestLT, mkTestEQ, init_lo, init_hi)
+         (init_lo, init_hi)
             | null notd_ways
             = panic "mkMultiBranch: awesome foursome"
             | otherwise
-            = case fst (head notd_ways) of {
-              DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
-                            \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
-                            DiscrI minBound,
-                            DiscrI maxBound );
-              DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label,
-                            \(DiscrW i) fail_label -> TESTEQ_W i fail_label,
-                            DiscrW minBound,
-                            DiscrW maxBound );
-              DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
-                            \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
-                            DiscrF minF,
-                            DiscrF maxF );
-              DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
-                            \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
-                            DiscrD minD,
-                            DiscrD maxD );
-              DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
-                            \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
-                            DiscrP algMinBound,
-                            DiscrP algMaxBound );
-              NoDiscr -> panic "mkMultiBranch NoDiscr"
-              }
+            = case fst (head notd_ways) of
+              	DiscrI _ -> ( DiscrI minBound, 	DiscrI maxBound )
+              	DiscrW _ -> ( DiscrW minBound, 	DiscrW maxBound )
+              	DiscrF _ -> ( DiscrF minF,     	DiscrF maxF )
+              	DiscrD _ -> ( DiscrD minD,     	DiscrD maxD )
+              	DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+              	NoDiscr -> panic "mkMultiBranch NoDiscr"
 
          (algMinBound, algMaxBound)
             = case maybe_ncons of
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index fa167e32ba..ef25ad5644 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -426,7 +426,7 @@ cPprTermBase y =
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
-           (\ p Term{subTerms=[h,t]} -> doList p h t)
+           (\ p t -> doList p t)
   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
@@ -452,7 +452,7 @@ cPprTermBase y =
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
            --Note pprinting of list terms is not lazy
-           doList p h t = do
+           doList p (Term{subTerms=[h,t]}) = do
                let elems      = h : getListTerms t
                    isConsLast = not(termType(last elems) `coreEqType` termType h)
                print_elems <- mapM (y cons_prec) elems
@@ -468,6 +468,7 @@ cPprTermBase y =
                       getListTerms Term{subTerms=[]}    = []
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
+           doList _ _ = panic "doList"
 
 
 repPrim :: TyCon -> [Word] -> String
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 97995871af..152d70b966 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -79,11 +79,8 @@ slurpSpillCostInfo cmm
 	--	the info table from the CmmProc
  	countBlock info (BasicBlock blockId instrs)
 		| LiveInfo _ _ (Just blockLive)	<- info
-		, Just rsLiveEntry		<- lookupBlockEnv blockLive blockId
-
-		, rsLiveEntry_virt	<- mapUniqSet (\(RegVirtual vr) -> vr) 
-					$  filterUniqSet isVirtualReg rsLiveEntry
-						
+		, Just rsLiveEntry  <- lookupBlockEnv blockLive blockId
+		, rsLiveEntry_virt  <- takeVirtuals rsLiveEntry
 		= countLIs rsLiveEntry_virt instrs
 
 		| otherwise
@@ -112,10 +109,6 @@ slurpSpillCostInfo cmm
 		mapM_ incDefs 	$ catMaybes $ map takeVirtualReg $ nub written
 
 		-- compute liveness for entry to next instruction.
-		let takeVirtuals set
-			= mapUniqSet (\(RegVirtual vr) -> vr)
-			$ filterUniqSet isVirtualReg set
-
 		let liveDieRead_virt	= takeVirtuals (liveDieRead  live)
 		let liveDieWrite_virt	= takeVirtuals (liveDieWrite live)
 		let liveBorn_virt	= takeVirtuals (liveBorn     live)
@@ -134,6 +127,13 @@ slurpSpillCostInfo cmm
 	incLifetime reg	= modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
 
 
+takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
+takeVirtuals set = mapUniqSet get_virtual
+		$ filterUniqSet isVirtualReg set
+  where
+   get_virtual (RegVirtual vr) = vr 
+   get_virtual _ = panic "getVirt" 
+
 -- | Choose a node to spill from this graph
 
 chooseSpill
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index de7760e611..5598cc0580 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -320,7 +320,8 @@ rnExpr (HsArrApp arrow arg _ ho rtl)
 -- infix form
 rnExpr (HsArrForm op (Just _) [arg1, arg2])
   = escapeArrowScope (rnLExpr op)
-			`thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
+			`thenM` \ (op',fv_op) ->
+    let L _ (HsVar op_name) = op' in
     rnCmdTop arg1	`thenM` \ (arg1',fv_arg1) ->
     rnCmdTop arg2	`thenM` \ (arg2',fv_arg2) ->
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index d8bcb22b80..76be4519d3 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -245,7 +245,7 @@ rnPat :: HsMatchContext Name -- for error messages
       -> RnM (a, FreeVars)     -- Variables bound by pattern do not 
       	     	 	       -- appear in the result FreeVars 
 rnPat ctxt pat thing_inside 
-  = rnPats ctxt [pat] (\[pat'] -> thing_inside pat')
+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
 
 applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 91bc78f947..07a596a177 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -309,7 +309,8 @@ rnSrcWarnDecls _bound_names []
 
 rnSrcWarnDecls bound_names decls 
   = do { -- check for duplicates
-       ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) 
+       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
+                          in addErrAt loc (dupWarnDecl lrdr' rdr)) 
                warn_rdr_dups
        ; pairs_s <- mapM (addLocM rn_deprec) decls
        ; return (WarnSome ((concat pairs_s))) }