2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
8 tcDoStmts, tcStmtsAndThen, tcGRHSs, tcThingWithSig
11 #include "HsVersions.h"
13 import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr )
15 import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
16 MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
17 pprMatch, getMatchLoc, isDoExpr,
18 pprMatchContext, pprStmtContext, pprStmtResultContext,
19 mkMonoBind, collectSigTysFromPats, andMonoBindList
21 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
22 RenamedPat, RenamedMatchContext )
23 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds,
24 TcMonoBinds, TcPat, TcStmt, ExprCoFn,
25 isIdCoercion, (<$>), (<.>) )
28 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
29 import Inst ( tcSyntaxName, tcInstCall )
30 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
31 import TcPat ( tcPat, tcMonoPatBndr )
32 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
33 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
34 tyVarsOfType, tidyOpenTypes, tidyOpenType, isSigmaTy,
35 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
36 mkArrowKind, mkAppTy )
37 import TcBinds ( tcBindsAndThen )
38 import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
39 unifyTauTy, subFunTy, unifyPArrTy, unifyListTy, unifyFunTy,
40 checkSigTyVarsWrt, tcSubExp, tcGen )
41 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
43 import PrelNames ( monadNames, mfixName )
44 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
45 import Id ( idType, mkSysLocal, mkLocalId )
46 import CoreFVs ( idFreeTyVars )
47 import BasicTypes ( RecFlag(..) )
51 import Util ( isSingleton, notNull, zipEqual )
57 %************************************************************************
59 \subsection{tcMatchesFun, tcMatchesCase}
61 %************************************************************************
63 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
64 @FunMonoBind@. The second argument is the name of the function, which
65 is used in error messages. It checks that all the equations have the
66 same number of arguments before using @tcMatches@ to do the work.
71 -> Expected TcRhoType -- Expected type
74 tcMatchesFun fun_name matches@(first_match:_) expected_ty
75 = -- Check that they all have the same no of arguments
76 -- Set the location to that of the first equation, so that
77 -- any inter-equation error messages get some vaguely
78 -- sensible location. Note: we have to do this odd
79 -- ann-grabbing, because we don't always have annotations in
80 -- hand when we call tcMatchesFun...
81 addSrcLoc (getMatchLoc first_match) (
82 checkTc (sameNoOfArgs matches)
83 (varyingArgsErr fun_name matches)
86 -- ToDo: Don't use "expected" stuff if there ain't a type signature
87 -- because inconsistency between branches
88 -- may show up as something wrong with the (non-existent) type signature
90 -- No need to zonk expected_ty, because subFunTy does that on the fly
91 tcMatches (FunRhs fun_name) matches expected_ty
94 @tcMatchesCase@ doesn't do the argument-count check because the
95 parser guarantees that each equation has exactly one argument.
98 tcMatchesCase :: [RenamedMatch] -- The case alternatives
99 -> Expected TcRhoType -- Type of whole case expressions
100 -> TcM (TcRhoType, -- Inferred type of the scrutinee
101 [TcMatch]) -- Translated alternatives
103 tcMatchesCase matches (Check expr_ty)
104 = -- This case is a bit yukky, because it prevents the
105 -- scrutinee being higher-ranked, which might just possible
106 -- matter if we were seq'ing on it. But it's awkward to fix.
107 newTyVarTy openTypeKind `thenM` \ scrut_ty ->
108 tcMatches CaseAlt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
109 returnM (scrut_ty, matches')
111 tcMatchesCase matches (Infer hole)
112 = newHole `thenM` \ fun_hole ->
113 tcMatches CaseAlt matches (Infer fun_hole) `thenM` \ matches' ->
114 readMutVar fun_hole `thenM` \ fun_ty ->
115 -- The result of tcMatches is bound to be a function type
116 unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
117 writeMutVar hole res_ty `thenM_`
118 returnM (scrut_ty, matches')
121 tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
122 tcMatchLambda match res_ty = tcMatch LambdaExpr match res_ty
127 tcMatches :: RenamedMatchContext
129 -> Expected TcRhoType
132 tcMatches ctxt matches exp_ty
133 = -- If there is more than one branch, and exp_ty is a 'hole',
134 -- all branches must be types, not type schemes, otherwise the
135 -- order in which we check them would affect the result.
136 zapExpectedBranches matches exp_ty `thenM` \ exp_ty' ->
137 mappM (tc_match exp_ty') matches
139 tc_match exp_ty match = tcMatch ctxt match exp_ty
143 %************************************************************************
147 %************************************************************************
150 tcMatch :: RenamedMatchContext
152 -> Expected TcRhoType -- Expected result-type of the Match.
153 -- Early unification with this guy gives better error messages
154 -- We regard the Match as having type
155 -- (ty1 -> ... -> tyn -> result_ty)
156 -- where there are n patterns.
159 tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
160 = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
161 addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
162 tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
163 returnM (Match pats' Nothing (glue_on ex_binds grhss'))
167 = -- Deal with the result signature
168 case maybe_rhs_sig of
169 Nothing -> tcGRHSs ctxt grhss rhs_ty
171 Just sig -> tcAddScopedTyVars [sig] $
172 -- Bring into scope the type variables in the signature
173 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
174 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
176 -- Pushes the coercion down to the right hand sides,
177 -- because there is no convenient place to hang it otherwise.
178 if isIdCoercion co_fn then
181 readExpectedType rhs_ty `thenM` \ rhs_ty' ->
182 returnM (lift_grhss co_fn rhs_ty' grhss')
184 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
185 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since the coercion does
187 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
189 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
190 lift_stmt stmt = stmt
192 -- glue_on just avoids stupid dross
193 glue_on EmptyBinds grhss = grhss -- The common case
194 glue_on binds1 (GRHSs grhss binds2 ty)
195 = GRHSs grhss (binds1 `ThenBinds` binds2) ty
198 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
199 -> Expected TcRhoType
202 -- Special case when there is just one equation with a degenerate
203 -- guard; then we pass in the full Expected type, so that we get
204 -- good inference from simple things like
205 -- f = \(x::forall a.a->a) -> <stuff>
206 -- This is a consequence of the fact that tcStmts takes a TcType,
207 -- not a Expected TcType, a decision we could revisit if necessary
208 tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
209 = tcBindsAndThen glue_on binds $
210 tcMonoExpr rhs exp_ty `thenM` \ rhs' ->
211 readExpectedType exp_ty `thenM` \ exp_ty' ->
212 returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
214 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
215 = tcBindsAndThen glue_on binds $
216 zapExpectedType exp_ty `thenM` \ exp_ty' ->
217 -- Even if there is only one guard, we zap the RHS type to
218 -- a monotype. Reason: it makes tcStmts much easier,
219 -- and even a one-armed guard has a notional second arm
221 tc_grhs (GRHS guarded locn)
223 tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
224 returnM (GRHS guarded' locn)
226 m_ty = (\ty -> ty, exp_ty')
228 mappM tc_grhs grhss `thenM` \ grhss' ->
229 returnM (GRHSs grhss' EmptyBinds exp_ty')
234 tcThingWithSig :: TcSigmaType -- Type signature
235 -> (TcRhoType -> TcM r) -- How to type check the thing inside
236 -> Expected TcRhoType -- Overall expected result type
238 -- Used for expressions with a type signature, and for result type signatures
240 tcThingWithSig sig_ty thing_inside res_ty
241 | not (isSigmaTy sig_ty)
242 = thing_inside sig_ty `thenM` \ result ->
243 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
244 returnM (co_fn, result)
246 | otherwise -- The signature has some outer foralls
247 = -- Must instantiate the outer for-alls of sig_tc_ty
248 -- else we risk instantiating a ? res_ty to a forall-type
249 -- which breaks the invariant that tcMonoExpr only returns phi-types
250 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
251 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
252 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
253 returnM (co_fn <.> inst_fn <.> gen_fn, result)
254 -- Note that we generalise, then instantiate. Ah well.
258 %************************************************************************
260 \subsection{tcMatchPats}
262 %************************************************************************
266 :: [RenamedPat] -> Expected TcRhoType
267 -> (Expected TcRhoType -> TcM a)
268 -> TcM ([TcPat], a, TcHsBinds)
269 -- Typecheck the patterns, extend the environment to bind the variables,
270 -- do the thing inside, use any existentially-bound dictionaries to
271 -- discharge parts of the returning LIE, and deal with pattern type
274 tcMatchPats pats expected_ty thing_inside
275 = -- STEP 1: Bring pattern-signature type variables into scope
276 tcAddScopedTyVars (collectSigTysFromPats pats) (
278 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
279 -- then do the thing inside
280 getLIE (tc_match_pats pats expected_ty thing_inside)
282 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
284 -- STEP 4: Check for existentially bound type variables
285 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
286 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
288 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
289 -- might need (via lie_req2) something made available from an 'outer'
290 -- pattern. But it's inconvenient to deal with, and I can't find an example
291 readExpectedType expected_ty `thenM` \ exp_ty ->
292 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req exp_ty `thenM` \ ex_binds ->
293 -- NB: we *must* pass "exp_ty" not "result_ty" to tcCheckExistentialPat
294 -- For example, we must reject this program:
295 -- data C = forall a. C (a -> Int)
297 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
299 returnM (pats', result, mkMonoBind Recursive ex_binds)
301 tc_match_pats [] expected_ty thing_inside
302 = thing_inside expected_ty `thenM` \ answer ->
303 returnM ([], emptyBag, [], [], answer)
305 tc_match_pats (pat:pats) expected_ty thing_inside
306 = subFunTy expected_ty $ \ arg_ty rest_ty ->
307 -- This is the unique place we call subFunTy
308 -- The point is that if expected_y is a "hole", we want
309 -- to make arg_ty and rest_ty as "holes" too.
310 tcPat tcMonoPatBndr pat arg_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
312 xve = bagToList pat_bndrs
313 ex_ids = [id | (_, id) <- xve]
314 -- ex_ids is all the pattern-bound Ids, a superset
315 -- of the existential Ids used in checkExistentialPat
317 tcExtendLocalValEnv2 xve $
318 tc_match_pats pats rest_ty thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
319 returnM ( pat':pats',
320 ex_tvs `unionBags` exs_tvs,
327 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
328 -> [TcId] -- Ids bound by this pattern; used
329 -- (a) by bindsInstsOfLocalFuns
330 -- (b) to generate helpful error messages
331 -> [Inst] -- and context
332 -> [Inst] -- Required context
333 -> TcType -- and type of the Match; vars in here must not escape
334 -> TcM TcDictBinds -- LIE to float out and dict bindings
335 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
336 | isEmptyBag ex_tvs && all not_overloaded ex_ids
337 -- Short cut for case when there are no existentials
338 -- and no polymorphic overloaded variables
339 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
341 -- Here we must discharge op Methods
342 = ASSERT( null ex_lie )
343 extendLIEs lie_req `thenM_`
344 returnM EmptyMonoBinds
347 = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
349 -- In case there are any polymorpic, overloaded binders in the pattern
350 -- (which can happen in the case of rank-2 type signatures, or data constructors
351 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
352 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
354 -- Deal with overloaded functions bound by the pattern
355 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
356 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
358 returnM (dict_binds `AndMonoBinds` inst_binds)
360 doc = text ("existential context of a data constructor")
361 tv_list = bagToList ex_tvs
362 not_overloaded id = not (isOverloadedTy (idType id))
366 %************************************************************************
368 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
370 %************************************************************************
373 tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name]
374 -> TcRhoType -- To keep it simple, we don't have an "expected" type here
375 -> TcM (TcMonoBinds, [TcStmt], [Id])
376 tcDoStmts PArrComp stmts method_names res_ty
377 = unifyPArrTy res_ty `thenM` \elt_ty ->
378 tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
379 returnM (EmptyMonoBinds, stmts', [{- unused -}])
381 tcDoStmts ListComp stmts method_names res_ty
382 = unifyListTy res_ty `thenM` \ elt_ty ->
383 tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
384 returnM (EmptyMonoBinds, stmts', [{- unused -}])
386 tcDoStmts do_or_mdo_expr stmts method_names res_ty
387 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
388 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
389 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
391 tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
393 -- Build the then and zero methods in case we need them
394 -- It's important that "then" and "return" appear just once in the final LIE,
395 -- not only for typechecker efficiency, but also because otherwise during
396 -- simplification we end up with silly stuff like
397 -- then = case d of (t,r) -> t
399 -- where the second "then" sees that it already exists in the "available" stuff.
401 mapAndUnzipM (tc_syn_name m_ty)
402 (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
403 returnM (andMonoBindList binds, stmts', ids)
405 currentMonadNames = case do_or_mdo_expr of
407 MDoExpr -> monadNames ++ [mfixName]
408 tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
409 tc_syn_name m_ty (std_nm, usr_nm)
410 = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
412 HsVar v -> returnM (EmptyMonoBinds, v)
413 other -> newUnique `thenM` \ uniq ->
415 id = mkSysLocal FSLIT("syn") uniq expr_ty
417 returnM (VarMonoBind id expr, id)
421 %************************************************************************
425 %************************************************************************
427 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
429 [ (g x, h x) | ... ; let g v = ...
430 | ... ; let h v = ... ]
432 It's possible that g,h are overloaded, so we need to feed the LIE from the
433 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
434 Similarly if we had an existential pattern match:
436 data T = forall a. Show a => C a
438 [ (show x, show y) | ... ; C x <- ...
441 Then we need the LIE from (show x, show y) to be simplified against
442 the bindings for x and y.
444 It's difficult to do this in parallel, so we rely on the renamer to
445 ensure that g,h and x,y don't duplicate, and simply grow the environment.
446 So the binders of the first parallel group will be in scope in the second
447 group. But that's fine; there's no shadowing to worry about.
450 tcStmts do_or_lc m_ty stmts
451 = ASSERT( notNull stmts )
452 tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
455 :: (TcStmt -> thing -> thing) -- Combiner
456 -> HsStmtContext Name
457 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
458 -- res_ty, the type of the entire comprehension
459 -- used at the end for the type of (return x)
460 -- or the final expression in do-notation
466 tcStmtsAndThen combine do_or_lc m_ty [] do_next
469 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
470 = tcStmtAndThen combine do_or_lc m_ty stmt
471 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
474 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
475 = tcBindsAndThen -- No error context, but a binding group is
476 (glue_binds combine) -- rather a large thing for an error context anyway
480 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
481 = addSrcLoc src_loc $
482 addErrCtxt (stmtCtxt do_or_lc stmt) $
483 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
484 tcCheckRho exp (m pat_ty) `thenM` \ exp' ->
485 tcMatchPats [pat] (Check (mkFunTy pat_ty (m elt_ty))) (\ _ ->
486 popErrCtxt thing_inside
487 ) `thenM` \ ([pat'], thing, dict_binds) ->
488 returnM (combine (BindStmt pat' exp' src_loc)
489 (glue_binds combine dict_binds thing))
492 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
493 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
494 returnM (combine (ParStmtOut pairs') thing)
497 = thing_inside `thenM` \ thing ->
500 loop ((bndrs,stmts) : pairs)
502 combine_par ListComp m_ty stmts
503 -- Notice we pass on m_ty; the result type is used only
504 -- to get escaping type variables for checkExistentialPat
505 (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
506 loop pairs `thenM` \ (pairs', thing) ->
507 returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
509 returnM ((bndrs',stmts') : pairs', thing)
511 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
514 tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
515 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
517 mono_ids = zipWith mkLocalId recNames recTys
519 tcExtendLocalValEnv mono_ids $
520 tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
521 mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
523 ) `thenM` \ (stmts', rets) ->
525 -- NB: it's the mono_ids that scope over this part
526 thing_inside `thenM` \ thing ->
528 returnM (combine (RecStmt mono_ids stmts' rets) thing)
530 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
532 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
533 tc_ret (rec_name, mono_ty)
534 = tcLookupId rec_name `thenM` \ poly_id ->
535 -- poly_id may have a polymorphic type
536 -- but mono_ty is just a monomorphic type variable
537 tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
538 returnM (co_fn <$> HsVar poly_id)
541 tcStmtAndThen combine do_or_lc m_ty@(m, _) stmt@(ExprStmt exp _ locn) thing_inside
542 = addErrCtxt (stmtCtxt do_or_lc stmt) (
543 if isDoExpr do_or_lc then
544 newTyVarTy openTypeKind `thenM` \ any_ty ->
545 tcCheckRho exp (m any_ty) `thenM` \ exp' ->
546 returnM (ExprStmt exp' any_ty locn)
548 tcCheckRho exp boolTy `thenM` \ exp' ->
549 returnM (ExprStmt exp' boolTy locn)
552 thing_inside `thenM` \ thing ->
553 returnM (combine stmt' thing)
557 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
558 = addErrCtxt (resCtxt do_or_lc stmt) (
559 if isDoExpr do_or_lc then
560 tcCheckRho exp (m res_elt_ty)
562 tcCheckRho exp res_elt_ty
565 thing_inside `thenM` \ thing ->
567 returnM (combine (ResultStmt exp' locn) thing)
570 ------------------------------
571 glue_binds combine EmptyBinds thing = thing
572 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
576 %************************************************************************
578 \subsection{Errors and contexts}
580 %************************************************************************
582 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
583 number of args are used in each equation.
586 sameNoOfArgs :: [RenamedMatch] -> Bool
587 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
589 args_in_match :: RenamedMatch -> Int
590 args_in_match (Match pats _ _) = length pats
594 varyingArgsErr name matches
595 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
597 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
598 stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
599 resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)
601 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
602 = zonkTcType match_ty `thenM` \ match_ty' ->
604 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
605 (env2, tidy_mty) = tidyOpenType env1 match_ty'
608 sep [ptext SLIT("When checking an existential match that binds"),
609 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
610 ptext SLIT("and whose type is") <+> ppr tidy_mty])
612 show_ids = filter is_interesting bound_ids
613 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
615 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
616 -- Don't zonk the types so we get the separate, un-unified versions