X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=da1d0e017df82ff85b3e471d00e07f07119bfd73;hb=1d1c3c727617630beacacaf33022e1daba06a0bb;hp=485aacb1d21edbbb76307cea10b005ee7410b2fe;hpb=b99310f05faee2abec850da4349fcd5c0498f7ca;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 485aacb..da1d0e0 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -6,6 +6,13 @@
 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(..), 
 		   tcStmts, tcDoStmts, tcBody,
@@ -48,12 +55,12 @@ is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 
 \begin{code}
-tcMatchesFun :: Name
+tcMatchesFun :: Name -> Bool
 	     -> MatchGroup Name
 	     -> BoxyRhoType 		-- Expected type of function
 	     -> TcM (HsWrapper, MatchGroup TcId)	-- Returns type of body
 
-tcMatchesFun fun_name matches exp_ty
+tcMatchesFun fun_name inf matches exp_ty
   = do	{  -- Check that they all have the same no of arguments
 	   -- Location is in the monad, set the caller so that 
 	   -- any inter-equation error messages get some vaguely
@@ -76,7 +83,7 @@ tcMatchesFun fun_name matches exp_ty
     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, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 \end{code}
 
 @tcMatchesCase@ doesn't do the argument-count check because the
@@ -99,7 +106,7 @@ tcMatchLambda match res_ty
   where
     n_pats = matchGroupArity match
     doc = sep [ ptext SLIT("The lambda expression")
-		 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
+		 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
 			-- The pprSetDepth makes the abstraction print briefly
 		ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
     match_ctxt = MC { mc_what = LambdaExpr,
@@ -215,29 +222,29 @@ tcDoStmts :: HsStmtContext Name
 	  -> BoxyRhoType
 	  -> TcM (HsExpr TcId)		-- Returns a HsDo
 tcDoStmts ListComp stmts body res_ty
-  = do	{ elt_ty <- boxySplitListTy res_ty
+  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
 	; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts 
 				     (emptyRefinement,elt_ty) $
 			     tcBody body
-	; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+	; return $ mkHsWrapCoI coi 
+                     (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 
 tcDoStmts PArrComp stmts body res_ty
-  = do	{ [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+  = do	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
 	; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts 
 				     (emptyRefinement, elt_ty) $
 			     tcBody body
-	; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
+	; return $ mkHsWrapCoI coi 
+                     (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 
 tcDoStmts DoExpr stmts body res_ty
-  = do	{ (m_ty, elt_ty) <- boxySplitAppTy res_ty
-	; let res_ty' = mkAppTy m_ty elt_ty	-- The boxySplit consumes res_ty
-	; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts 
-				     (emptyRefinement, res_ty') $
+  = do	{ (stmts', body') <- tcStmts DoExpr tcDoStmt stmts 
+				     (emptyRefinement, res_ty) $
 			     tcBody body
-	; return (HsDo DoExpr stmts' body' res_ty') }
+	; return (HsDo DoExpr stmts' body' res_ty) }
 
 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
-  = do	{ (m_ty, elt_ty) <- boxySplitAppTy res_ty
+  = do	{ ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
  	; let res_ty' = mkAppTy m_ty elt_ty	-- The boxySplit consumes res_ty
 	      tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
 			   tcMonoExpr rhs (mkAppTy m_ty pat_ty)
@@ -248,7 +255,9 @@ tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
 
 	; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 	; insts <- mapM (newMethodFromName DoOrigin m_ty) names
-	; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
+	; return $ 
+            mkHsWrapCoI coi 
+              (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 
 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
@@ -389,12 +398,10 @@ tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 --	Do-notation
 -- The main excitement here is dealing with rebindable syntax
 
-tcDoStmt :: TcType		-- Monad type,  m
-	 -> TcStmtChecker
+tcDoStmt :: TcStmtChecker
 
-tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
-  = do	{ (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty -> 
-			    tcMonoExpr rhs (mkAppTy m_ty pat_ty)
+tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
+  = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 		-- We should use type *inference* for the RHS computations, becuase of GADTs. 
 		-- 	do { pat <- rhs; <rest> }
 		-- is rather like
@@ -402,31 +409,34 @@ tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thi
 		-- We do inference on rhs, so that information about its type can be refined
 		-- when type-checking the pattern. 
 
-	; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
+	-- Deal with rebindable syntax; (>>=) :: rhs_ty -> (a -> res_ty) -> res_ty
+	; (bind_op', pat_ty) <- 
+	     withBox liftedTypeKind $ \ pat_ty ->
+	     tcSyntaxOp DoOrigin bind_op 
+			(mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty)
 
-	-- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
-	; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty, 
-				  mkFunTy pat_ty res_ty] res_ty
-	; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
 		-- If (but only if) the pattern can fail, 
 		-- typecheck the 'fail' operator
-	; fail_op' <- if isIrrefutableHsPat pat' 
+	; fail_op' <- if isIrrefutableHsPat pat 
 		      then return noSyntaxExpr
 		      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
+
+	; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
+
 	; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 
-tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
-  = do	{ 	-- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
-	  a_ty <- newFlexiTyVarTy liftedTypeKind
-	; let rhs_ty  = mkAppTy m_ty a_ty
-	      then_ty = mkFunTys [rhs_ty, res_ty] res_ty
-	; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
-	; rhs' <- tcPolyExpr rhs rhs_ty
+tcDoStmt ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
+  = do	{ (rhs', rhs_ty) <- tcInferRho rhs
+
+  	-- Deal with rebindable syntax; (>>) :: rhs_ty -> res_ty -> res_ty
+	; then_op' <- tcSyntaxOp DoOrigin then_op 
+				 (mkFunTys [rhs_ty, res_ty] res_ty)
+
 	; thing <- thing_inside reft_res_ty
 	; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 
-tcDoStmt m_ty ctxt stmt res_ty thing_inside
+tcDoStmt ctxt stmt res_ty thing_inside
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 
 --------------------------------
@@ -473,7 +483,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
 	= do { poly_id <- tcLookupId rec_name
 		-- poly_id may have a polymorphic type
 		-- but mono_ty is just a monomorphic type variable
-	     ; co_fn <- tcSubExp (idType poly_id) mono_ty
+	     ; 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