2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, matchCtxt,
8 tcDoStmts, tcStmtsAndThen, tcStmts, tcGRHSs, tcThingWithSig,
13 #include "HsVersions.h"
15 import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr )
17 import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
18 MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
20 pprMatch, getMatchLoc, isDoExpr,
21 pprMatchContext, pprStmtContext, pprStmtResultContext,
22 mkMonoBind, collectSigTysFromPats, andMonoBindList, glueBindsOnGRHSs
24 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr,
25 RenamedPat, RenamedMatchContext )
26 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr,
27 TcMonoBinds, TcPat, TcStmt, ExprCoFn,
28 isIdCoercion, (<$>), (<.>) )
31 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
32 import Inst ( tcSyntaxName, tcInstCall )
33 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
34 import TcPat ( tcPat, tcMonoPatBndr )
35 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
36 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
37 tyVarsOfTypes, tidyOpenTypes, tidyOpenType, isSigmaTy,
38 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
39 mkArrowKind, mkAppTy )
40 import TcBinds ( tcBindsAndThen )
41 import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
42 unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
43 checkSigTyVarsWrt, tcSubExp, tcGen )
44 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
46 import PrelNames ( monadNames, mfixName )
47 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
48 import Id ( idType, mkSysLocal, mkLocalId )
49 import CoreFVs ( idFreeTyVars )
50 import BasicTypes ( RecFlag(..) )
54 import Util ( isSingleton, notNull, zipEqual )
60 %************************************************************************
62 \subsection{tcMatchesFun, tcMatchesCase}
64 %************************************************************************
66 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
67 @FunMonoBind@. The second argument is the name of the function, which
68 is used in error messages. It checks that all the equations have the
69 same number of arguments before using @tcMatches@ to do the work.
74 -> Expected TcRhoType -- Expected type
77 tcMatchesFun fun_name matches@(first_match:_) expected_ty
78 = -- Check that they all have the same no of arguments
79 -- Set the location to that of the first equation, so that
80 -- any inter-equation error messages get some vaguely
81 -- sensible location. Note: we have to do this odd
82 -- ann-grabbing, because we don't always have annotations in
83 -- hand when we call tcMatchesFun...
84 addSrcLoc (getMatchLoc first_match) (
85 checkTc (sameNoOfArgs matches)
86 (varyingArgsErr fun_name matches)
89 -- ToDo: Don't use "expected" stuff if there ain't a type signature
90 -- because inconsistency between branches
91 -- may show up as something wrong with the (non-existent) type signature
93 -- No need to zonk expected_ty, because subFunTys does that on the fly
94 tcMatches (FunRhs fun_name) matches expected_ty
97 @tcMatchesCase@ doesn't do the argument-count check because the
98 parser guarantees that each equation has exactly one argument.
101 tcMatchesCase :: [RenamedMatch] -- The case alternatives
102 -> Expected TcRhoType -- Type of whole case expressions
103 -> TcM (TcRhoType, -- Inferred type of the scrutinee
104 [TcMatch]) -- Translated alternatives
106 tcMatchesCase matches (Check expr_ty)
107 = -- This case is a bit yukky, because it prevents the
108 -- scrutinee being higher-ranked, which might just possible
109 -- matter if we were seq'ing on it. But it's awkward to fix.
110 newTyVarTy openTypeKind `thenM` \ scrut_ty ->
111 tcMatches CaseAlt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
112 returnM (scrut_ty, matches')
114 tcMatchesCase matches (Infer hole)
115 = newHole `thenM` \ fun_hole ->
116 tcMatches CaseAlt matches (Infer fun_hole) `thenM` \ matches' ->
117 readMutVar fun_hole `thenM` \ fun_ty ->
118 -- The result of tcMatches is bound to be a function type
119 unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
120 writeMutVar hole res_ty `thenM_`
121 returnM (scrut_ty, matches')
124 tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
125 tcMatchLambda match res_ty = tcMatch LambdaExpr match res_ty
130 tcMatches :: RenamedMatchContext
132 -> Expected TcRhoType
135 tcMatches ctxt matches exp_ty
136 = -- If there is more than one branch, and exp_ty is a 'hole',
137 -- all branches must be types, not type schemes, otherwise the
138 -- order in which we check them would affect the result.
139 zapExpectedBranches matches exp_ty `thenM` \ exp_ty' ->
140 mappM (tc_match exp_ty') matches
142 tc_match exp_ty match = tcMatch ctxt match exp_ty
146 %************************************************************************
150 %************************************************************************
153 tcMatch :: RenamedMatchContext
155 -> Expected TcRhoType -- Expected result-type of the Match.
156 -- Early unification with this guy gives better error messages
157 -- We regard the Match as having type
158 -- (ty1 -> ... -> tyn -> result_ty)
159 -- where there are n patterns.
162 tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
163 = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
164 addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
165 subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
166 -- This is the unique place we call subFunTys
167 -- The point is that if expected_y is a "hole", we want
168 -- to make arg_ty and rest_ty as "holes" too.
169 tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
170 returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
174 = case maybe_rhs_sig of -- Deal with the result signature
175 Nothing -> tcGRHSs ctxt grhss rhs_ty
177 Just sig -> tcAddScopedTyVars [sig] $
178 -- Bring into scope the type variables in the signature
179 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
180 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
182 -- Pushes the coercion down to the right hand sides,
183 -- because there is no convenient place to hang it otherwise.
184 if isIdCoercion co_fn then
187 readExpectedType rhs_ty `thenM` \ rhs_ty' ->
188 returnM (lift_grhss co_fn rhs_ty' grhss')
190 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
191 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since the coercion does
193 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
195 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
196 lift_stmt stmt = stmt
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 glueBindsOnGRHSs 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 glueBindsOnGRHSs 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 stmt_ctxt = SC { sc_what = PatGuard ctxt,
223 sc_body = \ body -> tcCheckRho body exp_ty',
226 tc_grhs (GRHS guarded locn)
228 tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
229 returnM (GRHS guarded' locn)
231 mappM tc_grhs grhss `thenM` \ grhss' ->
232 returnM (GRHSs grhss' EmptyBinds exp_ty')
237 tcThingWithSig :: TcSigmaType -- Type signature
238 -> (TcRhoType -> TcM r) -- How to type check the thing inside
239 -> Expected TcRhoType -- Overall expected result type
241 -- Used for expressions with a type signature, and for result type signatures
243 tcThingWithSig sig_ty thing_inside res_ty
244 | not (isSigmaTy sig_ty)
245 = thing_inside sig_ty `thenM` \ result ->
246 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
247 returnM (co_fn, result)
249 | otherwise -- The signature has some outer foralls
250 = -- Must instantiate the outer for-alls of sig_tc_ty
251 -- else we risk instantiating a ? res_ty to a forall-type
252 -- which breaks the invariant that tcMonoExpr only returns phi-types
253 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
254 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
255 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
256 returnM (co_fn <.> inst_fn <.> gen_fn, result)
257 -- Note that we generalise, then instantiate. Ah well.
261 %************************************************************************
263 \subsection{tcMatchPats}
265 %************************************************************************
269 :: [(RenamedPat, Expected TcRhoType)]
270 -> Expected TcRhoType
272 -> TcM ([TcPat], a, TcHsBinds)
273 -- Typecheck the patterns, extend the environment to bind the variables,
274 -- do the thing inside, use any existentially-bound dictionaries to
275 -- discharge parts of the returning LIE, and deal with pattern type
278 tcMatchPats pats_w_tys body_ty thing_inside
279 = -- STEP 1: Bring pattern-signature type variables into scope
280 tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
282 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
283 -- then do the thing inside
284 getLIE (tc_match_pats pats_w_tys thing_inside)
286 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
288 -- STEP 4: Check for existentially bound type variables
289 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
290 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
292 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
293 -- might need (via lie_req2) something made available from an 'outer'
294 -- pattern. But it's inconvenient to deal with, and I can't find an example
295 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
296 pats_w_tys body_ty `thenM` \ ex_binds ->
297 -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
298 -- For example, we must reject this program:
299 -- data C = forall a. C (a -> Int)
301 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
303 returnM (pats', result, mkMonoBind Recursive ex_binds)
305 tc_match_pats [] thing_inside
306 = thing_inside `thenM` \ answer ->
307 returnM ([], emptyBag, [], [], answer)
309 tc_match_pats ((pat,pat_ty):pats) thing_inside
310 = tcPat tcMonoPatBndr pat pat_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 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 -> [(pat,Expected TcRhoType)] -- Types of the patterns
334 -> Expected TcRhoType -- Type of the body of the match
335 -- Tyvars in either of these must not escape
336 -> TcM TcDictBinds -- LIE to float out and dict bindings
337 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
338 | isEmptyBag ex_tvs && all not_overloaded ex_ids
339 -- Short cut for case when there are no existentials
340 -- and no polymorphic overloaded variables
341 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
343 -- Here we must discharge op Methods
344 = ASSERT( null ex_lie )
345 extendLIEs lie_req `thenM_`
346 returnM EmptyMonoBinds
349 = -- Read the by-now-filled-in expected types
350 mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
351 addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
353 -- In case there are any polymorpic, overloaded binders in the pattern
354 -- (which can happen in the case of rank-2 type signatures, or data constructors
355 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
356 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
358 -- Deal with overloaded functions bound by the pattern
359 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
361 -- Check for type variable escape
362 checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
364 returnM (dict_binds `AndMonoBinds` inst_binds)
366 doc = text ("existential context of a data constructor")
367 tv_list = bagToList ex_tvs
368 not_overloaded id = not (isOverloadedTy (idType id))
372 %************************************************************************
374 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
376 %************************************************************************
379 tcDoStmts :: HsStmtContext Name
380 -> [RenamedStmt] -> ReboundNames Name
381 -> TcRhoType -- To keep it simple, we don't have an "expected" type here
382 -> TcM ([TcStmt], ReboundNames TcId)
383 tcDoStmts PArrComp stmts method_names res_ty
384 = unifyPArrTy res_ty `thenM` \elt_ty ->
385 tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
386 returnM (stmts', [{- unused -}])
388 tcDoStmts ListComp stmts method_names res_ty
389 = unifyListTy res_ty ` thenM` \ elt_ty ->
390 tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
391 returnM (stmts', [{- unused -}])
393 tcDoStmts do_or_mdo stmts method_names res_ty
394 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
395 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
396 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
398 ctxt = SC { sc_what = do_or_mdo,
399 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
400 sc_body = \ body -> tcCheckRho body res_ty,
403 tcStmts ctxt stmts `thenM` \ stmts' ->
405 -- Build the then and zero methods in case we need them
406 -- It's important that "then" and "return" appear just once in the final LIE,
407 -- not only for typechecker efficiency, but also because otherwise during
408 -- simplification we end up with silly stuff like
409 -- then = case d of (t,r) -> t
411 -- where the second "then" sees that it already exists in the "available" stuff.
412 mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
414 returnM (stmts', methods)
416 tcComprehension do_or_lc mk_mty elt_ty stmts
419 ctxt = SC { sc_what = do_or_lc,
420 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
421 sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
422 sc_ty = mk_mty elt_ty }
426 %************************************************************************
430 %************************************************************************
432 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
434 [ (g x, h x) | ... ; let g v = ...
435 | ... ; let h v = ... ]
437 It's possible that g,h are overloaded, so we need to feed the LIE from the
438 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
439 Similarly if we had an existential pattern match:
441 data T = forall a. Show a => C a
443 [ (show x, show y) | ... ; C x <- ...
446 Then we need the LIE from (show x, show y) to be simplified against
447 the bindings for x and y.
449 It's difficult to do this in parallel, so we rely on the renamer to
450 ensure that g,h and x,y don't duplicate, and simply grow the environment.
451 So the binders of the first parallel group will be in scope in the second
452 group. But that's fine; there's no shadowing to worry about.
456 = ASSERT( notNull stmts )
457 tcStmtsAndThen (:) ctxt stmts (returnM [])
460 = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
461 sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations
462 sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation
463 sc_ty :: TcType } -- Return type; used *only* to check
464 -- for escape in existential patterns
466 :: (TcStmt -> thing -> thing) -- Combiner
473 tcStmtsAndThen combine ctxt [] thing_inside
476 tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
477 = tcStmtAndThen combine ctxt stmt $
478 tcStmtsAndThen combine ctxt stmts $
482 tcStmtAndThen combine ctxt (LetStmt binds) thing_inside
483 = tcBindsAndThen -- No error context, but a binding group is
484 (glue_binds combine) -- rather a large thing for an error context anyway
489 tcStmtAndThen combine ctxt stmt@(BindStmt pat exp src_loc) thing_inside
490 = addSrcLoc src_loc $
491 addErrCtxt (stmtCtxt ctxt stmt) $
492 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
493 sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
494 tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
495 popErrCtxt thing_inside
496 ) `thenM` \ ([pat'], thing, dict_binds) ->
497 returnM (combine (BindStmt pat' exp' src_loc)
498 (glue_binds combine dict_binds thing))
501 tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside
502 = addSrcLoc src_loc (
503 addErrCtxt (stmtCtxt ctxt stmt) $
504 if isDoExpr (sc_what ctxt)
505 then -- do or mdo; the expression is a computation
506 newTyVarTy openTypeKind `thenM` \ any_ty ->
507 sc_rhs ctxt exp any_ty `thenM` \ exp' ->
508 returnM (ExprStmt exp' any_ty src_loc)
509 else -- List comprehensions, pattern guards; expression is a boolean
510 tcCheckRho exp boolTy `thenM` \ exp' ->
511 returnM (ExprStmt exp' boolTy src_loc)
514 thing_inside `thenM` \ thing ->
515 returnM (combine stmt' thing)
519 tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside
520 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
521 returnM (combine (ParStmt pairs') thing)
523 loop [] = thing_inside `thenM` \ thing ->
526 loop ((stmts, bndrs) : pairs)
527 = tcStmtsAndThen combine_par ctxt stmts $
528 -- Notice we pass on ctxt; the result type is used only
529 -- to get escaping type variables for checkExistentialPat
530 tcLookupLocalIds bndrs `thenM` \ bndrs' ->
531 loop pairs `thenM` \ (pairs', thing) ->
532 returnM (([], bndrs') : pairs', thing)
534 combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
537 tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside
538 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
540 rec_ids = zipWith mkLocalId recNames recTys
542 tcExtendLocalValEnv rec_ids $
543 tcStmtsAndThen combine_rec ctxt stmts (
544 mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
545 tcLookupLocalIds laterNames `thenM` \ later_ids ->
546 returnM ([], (later_ids, rec_rets))
547 ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
549 tcExtendLocalValEnv later_ids $
550 -- NB: The rec_ids for the recursive things
551 -- already scope over this part
552 thing_inside `thenM` \ thing ->
554 returnM (combine (RecStmt stmts' later_ids rec_ids rec_rets) thing)
556 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
558 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
559 tc_ret (rec_name, mono_ty)
560 = tcLookupId rec_name `thenM` \ poly_id ->
561 -- poly_id may have a polymorphic type
562 -- but mono_ty is just a monomorphic type variable
563 tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
564 returnM (co_fn <$> HsVar poly_id)
567 tcStmtAndThen combine ctxt stmt@(ResultStmt exp locn) thing_inside
568 = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
569 thing_inside `thenM` \ thing ->
570 returnM (combine (ResultStmt exp' locn) thing)
573 ------------------------------
574 glue_binds combine EmptyBinds thing = thing
575 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
579 %************************************************************************
581 \subsection{Errors and contexts}
583 %************************************************************************
585 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
586 number of args are used in each equation.
589 sameNoOfArgs :: [RenamedMatch] -> Bool
590 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
592 args_in_match :: RenamedMatch -> Int
593 args_in_match (Match pats _ _) = length pats
597 varyingArgsErr name matches
598 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
600 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
601 4 (pprMatch ctxt match)
603 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
605 pp_ctxt = case stmt of
606 ResultStmt _ _ -> pprStmtResultContext
607 other -> pprStmtContext
609 sigPatCtxt bound_tvs bound_ids tys tidy_env
610 = -- tys is (body_ty : pat_tys)
611 mapM zonkTcType tys `thenM` \ tys' ->
613 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
614 (env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
617 sep [ptext SLIT("When checking an existential match that binds"),
618 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
619 ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
620 ptext SLIT("The body has type:") <+> ppr tidy_body_ty
623 show_ids = filter is_interesting bound_ids
624 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
626 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
627 -- Don't zonk the types so we get the separate, un-unified versions