X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=b16c8d3199a94082ee0df2388979a1ebd98e5fb7;hp=caab44ae2a515288130d8f06186fd69860f6183a;hb=c1500e4888be2341c0b6e6897f494766c86feba0;hpb=210ca9c013a9cd193a78c1590e3f2ec4041f4858

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index caab44a..b16c8d3 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -6,26 +6,16 @@
 TcMatches: Typecheck some @Matches@
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
-		   matchCtxt, TcMatchCtxt(..), 
+		   TcMatchCtxt(..), 
 		   tcStmts, tcDoStmts, tcBody,
 		   tcDoStmt, tcMDoStmt, tcGuardStmt
        ) where
 
-#include "HsVersions.h"
-
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
 
 import HsSyn
 import TcRnMonad
-import TcGadt
 import Inst
 import TcEnv
 import TcPat
@@ -43,6 +33,7 @@ import TysPrim
 import Outputable
 import Util
 import SrcLoc
+import FastString
 
 import Control.Monad
 \end{code}
@@ -84,8 +75,8 @@ tcMatchesFun fun_name inf matches exp_ty
 	  tcMatches match_ctxt pat_tys rhs_ty matches
 	}
   where
-    doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
-	  <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
+    doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
+	  <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
     n_pats = matchGroupArity matches
     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 \end{code}
@@ -109,10 +100,10 @@ tcMatchLambda match res_ty
     tcMatches match_ctxt pat_tys rhs_ty match
   where
     n_pats = matchGroupArity match
-    doc = sep [ ptext SLIT("The lambda expression")
+    doc = sep [ ptext (sLit "The lambda expression")
 		 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
 			-- The pprSetDepth makes the abstraction print briefly
-		ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
+		ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
     match_ctxt = MC { mc_what = LambdaExpr,
 		      mc_body = tcBody }
 \end{code}
@@ -173,17 +164,15 @@ tcMatch ctxt pat_tys rhs_ty match
       = tcGRHSs ctxt grhss rhs_ty	-- No result signature
 
 	-- Result type sigs are no longer supported
-    tc_grhss ctxt (Just res_sig) grhss rhs_ty
-      = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
-			<+> ppr res_sig)
-    	   ; tcGRHSs ctxt grhss rhs_ty }
+    tc_grhss _ (Just {}) _ _
+      = panic "tc_ghrss"  	-- Rejected by renamer
 
 	-- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 	-- so we don't want to add "In the lambda abstraction \x->e"
     add_match_ctxt match thing_inside
 	= case mc_what ctxt of
 	    LambdaExpr -> thing_inside
-	    m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
+	    m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 
 -------------
 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
@@ -263,7 +252,7 @@ tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
             mkHsWrapCoI coi 
               (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 
-tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcBody body res_ty
@@ -298,7 +287,7 @@ tcStmts :: HsStmtContext Name
 -- Note the higher-rank type.  stmt_chk is applied at different
 -- types in the equations for tcStmts
 
-tcStmts ctxt stmt_chk [] res_ty thing_inside
+tcStmts _ _ [] res_ty thing_inside
   = do	{ thing <- thing_inside res_ty
 	; return ([], thing) }
 
@@ -312,7 +301,7 @@ tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
   = do 	{ (stmt', (stmts', thing)) <- 
 		setSrcSpan loc		 		$
-    		addErrCtxt (stmtCtxt ctxt stmt)		$
+    		addErrCtxt (pprStmtInCtxt ctxt stmt)	$
 		stmt_chk ctxt stmt res_ty		$ \ res_ty' ->
 		popErrCtxt 				$
 		tcStmts ctxt stmt_chk stmts res_ty'	$
@@ -322,17 +311,17 @@ tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 --------------------------------
 --	Pattern guards
 tcGuardStmt :: TcStmtChecker
-tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
+tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
   = do	{ guard' <- tcMonoExpr guard boolTy
 	; thing  <- thing_inside res_ty
 	; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 
-tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 	; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcGuardStmt ctxt stmt res_ty thing_inside
+tcGuardStmt _ stmt _ _
   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 
 
@@ -343,14 +332,14 @@ tcLcStmt :: TyCon	-- The list/Parray type constructor ([] or PArray)
 	 -> TcStmtChecker
 
 -- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside 
+tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
  = do	{ (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
 			    tcMonoExpr rhs (mkTyConApp m_tc [ty])
 	; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- A boolean guard
-tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
+tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
   = do	{ rhs'  <- tcMonoExpr rhs boolTy
 	; thing <- thing_inside res_ty
 	; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
@@ -386,7 +375,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 
     loop ((stmts, names) : pairs)
       = do { (stmts', (ids, pairs', thing))
-		<- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
+		<- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 		   do { ids <- tcLookupLocalIds names
 		      ; (pairs', thing) <- loop pairs
 		      ; return (ids, pairs', thing) }
@@ -455,7 +444,7 @@ tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in
         associateNewBinder :: TcId -> Name -> TcId
         associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
     
-tcLcStmt m_tc ctxt stmt elt_ty thing_inside
+tcLcStmt _ _ stmt _ _
   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
         
 --------------------------------
@@ -464,7 +453,7 @@ tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 
 tcDoStmt :: TcStmtChecker
 
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 		-- We should use type *inference* for the RHS computations, 
                 -- becuase of GADTs. 
@@ -495,7 +484,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 	; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 
-tcDoStmt ctxt (ExprStmt rhs then_op _) res_ty thing_inside
+tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 
   	-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
@@ -507,12 +496,12 @@ tcDoStmt ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 	; thing <- thing_inside new_res_ty
 	; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 
-tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
-  = failWithTc (ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
+tcDoStmt ctxt (RecStmt {}) _ _
+  = failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
 	-- This case can't be caught in the renamer
 	-- see RnExpr.checkRecStmt
 
-tcDoStmt ctxt stmt res_ty thing_inside
+tcDoStmt _ stmt _ _
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 
 --------------------------------
@@ -523,12 +512,12 @@ tcDoStmt ctxt stmt res_ty thing_inside
 
 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))	-- RHS inference
 	  -> TcStmtChecker
-tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
   = do	{ (rhs', pat_ty) <- tc_rhs rhs
 	; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
+tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
   = do	{ (rhs', elt_ty) <- tc_rhs rhs
 	; thing 	 <- thing_inside res_ty
 	; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
@@ -538,7 +527,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
 	; let rec_ids = zipWith mkLocalId recNames rec_tys
 	; tcExtendIdEnv rec_ids			$ do
     	{ (stmts', (later_ids, rec_rets))
-		<- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty	$ \ res_ty' -> 
+		<- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty	$ \ _res_ty' ->
 			-- ToDo: res_ty not really right
 		   do { rec_rets <- zipWithM tc_ret recNames rec_tys
 		      ; later_ids <- tcLookupLocalIds laterNames
@@ -562,7 +551,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
 	     ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
 	     ; return (mkHsWrap co_fn (HsVar poly_id)) }
 
-tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
+tcMDoStmt _ _ stmt _ _
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 
 \end{code}
@@ -582,8 +571,8 @@ checkArgs :: Name -> MatchGroup Name -> TcM ()
 checkArgs fun (MatchGroup (match1:matches) _)
     | null bad_matches = return ()
     | otherwise
-    = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+> 
-			  ptext SLIT("have different numbers of arguments"),
+    = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> 
+			  ptext (sLit "have different numbers of arguments"),
 			nest 2 (ppr (getLoc match1)),
 			nest 2 (ppr (getLoc (head bad_matches)))])
   where
@@ -592,13 +581,6 @@ checkArgs fun (MatchGroup (match1:matches) _)
 
     args_in_match :: LMatch Name -> Int
     args_in_match (L _ (Match pats _ _)) = length pats
-checkArgs fun other = panic "TcPat.checkArgs"	-- Matches always non-empty
+checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
 \end{code}
 
-\begin{code}
-matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 
-			   4 (pprMatch ctxt match)
-
-stmtCtxt ctxt stmt = hang (ptext SLIT("In a stmt of") <+> pprStmtContext ctxt <> colon)
-		  	4 (ppr stmt)
-\end{code}