Print infix function definitions correctly in HsSyn

[ghc-hetmet.git] / compiler / typecheck / TcMatches.lhs

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 61faca8..bd83a55 100644 (file)
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[TcMatches]{Typecheck some @Matches@}
+
+TcMatches: Typecheck some @Matches@
 
 \begin{code}
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
@@ -14,36 +16,24 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
 
 import {-# SOURCE #-}  TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
 
-import HsSyn           ( HsExpr(..), LHsExpr, MatchGroup(..),
-                         Match(..), LMatch, GRHSs(..), GRHS(..), 
-                         Stmt(..), LStmt, HsMatchContext(..),
-                         HsStmtContext(..), 
-                         pprMatch, isIrrefutableHsPat, mkHsCoerce,
-                         mkLHsCoerce, pprMatchContext, pprStmtContext,  
-                         noSyntaxExpr, matchGroupArity, pprMatches,
-                         ExprCoFn )
-
+import HsSyn
 import TcRnMonad
-import TcGadt          ( Refinement, emptyRefinement, refineResType )
-import Inst            ( newMethodFromName )
-import TcEnv           ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv )
-import TcPat           ( tcLamPats, tcLamPat )
-import TcMType         ( newFlexiTyVarTy, newFlexiTyVarTys ) 
-import TcType          ( TcType, TcRhoType, 
-                         BoxySigmaType, BoxyRhoType, 
-                         mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
-                         liftedTypeKind )
-import TcBinds         ( tcLocalBinds )
-import TcUnify         ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
-                         subFunTys, tcSubExp, withBox )
-import TcSimplify      ( bindInstsOfLocalFuns )
-import Name            ( Name )
-import TysWiredIn      ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
-import PrelNames       ( bindMName, returnMName, mfixName, thenMName, failMName )
-import Id              ( idType, mkLocalId )
-import TyCon           ( TyCon )
+import TcGadt
+import Inst
+import TcEnv
+import TcPat
+import TcMType
+import TcType
+import TcBinds
+import TcUnify
+import TcSimplify
+import Name
+import TysWiredIn
+import PrelNames
+import Id
+import TyCon
 import Outputable
-import SrcLoc          ( Located(..), getLoc )
+import SrcLoc
 \end{code}
 
 %************************************************************************
@@ -58,12 +48,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 (ExprCoFn, MatchGroup TcId) -- Returns type of body
+            -> 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
@@ -86,7 +76,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
@@ -102,7 +92,7 @@ tcMatchesCase :: TcMatchCtxt         -- Case context
 tcMatchesCase ctxt scrut_ty matches res_ty
   = tcMatches ctxt [scrut_ty] res_ty matches
 
-tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
+tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
 tcMatchLambda match res_ty 
   = subFunTys doc n_pats res_ty        $ \ pat_tys rhs_ty ->
     tcMatches match_ctxt pat_tys rhs_ty match
@@ -163,7 +153,7 @@ tcMatch ctxt pat_tys rhs_ty match
   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
   where
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
-      = addErrCtxt (matchCtxt (mc_what ctxt) match)    $       
+      = add_match_ctxt match $
         do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
                                tc_grhss ctxt maybe_rhs_sig grhss
           ; return (Match pats' Nothing grhss') }
@@ -172,10 +162,17 @@ 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 (co,rhs_ty)
+    tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
       = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
                        <+> ppr res_sig)
-            tcGRHSs ctxt grhss (co, inner_ty) }
+          ; tcGRHSs ctxt grhss (co, rhs_ty) }
+
+       -- 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
 
 -------------
 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType) 
@@ -260,7 +257,7 @@ tcBody body (reft, res_ty)
   = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
        ; let (co, res_ty') = refineResType reft res_ty
        ; body' <- tcPolyExpr body res_ty'
-       ; return (mkLHsCoerce co body') } 
+       ; return (mkLHsWrap co body') } 
 \end{code}
 
 
@@ -477,7 +474,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
                -- poly_id may have a polymorphic type
                -- but mono_ty is just a monomorphic type variable
             ; co_fn <- tcSubExp (idType poly_id) mono_ty
-            ; return (mkHsCoerce co_fn (HsVar poly_id)) }
+            ; return (mkHsWrap co_fn (HsVar poly_id)) }
 
 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)