2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcMatches: Typecheck some @Matches@
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
17 matchCtxt, TcMatchCtxt(..),
18 tcStmts, tcDoStmts, tcBody,
19 tcDoStmt, tcMDoStmt, tcGuardStmt
22 #include "HsVersions.h"
24 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
47 import Control.Monad( liftM )
50 %************************************************************************
52 \subsection{tcMatchesFun, tcMatchesCase}
54 %************************************************************************
56 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
57 @FunMonoBind@. The second argument is the name of the function, which
58 is used in error messages. It checks that all the equations have the
59 same number of arguments before using @tcMatches@ to do the work.
62 tcMatchesFun :: Name -> Bool
64 -> BoxyRhoType -- Expected type of function
65 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
67 tcMatchesFun fun_name inf matches exp_ty
68 = do { -- Check that they all have the same no of arguments
69 -- Location is in the monad, set the caller so that
70 -- any inter-equation error messages get some vaguely
71 -- sensible location. Note: we have to do this odd
72 -- ann-grabbing, because we don't always have annotations in
73 -- hand when we call tcMatchesFun...
74 checkArgs fun_name matches
76 -- ToDo: Don't use "expected" stuff if there ain't a type signature
77 -- because inconsistency between branches
78 -- may show up as something wrong with the (non-existent) type signature
80 -- This is one of two places places we call subFunTys
81 -- The point is that if expected_y is a "hole", we want
82 -- to make pat_tys and rhs_ty as "holes" too.
83 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
84 tcMatches match_ctxt pat_tys rhs_ty matches
87 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
88 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
89 n_pats = matchGroupArity matches
90 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
93 @tcMatchesCase@ doesn't do the argument-count check because the
94 parser guarantees that each equation has exactly one argument.
97 tcMatchesCase :: TcMatchCtxt -- Case context
98 -> TcRhoType -- Type of scrutinee
99 -> MatchGroup Name -- The case alternatives
100 -> BoxyRhoType -- Type of whole case expressions
101 -> TcM (MatchGroup TcId) -- Translated alternatives
103 tcMatchesCase ctxt scrut_ty matches res_ty
104 = tcMatches ctxt [scrut_ty] res_ty matches
106 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
107 tcMatchLambda match res_ty
108 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
109 tcMatches match_ctxt pat_tys rhs_ty match
111 n_pats = matchGroupArity match
112 doc = sep [ ptext SLIT("The lambda expression")
113 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
114 -- The pprSetDepth makes the abstraction print briefly
115 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
116 match_ctxt = MC { mc_what = LambdaExpr,
120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
123 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
124 -- Used for pattern bindings
125 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty)
126 -- emptyRefinement: no refinement in a pattern binding
128 match_ctxt = MC { mc_what = PatBindRhs,
133 %************************************************************************
137 %************************************************************************
140 tcMatches :: TcMatchCtxt
141 -> [BoxySigmaType] -- Expected pattern types
142 -> BoxyRhoType -- Expected result-type of the Match.
144 -> TcM (MatchGroup TcId)
146 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
147 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
148 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
149 -> (Refinement, BoxyRhoType)
150 -> TcM (LHsExpr TcId) }
152 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
153 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
154 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
157 tcMatch :: TcMatchCtxt
158 -> [BoxySigmaType] -- Expected pattern types
159 -> BoxyRhoType -- Expected result-type of the Match.
163 tcMatch ctxt pat_tys rhs_ty match
164 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
166 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
167 = add_match_ctxt match $
168 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
169 tc_grhss ctxt maybe_rhs_sig grhss
170 ; return (Match pats' Nothing grhss') }
172 tc_grhss ctxt Nothing grhss rhs_ty
173 = tcGRHSs ctxt grhss rhs_ty -- No result signature
175 -- Result type sigs are no longer supported
176 tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
177 = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
179 ; tcGRHSs ctxt grhss (co, rhs_ty) }
181 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
182 -- so we don't want to add "In the lambda abstraction \x->e"
183 add_match_ctxt match thing_inside
184 = case mc_what ctxt of
185 LambdaExpr -> thing_inside
186 m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
189 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
192 -- Notice that we pass in the full res_ty, so that we get
193 -- good inference from simple things like
194 -- f = \(x::forall a.a->a) -> <stuff>
195 -- We used to force it to be a monotype when there was more than one guard
196 -- but we don't need to do that any more
198 tcGRHSs ctxt (GRHSs grhss binds) res_ty
199 = do { (binds', grhss') <- tcLocalBinds binds $
200 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
202 ; returnM (GRHSs grhss' binds') }
205 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
207 tcGRHS ctxt res_ty (GRHS guards rhs)
208 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
210 ; return (GRHS guards' rhs') }
212 stmt_ctxt = PatGuard (mc_what ctxt)
216 %************************************************************************
218 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
220 %************************************************************************
223 tcDoStmts :: HsStmtContext Name
227 -> TcM (HsExpr TcId) -- Returns a HsDo
228 tcDoStmts ListComp stmts body res_ty
229 = do { (elt_ty, coi) <- boxySplitListTy res_ty
230 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
231 (emptyRefinement,elt_ty) $
233 ; return $ mkHsWrapCoI coi
234 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
236 tcDoStmts PArrComp stmts body res_ty
237 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
238 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
239 (emptyRefinement, elt_ty) $
241 ; return $ mkHsWrapCoI coi
242 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
244 tcDoStmts DoExpr stmts body res_ty
245 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
246 (emptyRefinement, res_ty) $
248 ; return (HsDo DoExpr stmts' body' res_ty) }
250 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
251 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
252 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
253 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
254 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
256 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
257 (emptyRefinement, res_ty') $
260 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
261 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
264 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
266 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
268 tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId)
269 tcBody body (reft, res_ty)
270 = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
271 ; let (co, res_ty') = refineResType reft res_ty
272 ; body' <- tcPolyExpr body res_ty'
273 ; return (mkLHsWrap co body') }
277 %************************************************************************
281 %************************************************************************
285 = forall thing. HsStmtContext Name
287 -> (Refinement, BoxyRhoType) -- Result type for comprehension
288 -> ((Refinement,BoxyRhoType) -> TcM thing) -- Checker for what follows the stmt
289 -> TcM (Stmt TcId, thing)
291 -- The incoming BoxyRhoType may be refined by type refinements
292 -- before being passed to the thing_inside
294 tcStmts :: HsStmtContext Name
295 -> TcStmtChecker -- NB: higher-rank type
297 -> (Refinement, BoxyRhoType)
298 -> ((Refinement, BoxyRhoType) -> TcM thing)
299 -> TcM ([LStmt TcId], thing)
301 -- Note the higher-rank type. stmt_chk is applied at different
302 -- types in the equations for tcStmts
304 tcStmts ctxt stmt_chk [] res_ty thing_inside
305 = do { thing <- thing_inside res_ty
306 ; return ([], thing) }
308 -- LetStmts are handled uniformly, regardless of context
309 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
310 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
311 tcStmts ctxt stmt_chk stmts res_ty thing_inside
312 ; return (L loc (LetStmt binds') : stmts', thing) }
314 -- For the vanilla case, handle the location-setting part
315 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
316 = do { (stmt', (stmts', thing)) <-
318 addErrCtxt (stmtCtxt ctxt stmt) $
319 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
321 tcStmts ctxt stmt_chk stmts res_ty' $
323 ; return (L loc stmt' : stmts', thing) }
325 --------------------------------
327 tcGuardStmt :: TcStmtChecker
328 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
329 = do { guard' <- tcMonoExpr guard boolTy
330 ; thing <- thing_inside res_ty
331 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
333 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
334 = do { (rhs', rhs_ty) <- tcInferRho rhs
335 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
336 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
338 tcGuardStmt ctxt stmt res_ty thing_inside
339 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
342 --------------------------------
343 -- List comprehensions and PArrays
345 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
348 -- A generator, pat <- rhs
349 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
350 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
351 tcMonoExpr rhs (mkTyConApp m_tc [ty])
352 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
353 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
356 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
357 = do { rhs' <- tcMonoExpr rhs boolTy
358 ; thing <- thing_inside res_ty
359 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
361 -- A parallel set of comprehensions
362 -- [ (g x, h x) | ... ; let g v = ...
363 -- | ... ; let h v = ... ]
365 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
366 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
367 -- Similarly if we had an existential pattern match:
369 -- data T = forall a. Show a => C a
371 -- [ (show x, show y) | ... ; C x <- ...
372 -- | ... ; C y <- ... ]
374 -- Then we need the LIE from (show x, show y) to be simplified against
375 -- the bindings for x and y.
377 -- It's difficult to do this in parallel, so we rely on the renamer to
378 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
379 -- So the binders of the first parallel group will be in scope in the second
380 -- group. But that's fine; there's no shadowing to worry about.
382 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
383 = do { (pairs', thing) <- loop bndr_stmts_s
384 ; return (ParStmt pairs', thing) }
386 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
387 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
388 ; return ([], thing) } -- matching in the branches
390 loop ((stmts, names) : pairs)
391 = do { (stmts', (ids, pairs', thing))
392 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
393 do { ids <- tcLookupLocalIds names
394 ; (pairs', thing) <- loop pairs
395 ; return (ids, pairs', thing) }
396 ; return ( (stmts', ids) : pairs', thing ) }
398 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
399 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
400 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
401 let alphaListTy = mkTyConApp m_tc [alphaTy]
403 (usingExpr', maybeByExpr') <-
406 -- We must validate that usingExpr :: forall a. [a] -> [a]
407 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
408 return (usingExpr', Nothing)
410 -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
411 (byExpr', tTy) <- tcInferRho byExpr
412 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
413 return (usingExpr', Just byExpr')
415 binders' <- tcLookupLocalIds binders
416 thing <- thing_inside elt_ty'
418 return (binders', usingExpr', maybeByExpr', thing)
420 return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
422 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
423 (stmts', (bindersMap', groupByClause', thing)) <-
424 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
425 let alphaListTy = mkTyConApp m_tc [alphaTy]
426 alphaListListTy = mkTyConApp m_tc [alphaListTy]
429 case groupByClause of
430 GroupByNothing usingExpr ->
431 -- We must validate that usingExpr :: forall a. [a] -> [[a]]
432 tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
433 GroupBySomething eitherUsingExpr byExpr -> do
434 -- We must infer a type such that byExpr :: t
435 (byExpr', tTy) <- tcInferRho byExpr
437 -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
438 let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
440 case eitherUsingExpr of
441 Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
442 Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
443 return $ GroupBySomething eitherUsingExpr' byExpr'
445 -- Find the IDs and types of all old binders
446 let (oldBinders, newBinders) = unzip bindersMap
447 oldBinders' <- tcLookupLocalIds oldBinders
449 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
450 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
452 -- Type check the thing in the environment with these new binders and return the result
453 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
454 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
456 return (GroupStmt (stmts', bindersMap') groupByClause', thing)
458 associateNewBinder :: TcId -> Name -> TcId
459 associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
461 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
462 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
464 --------------------------------
466 -- The main excitement here is dealing with rebindable syntax
468 tcDoStmt :: TcStmtChecker
470 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
471 = do { (rhs', rhs_ty) <- tcInferRho rhs
472 -- We should use type *inference* for the RHS computations, becuase of GADTs.
473 -- do { pat <- rhs; <rest> }
475 -- case rhs of { pat -> <rest> }
476 -- We do inference on rhs, so that information about its type can be refined
477 -- when type-checking the pattern.
479 -- Deal with rebindable syntax; (>>=) :: rhs_ty -> (a -> res_ty) -> res_ty
480 ; (bind_op', pat_ty) <-
481 withBox liftedTypeKind $ \ pat_ty ->
482 tcSyntaxOp DoOrigin bind_op
483 (mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty)
485 -- If (but only if) the pattern can fail,
486 -- typecheck the 'fail' operator
487 ; fail_op' <- if isIrrefutableHsPat pat
488 then return noSyntaxExpr
489 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
491 ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
493 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
496 tcDoStmt ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
497 = do { (rhs', rhs_ty) <- tcInferRho rhs
499 -- Deal with rebindable syntax; (>>) :: rhs_ty -> res_ty -> res_ty
500 ; then_op' <- tcSyntaxOp DoOrigin then_op
501 (mkFunTys [rhs_ty, res_ty] res_ty)
503 ; thing <- thing_inside reft_res_ty
504 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
506 tcDoStmt ctxt stmt res_ty thing_inside
507 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
509 --------------------------------
511 -- The distinctive features here are
513 -- (b) no rebindable syntax
515 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
517 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
518 = do { (rhs', pat_ty) <- tc_rhs rhs
519 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
520 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
522 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
523 = do { (rhs', elt_ty) <- tc_rhs rhs
524 ; thing <- thing_inside res_ty
525 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
527 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
528 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
529 ; let rec_ids = zipWith mkLocalId recNames rec_tys
530 ; tcExtendIdEnv rec_ids $ do
531 { (stmts', (later_ids, rec_rets))
532 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
533 -- ToDo: res_ty not really right
534 do { rec_rets <- zipWithM tc_ret recNames rec_tys
535 ; later_ids <- tcLookupLocalIds laterNames
536 ; return (later_ids, rec_rets) }
538 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
539 -- NB: The rec_ids for the recursive things
540 -- already scope over this part. This binding may shadow
541 -- some of them with polymorphic things with the same Name
542 -- (see note [RecStmt] in HsExpr)
543 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
545 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
548 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
549 tc_ret rec_name mono_ty
550 = do { poly_id <- tcLookupId rec_name
551 -- poly_id may have a polymorphic type
552 -- but mono_ty is just a monomorphic type variable
553 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
554 ; return (mkHsWrap co_fn (HsVar poly_id)) }
556 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
557 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
562 %************************************************************************
564 \subsection{Errors and contexts}
566 %************************************************************************
568 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
569 number of args are used in each equation.
572 checkArgs :: Name -> MatchGroup Name -> TcM ()
573 checkArgs fun (MatchGroup (match1:matches) _)
574 | null bad_matches = return ()
576 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
577 ptext SLIT("have different numbers of arguments"),
578 nest 2 (ppr (getLoc match1)),
579 nest 2 (ppr (getLoc (head bad_matches)))])
581 n_args1 = args_in_match match1
582 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
584 args_in_match :: LMatch Name -> Int
585 args_in_match (L _ (Match pats _ _)) = length pats
586 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
590 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
591 4 (pprMatch ctxt match)
593 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)