X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=d11cb9754a9b705811d14fa9777b850ea32e7048;hp=bd83a55e29bce3e1361ee0cb5794077bfd883990;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index bd83a55..d11cb97 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,
@@ -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,31 @@ 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
+  = do	{ ((m_ty, elt_ty), coi) <- 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') $
 			     tcBody body
-	; return (HsDo DoExpr stmts' body' res_ty') }
+	; return $ mkHsWrapCoI coi (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 +257,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)