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 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
48 %************************************************************************
50 \subsection{tcMatchesFun, tcMatchesCase}
52 %************************************************************************
54 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
55 @FunMonoBind@. The second argument is the name of the function, which
56 is used in error messages. It checks that all the equations have the
57 same number of arguments before using @tcMatches@ to do the work.
60 tcMatchesFun :: Name -> Bool
62 -> BoxyRhoType -- Expected type of function
63 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
65 tcMatchesFun fun_name inf matches exp_ty
66 = do { -- Check that they all have the same no of arguments
67 -- Location is in the monad, set the caller so that
68 -- any inter-equation error messages get some vaguely
69 -- sensible location. Note: we have to do this odd
70 -- ann-grabbing, because we don't always have annotations in
71 -- hand when we call tcMatchesFun...
72 checkArgs fun_name matches
74 -- ToDo: Don't use "expected" stuff if there ain't a type signature
75 -- because inconsistency between branches
76 -- may show up as something wrong with the (non-existent) type signature
78 -- This is one of two places places we call subFunTys
79 -- The point is that if expected_y is a "hole", we want
80 -- to make pat_tys and rhs_ty as "holes" too.
81 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
82 tcMatches match_ctxt pat_tys rhs_ty matches
85 doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
86 <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
87 n_pats = matchGroupArity matches
88 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
91 @tcMatchesCase@ doesn't do the argument-count check because the
92 parser guarantees that each equation has exactly one argument.
95 tcMatchesCase :: TcMatchCtxt -- Case context
96 -> TcRhoType -- Type of scrutinee
97 -> MatchGroup Name -- The case alternatives
98 -> BoxyRhoType -- Type of whole case expressions
99 -> TcM (MatchGroup TcId) -- Translated alternatives
101 tcMatchesCase ctxt scrut_ty matches res_ty
102 = tcMatches ctxt [scrut_ty] res_ty matches
104 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
105 tcMatchLambda match res_ty
106 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
107 tcMatches match_ctxt pat_tys rhs_ty match
109 n_pats = matchGroupArity match
110 doc = sep [ ptext (sLit "The lambda expression")
111 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
112 -- The pprSetDepth makes the abstraction print briefly
113 ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
114 match_ctxt = MC { mc_what = LambdaExpr,
118 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
121 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
122 -- Used for pattern bindings
123 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
125 match_ctxt = MC { mc_what = PatBindRhs,
130 %************************************************************************
134 %************************************************************************
137 tcMatches :: TcMatchCtxt
138 -> [BoxySigmaType] -- Expected pattern types
139 -> BoxyRhoType -- Expected result-type of the Match.
141 -> TcM (MatchGroup TcId)
143 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
144 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
145 mc_body :: LHsExpr Name -- Type checker for a body of
148 -> TcM (LHsExpr TcId) }
150 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
151 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
152 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
155 tcMatch :: TcMatchCtxt
156 -> [BoxySigmaType] -- Expected pattern types
157 -> BoxyRhoType -- Expected result-type of the Match.
161 tcMatch ctxt pat_tys rhs_ty match
162 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
164 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
165 = add_match_ctxt match $
166 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
167 tc_grhss ctxt maybe_rhs_sig grhss
168 ; return (Match pats' Nothing grhss') }
170 tc_grhss ctxt Nothing grhss rhs_ty
171 = tcGRHSs ctxt grhss rhs_ty -- No result signature
173 -- Result type sigs are no longer supported
174 tc_grhss ctxt (Just res_sig) grhss rhs_ty
175 = do { addErr (ptext (sLit "Ignoring (deprecated) result type signature")
177 ; tcGRHSs ctxt grhss rhs_ty }
179 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
180 -- so we don't want to add "In the lambda abstraction \x->e"
181 add_match_ctxt match thing_inside
182 = case mc_what ctxt of
183 LambdaExpr -> thing_inside
184 m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
187 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
190 -- Notice that we pass in the full res_ty, so that we get
191 -- good inference from simple things like
192 -- f = \(x::forall a.a->a) -> <stuff>
193 -- We used to force it to be a monotype when there was more than one guard
194 -- but we don't need to do that any more
196 tcGRHSs ctxt (GRHSs grhss binds) res_ty
197 = do { (binds', grhss') <- tcLocalBinds binds $
198 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
200 ; return (GRHSs grhss' binds') }
203 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
205 tcGRHS ctxt res_ty (GRHS guards rhs)
206 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
208 ; return (GRHS guards' rhs') }
210 stmt_ctxt = PatGuard (mc_what ctxt)
214 %************************************************************************
216 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
218 %************************************************************************
221 tcDoStmts :: HsStmtContext Name
225 -> TcM (HsExpr TcId) -- Returns a HsDo
226 tcDoStmts ListComp stmts body res_ty
227 = do { (elt_ty, coi) <- boxySplitListTy res_ty
228 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
231 ; return $ mkHsWrapCoI coi
232 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
234 tcDoStmts PArrComp stmts body res_ty
235 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
236 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
239 ; return $ mkHsWrapCoI coi
240 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
242 tcDoStmts DoExpr stmts body res_ty
243 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
246 ; return (HsDo DoExpr stmts' body' res_ty) }
248 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
249 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
250 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
251 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
252 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
254 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
258 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
259 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
262 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
264 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
266 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
268 = do { traceTc (text "tcBody" <+> ppr res_ty)
269 ; body' <- tcPolyExpr body res_ty
275 %************************************************************************
279 %************************************************************************
283 = forall thing. HsStmtContext Name
285 -> BoxyRhoType -- Result type for comprehension
286 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
287 -> TcM (Stmt TcId, thing)
289 tcStmts :: HsStmtContext Name
290 -> TcStmtChecker -- NB: higher-rank type
293 -> (BoxyRhoType -> TcM thing)
294 -> TcM ([LStmt TcId], thing)
296 -- Note the higher-rank type. stmt_chk is applied at different
297 -- types in the equations for tcStmts
299 tcStmts ctxt stmt_chk [] res_ty thing_inside
300 = do { thing <- thing_inside res_ty
301 ; return ([], thing) }
303 -- LetStmts are handled uniformly, regardless of context
304 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
305 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
306 tcStmts ctxt stmt_chk stmts res_ty thing_inside
307 ; return (L loc (LetStmt binds') : stmts', thing) }
309 -- For the vanilla case, handle the location-setting part
310 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
311 = do { (stmt', (stmts', thing)) <-
313 addErrCtxt (stmtCtxt ctxt stmt) $
314 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
316 tcStmts ctxt stmt_chk stmts res_ty' $
318 ; return (L loc stmt' : stmts', thing) }
320 --------------------------------
322 tcGuardStmt :: TcStmtChecker
323 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
324 = do { guard' <- tcMonoExpr guard boolTy
325 ; thing <- thing_inside res_ty
326 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
328 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
329 = do { (rhs', rhs_ty) <- tcInferRho rhs
330 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
331 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
333 tcGuardStmt ctxt stmt res_ty thing_inside
334 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
337 --------------------------------
338 -- List comprehensions and PArrays
340 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
343 -- A generator, pat <- rhs
344 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
345 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
346 tcMonoExpr rhs (mkTyConApp m_tc [ty])
347 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
348 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
351 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
352 = do { rhs' <- tcMonoExpr rhs boolTy
353 ; thing <- thing_inside res_ty
354 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
356 -- A parallel set of comprehensions
357 -- [ (g x, h x) | ... ; let g v = ...
358 -- | ... ; let h v = ... ]
360 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
361 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
362 -- Similarly if we had an existential pattern match:
364 -- data T = forall a. Show a => C a
366 -- [ (show x, show y) | ... ; C x <- ...
367 -- | ... ; C y <- ... ]
369 -- Then we need the LIE from (show x, show y) to be simplified against
370 -- the bindings for x and y.
372 -- It's difficult to do this in parallel, so we rely on the renamer to
373 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
374 -- So the binders of the first parallel group will be in scope in the second
375 -- group. But that's fine; there's no shadowing to worry about.
377 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
378 = do { (pairs', thing) <- loop bndr_stmts_s
379 ; return (ParStmt pairs', thing) }
381 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
382 loop [] = do { thing <- thing_inside elt_ty
383 ; return ([], thing) } -- matching in the branches
385 loop ((stmts, names) : pairs)
386 = do { (stmts', (ids, pairs', thing))
387 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
388 do { ids <- tcLookupLocalIds names
389 ; (pairs', thing) <- loop pairs
390 ; return (ids, pairs', thing) }
391 ; return ( (stmts', ids) : pairs', thing ) }
393 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
394 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
395 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
396 let alphaListTy = mkTyConApp m_tc [alphaTy]
398 (usingExpr', maybeByExpr') <-
401 -- We must validate that usingExpr :: forall a. [a] -> [a]
402 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
403 return (usingExpr', Nothing)
405 -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
406 (byExpr', tTy) <- tcInferRho byExpr
407 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
408 return (usingExpr', Just byExpr')
410 binders' <- tcLookupLocalIds binders
411 thing <- thing_inside elt_ty'
413 return (binders', usingExpr', maybeByExpr', thing)
415 return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
417 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
418 (stmts', (bindersMap', groupByClause', thing)) <-
419 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
420 let alphaListTy = mkTyConApp m_tc [alphaTy]
421 alphaListListTy = mkTyConApp m_tc [alphaListTy]
424 case groupByClause of
425 GroupByNothing usingExpr ->
426 -- We must validate that usingExpr :: forall a. [a] -> [[a]]
427 tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
428 GroupBySomething eitherUsingExpr byExpr -> do
429 -- We must infer a type such that byExpr :: t
430 (byExpr', tTy) <- tcInferRho byExpr
432 -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
433 let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
435 case eitherUsingExpr of
436 Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
437 Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
438 return $ GroupBySomething eitherUsingExpr' byExpr'
440 -- Find the IDs and types of all old binders
441 let (oldBinders, newBinders) = unzip bindersMap
442 oldBinders' <- tcLookupLocalIds oldBinders
444 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
445 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
447 -- Type check the thing in the environment with these new binders and return the result
448 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
449 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
451 return (GroupStmt (stmts', bindersMap') groupByClause', thing)
453 associateNewBinder :: TcId -> Name -> TcId
454 associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
456 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
457 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
459 --------------------------------
461 -- The main excitement here is dealing with rebindable syntax
463 tcDoStmt :: TcStmtChecker
465 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
466 = do { (rhs', rhs_ty) <- tcInferRho rhs
467 -- We should use type *inference* for the RHS computations,
469 -- do { pat <- rhs; <rest> }
471 -- case rhs of { pat -> <rest> }
472 -- We do inference on rhs, so that information about its type
473 -- can be refined when type-checking the pattern.
475 -- Deal with rebindable syntax:
476 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
477 -- This level of generality is needed for using do-notation
478 -- in full generality; see Trac #1537
479 ; ((bind_op', new_res_ty), pat_ty) <-
480 withBox liftedTypeKind $ \ pat_ty ->
481 withBox liftedTypeKind $ \ new_res_ty ->
482 tcSyntaxOp DoOrigin bind_op
483 (mkFunTys [rhs_ty, mkFunTy pat_ty new_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 new_res_ty)
491 ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
493 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
496 tcDoStmt ctxt (ExprStmt rhs then_op _) res_ty thing_inside
497 = do { (rhs', rhs_ty) <- tcInferRho rhs
499 -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
500 ; (then_op', new_res_ty) <-
501 withBox liftedTypeKind $ \ new_res_ty ->
502 tcSyntaxOp DoOrigin then_op
503 (mkFunTys [rhs_ty, new_res_ty] res_ty)
505 ; thing <- thing_inside new_res_ty
506 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
508 tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
509 = failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
510 -- This case can't be caught in the renamer
511 -- see RnExpr.checkRecStmt
513 tcDoStmt ctxt stmt res_ty thing_inside
514 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
516 --------------------------------
518 -- The distinctive features here are
520 -- (b) no rebindable syntax
522 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
524 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
525 = do { (rhs', pat_ty) <- tc_rhs rhs
526 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
527 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
529 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
530 = do { (rhs', elt_ty) <- tc_rhs rhs
531 ; thing <- thing_inside res_ty
532 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
534 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
535 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
536 ; let rec_ids = zipWith mkLocalId recNames rec_tys
537 ; tcExtendIdEnv rec_ids $ do
538 { (stmts', (later_ids, rec_rets))
539 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
540 -- ToDo: res_ty not really right
541 do { rec_rets <- zipWithM tc_ret recNames rec_tys
542 ; later_ids <- tcLookupLocalIds laterNames
543 ; return (later_ids, rec_rets) }
545 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
546 -- NB: The rec_ids for the recursive things
547 -- already scope over this part. This binding may shadow
548 -- some of them with polymorphic things with the same Name
549 -- (see note [RecStmt] in HsExpr)
550 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
552 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
555 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
556 tc_ret rec_name mono_ty
557 = do { poly_id <- tcLookupId rec_name
558 -- poly_id may have a polymorphic type
559 -- but mono_ty is just a monomorphic type variable
560 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
561 ; return (mkHsWrap co_fn (HsVar poly_id)) }
563 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
564 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
569 %************************************************************************
571 \subsection{Errors and contexts}
573 %************************************************************************
575 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
576 number of args are used in each equation.
579 checkArgs :: Name -> MatchGroup Name -> TcM ()
580 checkArgs fun (MatchGroup (match1:matches) _)
581 | null bad_matches = return ()
583 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
584 ptext (sLit "have different numbers of arguments"),
585 nest 2 (ppr (getLoc match1)),
586 nest 2 (ppr (getLoc (head bad_matches)))])
588 n_args1 = args_in_match match1
589 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
591 args_in_match :: LMatch Name -> Int
592 args_in_match (L _ (Match pats _ _)) = length pats
593 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
597 matchCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon)
598 4 (pprMatch ctxt match)
600 stmtCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)