2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
9 tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
11 TcStmtCtxt(..), TcMatchCtxt(..)
14 #include "HsVersions.h"
16 import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr )
18 import HsSyn ( HsExpr(..), LHsExpr, HsBindGroup(..),
19 Match(..), LMatch, GRHSs(..), GRHS(..),
20 Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
23 pprMatchContext, pprStmtContext, pprStmtResultContext,
24 collectSigTysFromPats, glueBindsOnGRHSs
26 import TcHsSyn ( ExprCoFn, TcDictBinds, isIdCoercion, (<$>), (<.>) )
29 import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
30 import Inst ( tcSyntaxName, tcInstCall )
31 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
32 import TcPat ( tcPat, tcMonoPatBndr )
33 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
34 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
35 tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
36 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
37 mkArrowKind, mkAppTy )
38 import TcBinds ( tcBindsAndThen )
39 import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
40 unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
41 checkSigTyVarsWrt, tcSubExp, tcGen )
42 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
44 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
45 import Id ( idType, mkLocalId )
46 import CoreFVs ( idFreeTyVars )
47 import BasicTypes ( RecFlag(..) )
50 import Util ( isSingleton, notNull )
52 import SrcLoc ( Located(..), noLoc )
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 -- Location is in the monad, set the caller 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 checkTc (sameNoOfArgs matches)
82 (varyingArgsErr fun_name matches) `thenM_`
84 -- ToDo: Don't use "expected" stuff if there ain't a type signature
85 -- because inconsistency between branches
86 -- may show up as something wrong with the (non-existent) type signature
88 -- No need to zonk expected_ty, because subFunTys does that on the fly
89 tcMatches match_ctxt matches expected_ty
91 match_ctxt = MC { mc_what = FunRhs fun_name,
92 mc_body = tcMonoExpr }
95 @tcMatchesCase@ doesn't do the argument-count check because the
96 parser guarantees that each equation has exactly one argument.
99 tcMatchesCase :: TcMatchCtxt -- Case context
100 -> [LMatch Name] -- The case alternatives
101 -> Expected TcRhoType -- Type of whole case expressions
102 -> TcM (TcRhoType, -- Inferred type of the scrutinee
103 [LMatch TcId]) -- Translated alternatives
105 tcMatchesCase ctxt matches (Check expr_ty)
106 = -- This case is a bit yukky, because it prevents the
107 -- scrutinee being higher-ranked, which might just possible
108 -- matter if we were seq'ing on it. But it's awkward to fix.
109 newTyVarTy openTypeKind `thenM` \ scrut_ty ->
110 tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
111 returnM (scrut_ty, matches')
113 tcMatchesCase ctxt matches (Infer hole)
114 = newHole `thenM` \ fun_hole ->
115 tcMatches ctxt matches (Infer fun_hole) `thenM` \ matches' ->
116 readMutVar fun_hole `thenM` \ fun_ty ->
117 -- The result of tcMatches is bound to be a function type
118 unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
119 writeMutVar hole res_ty `thenM_`
120 returnM (scrut_ty, matches')
123 tcMatchLambda :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId)
124 tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match
126 match_ctxt = MC { mc_what = LambdaExpr,
127 mc_body = tcMonoExpr }
130 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
133 tcGRHSsPat :: GRHSs Name
134 -> Expected TcRhoType
136 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
138 match_ctxt = MC { mc_what = PatBindRhs,
139 mc_body = tcMonoExpr }
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 an alternative
146 -> Expected TcRhoType
147 -> TcM (LHsExpr TcId) }
149 tcMatches :: TcMatchCtxt
151 -> Expected TcRhoType
154 tcMatches ctxt matches exp_ty
155 = -- If there is more than one branch, and exp_ty is a 'hole',
156 -- all branches must be types, not type schemes, otherwise the
157 -- order in which we check them would affect the result.
158 zapExpectedBranches matches exp_ty `thenM` \ exp_ty' ->
159 mappM (tcMatch ctxt exp_ty') matches
163 %************************************************************************
167 %************************************************************************
170 tcMatch :: TcMatchCtxt
171 -> Expected TcRhoType -- Expected result-type of the Match.
172 -- Early unification with this guy gives better error messages
173 -- We regard the Match as having type
174 -- (ty1 -> ... -> tyn -> result_ty)
175 -- where there are n patterns.
179 tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match
181 tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss)
182 = addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back
183 subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
184 -- This is the unique place we call subFunTys
185 -- The point is that if expected_y is a "hole", we want
186 -- to make arg_ty and rest_ty as "holes" too.
187 tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
188 returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
192 = case maybe_rhs_sig of -- Deal with the result signature
193 Nothing -> tcGRHSs ctxt grhss rhs_ty
195 Just sig -> tcAddScopedTyVars [sig] $
196 -- Bring into scope the type variables in the signature
197 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
198 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
200 -- Pushes the coercion down to the right hand sides,
201 -- because there is no convenient place to hang it otherwise.
202 if isIdCoercion co_fn then
205 readExpectedType rhs_ty `thenM` \ rhs_ty' ->
206 returnM (lift_grhss co_fn rhs_ty' grhss')
208 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
209 = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty -- Change the type, since the coercion does
211 lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
213 lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
214 lift_stmt stmt = stmt
216 tcGRHSs :: TcMatchCtxt -> GRHSs Name
217 -> Expected TcRhoType
220 -- Special case when there is just one equation with a degenerate
221 -- guard; then we pass in the full Expected type, so that we get
222 -- good inference from simple things like
223 -- f = \(x::forall a.a->a) -> <stuff>
224 -- This is a consequence of the fact that tcStmts takes a TcType,
225 -- not a Expected TcType, a decision we could revisit if necessary
226 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty
227 = tcBindsAndThen glueBindsOnGRHSs binds $
228 mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
229 readExpectedType exp_ty `thenM` \ exp_ty' ->
230 returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty')
232 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
233 = tcBindsAndThen glueBindsOnGRHSs binds $
234 zapExpectedType exp_ty `thenM` \ exp_ty' ->
235 -- Even if there is only one guard, we zap the RHS type to
236 -- a monotype. Reason: it makes tcStmts much easier,
237 -- and even a one-armed guard has a notional second arm
239 stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
243 sc_body body = mc_body ctxt body (Check exp_ty')
245 tc_grhs (GRHS guarded)
246 = tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
247 returnM (GRHS guarded')
249 mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
250 returnM (GRHSs grhss' [] exp_ty')
255 tcThingWithSig :: TcSigmaType -- Type signature
256 -> (TcRhoType -> TcM r) -- How to type check the thing inside
257 -> Expected TcRhoType -- Overall expected result type
259 -- Used for expressions with a type signature, and for result type signatures
261 tcThingWithSig sig_ty thing_inside res_ty
262 | not (isSigmaTy sig_ty)
263 = thing_inside sig_ty `thenM` \ result ->
264 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
265 returnM (co_fn, result)
267 | otherwise -- The signature has some outer foralls
268 = -- Must instantiate the outer for-alls of sig_tc_ty
269 -- else we risk instantiating a ? res_ty to a forall-type
270 -- which breaks the invariant that tcMonoExpr only returns phi-types
271 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
272 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
273 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
274 returnM (co_fn <.> inst_fn <.> gen_fn, result)
275 -- Note that we generalise, then instantiate. Ah well.
279 %************************************************************************
281 \subsection{tcMatchPats}
283 %************************************************************************
287 :: [(LPat Name, Expected TcRhoType)]
288 -> Expected TcRhoType
290 -> TcM ([LPat TcId], a, HsBindGroup TcId)
291 -- Typecheck the patterns, extend the environment to bind the variables,
292 -- do the thing inside, use any existentially-bound dictionaries to
293 -- discharge parts of the returning LIE, and deal with pattern type
296 tcMatchPats pats_w_tys body_ty thing_inside
297 = -- STEP 1: Bring pattern-signature type variables into scope
298 tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
300 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
301 -- then do the thing inside
302 getLIE (tc_match_pats pats_w_tys thing_inside)
304 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
306 -- STEP 4: Check for existentially bound type variables
307 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
308 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
310 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
311 -- might need (via lie_req2) something made available from an 'outer'
312 -- pattern. But it's inconvenient to deal with, and I can't find an example
313 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
314 pats_w_tys body_ty `thenM` \ ex_binds ->
315 -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
316 -- For example, we must reject this program:
317 -- data C = forall a. C (a -> Int)
319 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
321 returnM (pats', result, HsBindGroup ex_binds [] Recursive)
323 tc_match_pats [] thing_inside
324 = thing_inside `thenM` \ answer ->
325 returnM ([], emptyBag, [], [], answer)
327 tc_match_pats ((pat,pat_ty):pats) thing_inside
328 = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
330 xve = bagToList pat_bndrs
331 ex_ids = [id | (_, id) <- xve]
332 -- ex_ids is all the pattern-bound Ids, a superset
333 -- of the existential Ids used in checkExistentialPat
335 tcExtendLocalValEnv2 xve $
336 tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
337 returnM ( pat':pats',
338 ex_tvs `unionBags` exs_tvs,
345 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
346 -> [TcId] -- Ids bound by this pattern; used
347 -- (a) by bindsInstsOfLocalFuns
348 -- (b) to generate helpful error messages
349 -> [Inst] -- and context
350 -> [Inst] -- Required context
351 -> [(pat,Expected TcRhoType)] -- Types of the patterns
352 -> Expected TcRhoType -- Type of the body of the match
353 -- Tyvars in either of these must not escape
354 -> TcM TcDictBinds -- LIE to float out and dict bindings
355 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
356 | isEmptyBag ex_tvs && all not_overloaded ex_ids
357 -- Short cut for case when there are no existentials
358 -- and no polymorphic overloaded variables
359 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
361 -- Here we must discharge op Methods
362 = ASSERT( null ex_lie )
363 extendLIEs lie_req `thenM_`
367 = -- Read the by-now-filled-in expected types
368 mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
369 addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
371 -- In case there are any polymorpic, overloaded binders in the pattern
372 -- (which can happen in the case of rank-2 type signatures, or data constructors
373 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
374 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
376 -- Deal with overloaded functions bound by the pattern
377 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
379 -- Check for type variable escape
380 checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
382 returnM (dict_binds `unionBags` inst_binds)
384 doc = text ("existential context of a data constructor")
385 tv_list = bagToList ex_tvs
386 not_overloaded id = not (isOverloadedTy (idType id))
390 %************************************************************************
392 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
394 %************************************************************************
397 tcDoStmts :: HsStmtContext Name
398 -> [LStmt Name] -> ReboundNames Name
399 -> TcRhoType -- To keep it simple, we don't have an "expected" type here
400 -> TcM ([LStmt TcId], ReboundNames TcId)
401 tcDoStmts PArrComp stmts method_names res_ty
402 = unifyPArrTy res_ty `thenM` \elt_ty ->
403 tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
404 returnM (stmts', [{- unused -}])
406 tcDoStmts ListComp stmts method_names res_ty
407 = unifyListTy res_ty ` thenM` \ elt_ty ->
408 tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
409 returnM (stmts', [{- unused -}])
411 tcDoStmts do_or_mdo stmts method_names res_ty
412 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
413 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
414 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
416 ctxt = SC { sc_what = do_or_mdo,
417 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
418 sc_body = \ body -> tcCheckRho body res_ty,
421 tcStmts ctxt stmts `thenM` \ stmts' ->
423 -- Build the then and zero methods in case we need them
424 -- It's important that "then" and "return" appear just once in the final LIE,
425 -- not only for typechecker efficiency, but also because otherwise during
426 -- simplification we end up with silly stuff like
427 -- then = case d of (t,r) -> t
429 -- where the second "then" sees that it already exists in the "available" stuff.
430 mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
432 returnM (stmts', methods)
434 tcComprehension do_or_lc mk_mty elt_ty stmts
437 ctxt = SC { sc_what = do_or_lc,
438 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
439 sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
440 sc_ty = mk_mty elt_ty }
444 %************************************************************************
448 %************************************************************************
450 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
452 [ (g x, h x) | ... ; let g v = ...
453 | ... ; let h v = ... ]
455 It's possible that g,h are overloaded, so we need to feed the LIE from the
456 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
457 Similarly if we had an existential pattern match:
459 data T = forall a. Show a => C a
461 [ (show x, show y) | ... ; C x <- ...
464 Then we need the LIE from (show x, show y) to be simplified against
465 the bindings for x and y.
467 It's difficult to do this in parallel, so we rely on the renamer to
468 ensure that g,h and x,y don't duplicate, and simply grow the environment.
469 So the binders of the first parallel group will be in scope in the second
470 group. But that's fine; there's no shadowing to worry about.
474 = ASSERT( notNull stmts )
475 tcStmtsAndThen (:) ctxt stmts (returnM [])
478 = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
479 sc_rhs :: LHsExpr Name -> TcType -> TcM (LHsExpr TcId), -- Type checker for RHS computations
480 sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation
481 sc_ty :: TcType } -- Return type; used *only* to check
482 -- for escape in existential patterns
484 :: (LStmt TcId -> thing -> thing) -- Combiner
491 tcStmtsAndThen combine ctxt [] thing_inside
494 tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
495 = tcStmtAndThen combine ctxt stmt $
496 tcStmtsAndThen combine ctxt stmts $
500 tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside
501 = tcBindsAndThen -- No error context, but a binding group is
502 (glue_binds combine) -- rather a large thing for an error context anyway
507 tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
508 = addSrcSpan src_loc $
509 addErrCtxt (stmtCtxt ctxt stmt) $
510 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
511 sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
512 tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
513 popErrCtxt thing_inside
514 ) `thenM` \ ([pat'], thing, dict_binds) ->
515 returnM (combine (L src_loc (BindStmt pat' exp'))
516 (glue_binds combine dict_binds thing))
519 tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
520 = addSrcSpan src_loc (
521 addErrCtxt (stmtCtxt ctxt stmt) $
522 if isDoExpr (sc_what ctxt)
523 then -- do or mdo; the expression is a computation
524 newTyVarTy openTypeKind `thenM` \ any_ty ->
525 sc_rhs ctxt exp any_ty `thenM` \ exp' ->
526 returnM (L src_loc (ExprStmt exp' any_ty))
527 else -- List comprehensions, pattern guards; expression is a boolean
528 tcCheckRho exp boolTy `thenM` \ exp' ->
529 returnM (L src_loc (ExprStmt exp' boolTy))
532 thing_inside `thenM` \ thing ->
533 returnM (combine stmt' thing)
537 tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
538 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
539 returnM (combine (L src_loc (ParStmt pairs')) thing)
541 loop [] = thing_inside `thenM` \ thing ->
544 loop ((stmts, bndrs) : pairs)
545 = tcStmtsAndThen combine_par ctxt stmts $
546 -- Notice we pass on ctxt; the result type is used only
547 -- to get escaping type variables for checkExistentialPat
548 tcLookupLocalIds bndrs `thenM` \ bndrs' ->
549 loop pairs `thenM` \ (pairs', thing) ->
550 returnM (([], bndrs') : pairs', thing)
552 combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
555 tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
556 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
558 rec_ids = zipWith mkLocalId recNames recTys
560 tcExtendLocalValEnv rec_ids $
561 tcStmtsAndThen combine_rec ctxt stmts (
562 mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
563 tcLookupLocalIds laterNames `thenM` \ later_ids ->
564 returnM ([], (later_ids, rec_rets))
565 ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
567 tcExtendLocalValEnv later_ids $
568 -- NB: The rec_ids for the recursive things
569 -- already scope over this part
570 thing_inside `thenM` \ thing ->
572 returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing)
574 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
576 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
577 tc_ret (rec_name, mono_ty)
578 = tcLookupId rec_name `thenM` \ poly_id ->
579 -- poly_id may have a polymorphic type
580 -- but mono_ty is just a monomorphic type variable
581 tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
582 returnM (L src_loc (co_fn <$> HsVar poly_id))
585 tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside
586 = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
587 thing_inside `thenM` \ thing ->
588 returnM (combine (L src_loc (ResultStmt exp')) thing)
591 ------------------------------
592 glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing
593 -- ToDo: fix the noLoc
597 %************************************************************************
599 \subsection{Errors and contexts}
601 %************************************************************************
603 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
604 number of args are used in each equation.
607 sameNoOfArgs :: [LMatch Name] -> Bool
608 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
610 args_in_match :: LMatch Name -> Int
611 args_in_match (L _ (Match pats _ _)) = length pats
615 varyingArgsErr name matches
616 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
618 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
619 4 (pprMatch ctxt match)
621 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
623 pp_ctxt = case stmt of
624 ResultStmt _ -> pprStmtResultContext
625 other -> pprStmtContext
627 sigPatCtxt bound_tvs bound_ids tys tidy_env
628 = -- tys is (body_ty : pat_tys)
629 mapM zonkTcType tys `thenM` \ tys' ->
631 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
632 (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
635 sep [ptext SLIT("When checking an existential match that binds"),
636 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
637 ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
638 ptext SLIT("The body has type:") <+> ppr tidy_body_ty
641 show_ids = filter is_interesting bound_ids
642 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
644 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
645 -- Don't zonk the types so we get the separate, un-unified versions