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, typeKind,
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 = newTyVarTy openTypeKind `thenM` \ scrut_ty ->
107 -- openTypeKind because the scrutinee can be an unboxed type
108 tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
109 returnM (scrut_ty, matches')
111 tcMatchesCase ctxt matches (Infer hole)
112 = newHole `thenM` \ fun_hole ->
113 tcMatches ctxt 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 :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId)
122 tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match
124 match_ctxt = MC { mc_what = LambdaExpr,
125 mc_body = tcMonoExpr }
128 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
131 tcGRHSsPat :: GRHSs Name
132 -> Expected TcRhoType
134 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
136 match_ctxt = MC { mc_what = PatBindRhs,
137 mc_body = tcMonoExpr }
141 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
142 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
143 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
144 -> Expected TcRhoType
145 -> TcM (LHsExpr TcId) }
147 tcMatches :: TcMatchCtxt
149 -> Expected TcRhoType
152 tcMatches ctxt matches exp_ty
153 = -- If there is more than one branch, and exp_ty is a 'hole',
154 -- all branches must be types, not type schemes, otherwise the
155 -- order in which we check them would affect the result.
156 zapExpectedBranches matches exp_ty `thenM` \ exp_ty' ->
157 mappM (tcMatch ctxt exp_ty') matches
161 %************************************************************************
165 %************************************************************************
168 tcMatch :: TcMatchCtxt
169 -> Expected TcRhoType -- Expected result-type of the Match.
170 -- Early unification with this guy gives better error messages
171 -- We regard the Match as having type
172 -- (ty1 -> ... -> tyn -> result_ty)
173 -- where there are n patterns.
177 tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match
179 tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss)
180 = addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back
181 subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
182 -- This is the unique place we call subFunTys
183 -- The point is that if expected_y is a "hole", we want
184 -- to make arg_ty and rest_ty as "holes" too.
185 tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
186 returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
190 = case maybe_rhs_sig of -- Deal with the result signature
191 Nothing -> tcGRHSs ctxt grhss rhs_ty
193 Just sig -> tcAddScopedTyVars [sig] $
194 -- Bring into scope the type variables in the signature
195 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
196 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
198 -- Pushes the coercion down to the right hand sides,
199 -- because there is no convenient place to hang it otherwise.
200 if isIdCoercion co_fn then
203 readExpectedType rhs_ty `thenM` \ rhs_ty' ->
204 returnM (lift_grhss co_fn rhs_ty' grhss')
206 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
207 = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty -- Change the type, since the coercion does
209 lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
211 lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
212 lift_stmt stmt = stmt
214 tcGRHSs :: TcMatchCtxt -> GRHSs Name
215 -> Expected TcRhoType
218 -- Special case when there is just one equation with a degenerate
219 -- guard; then we pass in the full Expected type, so that we get
220 -- good inference from simple things like
221 -- f = \(x::forall a.a->a) -> <stuff>
222 -- This is a consequence of the fact that tcStmts takes a TcType,
223 -- not a Expected TcType, a decision we could revisit if necessary
224 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty
225 = tcBindsAndThen glueBindsOnGRHSs binds $
226 mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
227 readExpectedType exp_ty `thenM` \ exp_ty' ->
228 returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty')
230 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
231 = tcBindsAndThen glueBindsOnGRHSs binds $
232 zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
233 -- Even if there is only one guard, we zap the RHS type to
234 -- a monotype. Reason: it makes tcStmts much easier,
235 -- and even a one-armed guard has a notional second arm
237 stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
241 sc_body body = mc_body ctxt body (Check exp_ty')
243 tc_grhs (GRHS guarded)
244 = tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
245 returnM (GRHS guarded')
247 mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
248 returnM (GRHSs grhss' [] exp_ty')
253 tcThingWithSig :: TcSigmaType -- Type signature
254 -> (TcRhoType -> TcM r) -- How to type check the thing inside
255 -> Expected TcRhoType -- Overall expected result type
257 -- Used for expressions with a type signature, and for result type signatures
259 tcThingWithSig sig_ty thing_inside res_ty
260 | not (isSigmaTy sig_ty)
261 = thing_inside sig_ty `thenM` \ result ->
262 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
263 returnM (co_fn, result)
265 | otherwise -- The signature has some outer foralls
266 = -- Must instantiate the outer for-alls of sig_tc_ty
267 -- else we risk instantiating a ? res_ty to a forall-type
268 -- which breaks the invariant that tcMonoExpr only returns phi-types
269 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
270 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
271 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
272 returnM (co_fn <.> inst_fn <.> gen_fn, result)
273 -- Note that we generalise, then instantiate. Ah well.
277 %************************************************************************
279 \subsection{tcMatchPats}
281 %************************************************************************
285 :: [(LPat Name, Expected TcRhoType)]
286 -> Expected TcRhoType
288 -> TcM ([LPat TcId], a, HsBindGroup TcId)
289 -- Typecheck the patterns, extend the environment to bind the variables,
290 -- do the thing inside, use any existentially-bound dictionaries to
291 -- discharge parts of the returning LIE, and deal with pattern type
294 tcMatchPats pats_w_tys body_ty thing_inside
295 = -- STEP 1: Bring pattern-signature type variables into scope
296 tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
298 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
299 -- then do the thing inside
300 getLIE (tc_match_pats pats_w_tys thing_inside)
302 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
304 -- STEP 4: Check for existentially bound type variables
305 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
306 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
308 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
309 -- might need (via lie_req2) something made available from an 'outer'
310 -- pattern. But it's inconvenient to deal with, and I can't find an example
311 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
312 pats_w_tys body_ty `thenM` \ ex_binds ->
313 -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
314 -- For example, we must reject this program:
315 -- data C = forall a. C (a -> Int)
317 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
319 returnM (pats', result, HsBindGroup ex_binds [] Recursive)
321 tc_match_pats [] thing_inside
322 = thing_inside `thenM` \ answer ->
323 returnM ([], emptyBag, [], [], answer)
325 tc_match_pats ((pat,pat_ty):pats) thing_inside
326 = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
328 xve = bagToList pat_bndrs
329 ex_ids = [id | (_, id) <- xve]
330 -- ex_ids is all the pattern-bound Ids, a superset
331 -- of the existential Ids used in checkExistentialPat
333 tcExtendLocalValEnv2 xve $
334 traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$
335 ppr (map (typeKind . idType . snd) xve))) `thenM_`
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 liftedTypeKind `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