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(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
19 MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
21 pprMatch, getMatchLoc, isDoExpr,
22 pprMatchContext, pprStmtContext, pprStmtResultContext,
23 mkMonoBind, collectSigTysFromPats, glueBindsOnGRHSs
25 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr,
26 RenamedPat, RenamedMatchContext )
27 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr,
28 TcPat, TcStmt, ExprCoFn,
29 isIdCoercion, (<$>), (<.>) )
32 import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
33 import Inst ( tcSyntaxName, tcInstCall )
34 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
35 import TcPat ( tcPat, tcMonoPatBndr )
36 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
37 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
38 tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
39 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
40 mkArrowKind, mkAppTy )
41 import TcBinds ( tcBindsAndThen )
42 import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
43 unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
44 checkSigTyVarsWrt, tcSubExp, tcGen )
45 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
47 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
48 import Id ( idType, mkLocalId )
49 import CoreFVs ( idFreeTyVars )
50 import BasicTypes ( RecFlag(..) )
53 import Util ( isSingleton, notNull )
59 %************************************************************************
61 \subsection{tcMatchesFun, tcMatchesCase}
63 %************************************************************************
65 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
66 @FunMonoBind@. The second argument is the name of the function, which
67 is used in error messages. It checks that all the equations have the
68 same number of arguments before using @tcMatches@ to do the work.
73 -> Expected TcRhoType -- Expected type
76 tcMatchesFun fun_name matches@(first_match:_) expected_ty
77 = -- Check that they all have the same no of arguments
78 -- Set the location to that of the first equation, so that
79 -- any inter-equation error messages get some vaguely
80 -- sensible location. Note: we have to do this odd
81 -- ann-grabbing, because we don't always have annotations in
82 -- hand when we call tcMatchesFun...
83 addSrcLoc (getMatchLoc first_match) (
84 checkTc (sameNoOfArgs matches)
85 (varyingArgsErr fun_name matches)
88 -- ToDo: Don't use "expected" stuff if there ain't a type signature
89 -- because inconsistency between branches
90 -- may show up as something wrong with the (non-existent) type signature
92 -- No need to zonk expected_ty, because subFunTys does that on the fly
93 tcMatches match_ctxt matches expected_ty
95 match_ctxt = MC { mc_what = FunRhs fun_name,
96 mc_body = tcMonoExpr }
99 @tcMatchesCase@ doesn't do the argument-count check because the
100 parser guarantees that each equation has exactly one argument.
103 tcMatchesCase :: TcMatchCtxt -- Case context
104 -> [RenamedMatch] -- The case alternatives
105 -> Expected TcRhoType -- Type of whole case expressions
106 -> TcM (TcRhoType, -- Inferred type of the scrutinee
107 [TcMatch]) -- Translated alternatives
109 tcMatchesCase ctxt matches (Check expr_ty)
110 = -- This case is a bit yukky, because it prevents the
111 -- scrutinee being higher-ranked, which might just possible
112 -- matter if we were seq'ing on it. But it's awkward to fix.
113 newTyVarTy openTypeKind `thenM` \ scrut_ty ->
114 tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
115 returnM (scrut_ty, matches')
117 tcMatchesCase ctxt matches (Infer hole)
118 = newHole `thenM` \ fun_hole ->
119 tcMatches ctxt matches (Infer fun_hole) `thenM` \ matches' ->
120 readMutVar fun_hole `thenM` \ fun_ty ->
121 -- The result of tcMatches is bound to be a function type
122 unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
123 writeMutVar hole res_ty `thenM_`
124 returnM (scrut_ty, matches')
127 tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
128 tcMatchLambda match res_ty = tcMatch match_ctxt match res_ty
130 match_ctxt = MC { mc_what = LambdaExpr,
131 mc_body = tcMonoExpr }
134 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
137 tcGRHSsPat :: RenamedGRHSs
138 -> Expected TcRhoType
140 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
142 match_ctxt = MC { mc_what = PatBindRhs,
143 mc_body = tcMonoExpr }
147 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
148 = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is
149 mc_body :: RenamedHsExpr -- Type checker for a body of an alternative
150 -> Expected TcRhoType
153 tcMatches :: TcMatchCtxt
155 -> Expected TcRhoType
158 tcMatches ctxt matches exp_ty
159 = -- If there is more than one branch, and exp_ty is a 'hole',
160 -- all branches must be types, not type schemes, otherwise the
161 -- order in which we check them would affect the result.
162 zapExpectedBranches matches exp_ty `thenM` \ exp_ty' ->
163 mappM (tc_match exp_ty') matches
165 tc_match exp_ty match = tcMatch ctxt match exp_ty
169 %************************************************************************
173 %************************************************************************
176 tcMatch :: TcMatchCtxt
178 -> Expected TcRhoType -- Expected result-type of the Match.
179 -- Early unification with this guy gives better error messages
180 -- We regard the Match as having type
181 -- (ty1 -> ... -> tyn -> result_ty)
182 -- where there are n patterns.
185 tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
186 = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
187 addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back
188 subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
189 -- This is the unique place we call subFunTys
190 -- The point is that if expected_y is a "hole", we want
191 -- to make arg_ty and rest_ty as "holes" too.
192 tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
193 returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
197 = case maybe_rhs_sig of -- Deal with the result signature
198 Nothing -> tcGRHSs ctxt grhss rhs_ty
200 Just sig -> tcAddScopedTyVars [sig] $
201 -- Bring into scope the type variables in the signature
202 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
203 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
205 -- Pushes the coercion down to the right hand sides,
206 -- because there is no convenient place to hang it otherwise.
207 if isIdCoercion co_fn then
210 readExpectedType rhs_ty `thenM` \ rhs_ty' ->
211 returnM (lift_grhss co_fn rhs_ty' grhss')
213 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
214 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since the coercion does
216 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
218 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
219 lift_stmt stmt = stmt
221 tcGRHSs :: TcMatchCtxt -> RenamedGRHSs
222 -> Expected TcRhoType
225 -- Special case when there is just one equation with a degenerate
226 -- guard; then we pass in the full Expected type, so that we get
227 -- good inference from simple things like
228 -- f = \(x::forall a.a->a) -> <stuff>
229 -- This is a consequence of the fact that tcStmts takes a TcType,
230 -- not a Expected TcType, a decision we could revisit if necessary
231 tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
232 = tcBindsAndThen glueBindsOnGRHSs binds $
233 mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
234 readExpectedType exp_ty `thenM` \ exp_ty' ->
235 returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
237 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
238 = tcBindsAndThen glueBindsOnGRHSs binds $
239 zapExpectedType exp_ty `thenM` \ exp_ty' ->
240 -- Even if there is only one guard, we zap the RHS type to
241 -- a monotype. Reason: it makes tcStmts much easier,
242 -- and even a one-armed guard has a notional second arm
244 stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
248 sc_body body = mc_body ctxt body (Check exp_ty')
250 tc_grhs (GRHS guarded locn)
252 tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
253 returnM (GRHS guarded' locn)
255 mappM tc_grhs grhss `thenM` \ grhss' ->
256 returnM (GRHSs grhss' EmptyBinds exp_ty')
261 tcThingWithSig :: TcSigmaType -- Type signature
262 -> (TcRhoType -> TcM r) -- How to type check the thing inside
263 -> Expected TcRhoType -- Overall expected result type
265 -- Used for expressions with a type signature, and for result type signatures
267 tcThingWithSig sig_ty thing_inside res_ty
268 | not (isSigmaTy sig_ty)
269 = thing_inside sig_ty `thenM` \ result ->
270 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
271 returnM (co_fn, result)
273 | otherwise -- The signature has some outer foralls
274 = -- Must instantiate the outer for-alls of sig_tc_ty
275 -- else we risk instantiating a ? res_ty to a forall-type
276 -- which breaks the invariant that tcMonoExpr only returns phi-types
277 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
278 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
279 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
280 returnM (co_fn <.> inst_fn <.> gen_fn, result)
281 -- Note that we generalise, then instantiate. Ah well.
285 %************************************************************************
287 \subsection{tcMatchPats}
289 %************************************************************************
293 :: [(RenamedPat, Expected TcRhoType)]
294 -> Expected TcRhoType
296 -> TcM ([TcPat], a, TcHsBinds)
297 -- Typecheck the patterns, extend the environment to bind the variables,
298 -- do the thing inside, use any existentially-bound dictionaries to
299 -- discharge parts of the returning LIE, and deal with pattern type
302 tcMatchPats pats_w_tys body_ty thing_inside
303 = -- STEP 1: Bring pattern-signature type variables into scope
304 tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
306 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
307 -- then do the thing inside
308 getLIE (tc_match_pats pats_w_tys thing_inside)
310 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
312 -- STEP 4: Check for existentially bound type variables
313 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
314 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
316 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
317 -- might need (via lie_req2) something made available from an 'outer'
318 -- pattern. But it's inconvenient to deal with, and I can't find an example
319 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
320 pats_w_tys body_ty `thenM` \ ex_binds ->
321 -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
322 -- For example, we must reject this program:
323 -- data C = forall a. C (a -> Int)
325 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
327 returnM (pats', result, mkMonoBind Recursive ex_binds)
329 tc_match_pats [] thing_inside
330 = thing_inside `thenM` \ answer ->
331 returnM ([], emptyBag, [], [], answer)
333 tc_match_pats ((pat,pat_ty):pats) thing_inside
334 = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
336 xve = bagToList pat_bndrs
337 ex_ids = [id | (_, id) <- xve]
338 -- ex_ids is all the pattern-bound Ids, a superset
339 -- of the existential Ids used in checkExistentialPat
341 tcExtendLocalValEnv2 xve $
342 tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
343 returnM ( pat':pats',
344 ex_tvs `unionBags` exs_tvs,
351 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
352 -> [TcId] -- Ids bound by this pattern; used
353 -- (a) by bindsInstsOfLocalFuns
354 -- (b) to generate helpful error messages
355 -> [Inst] -- and context
356 -> [Inst] -- Required context
357 -> [(pat,Expected TcRhoType)] -- Types of the patterns
358 -> Expected TcRhoType -- Type of the body of the match
359 -- Tyvars in either of these must not escape
360 -> TcM TcDictBinds -- LIE to float out and dict bindings
361 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
362 | isEmptyBag ex_tvs && all not_overloaded ex_ids
363 -- Short cut for case when there are no existentials
364 -- and no polymorphic overloaded variables
365 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
367 -- Here we must discharge op Methods
368 = ASSERT( null ex_lie )
369 extendLIEs lie_req `thenM_`
370 returnM EmptyMonoBinds
373 = -- Read the by-now-filled-in expected types
374 mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
375 addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
377 -- In case there are any polymorpic, overloaded binders in the pattern
378 -- (which can happen in the case of rank-2 type signatures, or data constructors
379 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
380 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
382 -- Deal with overloaded functions bound by the pattern
383 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
385 -- Check for type variable escape
386 checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
388 returnM (dict_binds `AndMonoBinds` inst_binds)
390 doc = text ("existential context of a data constructor")
391 tv_list = bagToList ex_tvs
392 not_overloaded id = not (isOverloadedTy (idType id))
396 %************************************************************************
398 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
400 %************************************************************************
403 tcDoStmts :: HsStmtContext Name
404 -> [RenamedStmt] -> ReboundNames Name
405 -> TcRhoType -- To keep it simple, we don't have an "expected" type here
406 -> TcM ([TcStmt], ReboundNames TcId)
407 tcDoStmts PArrComp stmts method_names res_ty
408 = unifyPArrTy res_ty `thenM` \elt_ty ->
409 tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
410 returnM (stmts', [{- unused -}])
412 tcDoStmts ListComp stmts method_names res_ty
413 = unifyListTy res_ty ` thenM` \ elt_ty ->
414 tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
415 returnM (stmts', [{- unused -}])
417 tcDoStmts do_or_mdo stmts method_names res_ty
418 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
419 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
420 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
422 ctxt = SC { sc_what = do_or_mdo,
423 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
424 sc_body = \ body -> tcCheckRho body res_ty,
427 tcStmts ctxt stmts `thenM` \ stmts' ->
429 -- Build the then and zero methods in case we need them
430 -- It's important that "then" and "return" appear just once in the final LIE,
431 -- not only for typechecker efficiency, but also because otherwise during
432 -- simplification we end up with silly stuff like
433 -- then = case d of (t,r) -> t
435 -- where the second "then" sees that it already exists in the "available" stuff.
436 mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
438 returnM (stmts', methods)
440 tcComprehension do_or_lc mk_mty elt_ty stmts
443 ctxt = SC { sc_what = do_or_lc,
444 sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
445 sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
446 sc_ty = mk_mty elt_ty }
450 %************************************************************************
454 %************************************************************************
456 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
458 [ (g x, h x) | ... ; let g v = ...
459 | ... ; let h v = ... ]
461 It's possible that g,h are overloaded, so we need to feed the LIE from the
462 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
463 Similarly if we had an existential pattern match:
465 data T = forall a. Show a => C a
467 [ (show x, show y) | ... ; C x <- ...
470 Then we need the LIE from (show x, show y) to be simplified against
471 the bindings for x and y.
473 It's difficult to do this in parallel, so we rely on the renamer to
474 ensure that g,h and x,y don't duplicate, and simply grow the environment.
475 So the binders of the first parallel group will be in scope in the second
476 group. But that's fine; there's no shadowing to worry about.
480 = ASSERT( notNull stmts )
481 tcStmtsAndThen (:) ctxt stmts (returnM [])
484 = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
485 sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations
486 sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation
487 sc_ty :: TcType } -- Return type; used *only* to check
488 -- for escape in existential patterns
490 :: (TcStmt -> thing -> thing) -- Combiner
497 tcStmtsAndThen combine ctxt [] thing_inside
500 tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
501 = tcStmtAndThen combine ctxt stmt $
502 tcStmtsAndThen combine ctxt stmts $
506 tcStmtAndThen combine ctxt (LetStmt binds) thing_inside
507 = tcBindsAndThen -- No error context, but a binding group is
508 (glue_binds combine) -- rather a large thing for an error context anyway
513 tcStmtAndThen combine ctxt stmt@(BindStmt pat exp src_loc) thing_inside
514 = addSrcLoc src_loc $
515 addErrCtxt (stmtCtxt ctxt stmt) $
516 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
517 sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
518 tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
519 popErrCtxt thing_inside
520 ) `thenM` \ ([pat'], thing, dict_binds) ->
521 returnM (combine (BindStmt pat' exp' src_loc)
522 (glue_binds combine dict_binds thing))
525 tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside
526 = addSrcLoc src_loc (
527 addErrCtxt (stmtCtxt ctxt stmt) $
528 if isDoExpr (sc_what ctxt)
529 then -- do or mdo; the expression is a computation
530 newTyVarTy openTypeKind `thenM` \ any_ty ->
531 sc_rhs ctxt exp any_ty `thenM` \ exp' ->
532 returnM (ExprStmt exp' any_ty src_loc)
533 else -- List comprehensions, pattern guards; expression is a boolean
534 tcCheckRho exp boolTy `thenM` \ exp' ->
535 returnM (ExprStmt exp' boolTy src_loc)
538 thing_inside `thenM` \ thing ->
539 returnM (combine stmt' thing)
543 tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside
544 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
545 returnM (combine (ParStmt pairs') thing)
547 loop [] = thing_inside `thenM` \ thing ->
550 loop ((stmts, bndrs) : pairs)
551 = tcStmtsAndThen combine_par ctxt stmts $
552 -- Notice we pass on ctxt; the result type is used only
553 -- to get escaping type variables for checkExistentialPat
554 tcLookupLocalIds bndrs `thenM` \ bndrs' ->
555 loop pairs `thenM` \ (pairs', thing) ->
556 returnM (([], bndrs') : pairs', thing)
558 combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
561 tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside
562 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
564 rec_ids = zipWith mkLocalId recNames recTys
566 tcExtendLocalValEnv rec_ids $
567 tcStmtsAndThen combine_rec ctxt stmts (
568 mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
569 tcLookupLocalIds laterNames `thenM` \ later_ids ->
570 returnM ([], (later_ids, rec_rets))
571 ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
573 tcExtendLocalValEnv later_ids $
574 -- NB: The rec_ids for the recursive things
575 -- already scope over this part
576 thing_inside `thenM` \ thing ->
578 returnM (combine (RecStmt stmts' later_ids rec_ids rec_rets) thing)
580 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
582 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
583 tc_ret (rec_name, mono_ty)
584 = tcLookupId rec_name `thenM` \ poly_id ->
585 -- poly_id may have a polymorphic type
586 -- but mono_ty is just a monomorphic type variable
587 tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
588 returnM (co_fn <$> HsVar poly_id)
591 tcStmtAndThen combine ctxt stmt@(ResultStmt exp locn) thing_inside
592 = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
593 thing_inside `thenM` \ thing ->
594 returnM (combine (ResultStmt exp' locn) thing)
597 ------------------------------
598 glue_binds combine EmptyBinds thing = thing
599 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
603 %************************************************************************
605 \subsection{Errors and contexts}
607 %************************************************************************
609 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
610 number of args are used in each equation.
613 sameNoOfArgs :: [RenamedMatch] -> Bool
614 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
616 args_in_match :: RenamedMatch -> Int
617 args_in_match (Match pats _ _) = length pats
621 varyingArgsErr name matches
622 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
624 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
625 4 (pprMatch ctxt match)
627 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
629 pp_ctxt = case stmt of
630 ResultStmt _ _ -> pprStmtResultContext
631 other -> pprStmtContext
633 sigPatCtxt bound_tvs bound_ids tys tidy_env
634 = -- tys is (body_ty : pat_tys)
635 mapM zonkTcType tys `thenM` \ tys' ->
637 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
638 (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
641 sep [ptext SLIT("When checking an existential match that binds"),
642 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
643 ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
644 ptext SLIT("The body has type:") <+> ppr tidy_body_ty
647 show_ids = filter is_interesting bound_ids
648 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
650 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
651 -- Don't zonk the types so we get the separate, un-unified versions