2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
8 tcMatchPats, matchCtxt, TcMatchCtxt(..),
10 tcDoStmt, tcMDoStmt, tcGuardStmt,
14 #include "HsVersions.h"
16 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcCheckRho, tcInferRho, tcMonoExpr, tcCheckSigma )
18 import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
19 Match(..), LMatch, GRHSs(..), GRHS(..),
20 Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
21 LPat, pprMatch, isIrrefutableHsPat,
22 pprMatchContext, pprStmtContext, pprMatchRhsContext,
23 collectPatsBinders, noSyntaxExpr
25 import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
28 import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) )
29 import Inst ( tcInstCall, newMethodFromName )
30 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
32 import TcPat ( PatCtxt(..), tcPats )
33 import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType )
34 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
35 tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
36 liftedTypeKind, openTypeKind, mkFunTy, mkAppTy )
37 import TcBinds ( tcLocalBinds )
38 import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
39 unifyTauTy, subFunTys, unifyTyConApp,
40 checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
41 unifyAppTy, zapToListTy, zapToTyConApp )
42 import TcSimplify ( bindInstsOfLocalFuns )
44 import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
45 import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
46 import Id ( idType, mkLocalId )
47 import TyCon ( TyCon )
48 import CoreFVs ( idFreeTyVars )
50 import Util ( isSingleton )
52 import SrcLoc ( Located(..) )
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 of function
72 -> TcM (MatchGroup TcId) -- Returns type of body
74 tcMatchesFun fun_name matches exp_ty
75 = do { -- 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) (varyingArgsErr fun_name matches)
83 -- ToDo: Don't use "expected" stuff if there ain't a type signature
84 -- because inconsistency between branches
85 -- may show up as something wrong with the (non-existent) type signature
87 -- This is one of two places places we call subFunTys
88 -- The point is that if expected_y is a "hole", we want
89 -- to make pat_tys and rhs_ty as "holes" too.
90 ; exp_ty' <- zapExpectedBranches matches exp_ty
91 ; subFunTys ctxt matches exp_ty' $ \ pat_tys rhs_ty ->
92 tcMatches match_ctxt pat_tys rhs_ty matches
95 ctxt = FunRhs fun_name
96 match_ctxt = MC { mc_what = ctxt, 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 -> TcRhoType -- Type of scrutinee
105 -> MatchGroup Name -- The case alternatives
106 -> Expected TcRhoType -- Type of whole case expressions
107 -> TcM (MatchGroup TcId) -- Translated alternatives
109 tcMatchesCase ctxt scrut_ty matches exp_ty
110 = do { exp_ty' <- zapExpectedBranches matches exp_ty
111 ; tcMatches ctxt [Check scrut_ty] exp_ty' matches }
113 tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId)
114 tcMatchLambda match exp_ty -- One branch so no unifyBranches needed
115 = subFunTys LambdaExpr match exp_ty $ \ pat_tys rhs_ty ->
116 tcMatches match_ctxt pat_tys rhs_ty match
118 match_ctxt = MC { mc_what = LambdaExpr,
119 mc_body = tcMonoExpr }
122 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
125 tcGRHSsPat :: GRHSs Name
126 -> Expected TcRhoType
128 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
130 match_ctxt = MC { mc_what = PatBindRhs,
131 mc_body = tcMonoExpr }
135 %************************************************************************
139 %************************************************************************
142 tcMatches :: TcMatchCtxt
143 -> [Expected TcRhoType] -- Expected pattern types
144 -> Expected TcRhoType -- Expected result-type of the Match.
146 -> TcM (MatchGroup TcId)
148 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
149 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
150 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
151 -> Expected TcRhoType
152 -> TcM (LHsExpr TcId) }
154 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
155 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
156 ; pat_tys' <- mapM readExpectedType pat_tys
157 ; rhs_ty' <- readExpectedType rhs_ty
158 ; return (MatchGroup matches' (mkFunTys pat_tys' rhs_ty')) }
161 tcMatch :: TcMatchCtxt
162 -> [Expected TcRhoType] -- Expected pattern types
163 -> Expected TcRhoType -- Expected result-type of the Match.
167 tcMatch ctxt pat_tys rhs_ty match
168 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
170 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
171 = addErrCtxt (matchCtxt (mc_what ctxt) match) $
172 do { (pats', grhss') <- tcMatchPats pats pat_tys rhs_ty $
173 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
174 ; returnM (Match pats' Nothing grhss') }
178 tc_grhss ctxt Nothing grhss rhs_ty
179 = tcGRHSs ctxt grhss rhs_ty -- No result signature
181 tc_grhss ctxt (Just res_sig) grhss rhs_ty
182 = do { (sig_tvs, sig_ty) <- tcHsPatSigType ResSigCtxt res_sig
183 ; traceTc (text "tc_grhss" <+> ppr sig_tvs)
184 ; (co_fn, grhss') <- tcExtendTyVarEnv sig_tvs $
185 tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty
187 -- Push the coercion down to the right hand sides,
188 -- because there is no convenient place to hang it otherwise.
189 ; if isIdCoercion co_fn then
192 return (lift_grhss co_fn grhss') }
195 lift_grhss co_fn (GRHSs grhss binds)
196 = GRHSs (map (fmap lift_grhs) grhss) binds
198 lift_grhs (GRHS stmts rhs) = GRHS stmts (fmap (co_fn <$>) rhs)
201 tcGRHSs :: TcMatchCtxt -> GRHSs Name
202 -> Expected TcRhoType
205 -- Special case when there is just one equation with a degenerate
206 -- guard; then we pass in the full Expected type, so that we get
207 -- good inference from simple things like
208 -- f = \(x::forall a.a->a) -> <stuff>
209 -- This is a consequence of the fact that tcStmts takes a TcType,
210 -- not a Expected TcType, a decision we could revisit if necessary
211 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty
212 = do { (binds', rhs') <- tcLocalBinds binds $
213 mc_body ctxt rhs exp_ty
214 ; returnM (GRHSs [L loc1 (GRHS [] rhs')] binds') }
216 tcGRHSs ctxt (GRHSs grhss binds) exp_ty
217 = do { exp_ty' <- zapExpectedType exp_ty openTypeKind
218 -- Even if there is only one guard, we zap the RHS type to
219 -- a monotype. Reason: it makes tcStmts much easier,
220 -- and even a one-armed guard has a notional second arm
222 ; (binds', grhss') <- tcLocalBinds binds $
223 mappM (wrapLocM (tcGRHS ctxt exp_ty')) grhss
225 ; returnM (GRHSs grhss' binds') }
228 tcGRHS :: TcMatchCtxt -> TcRhoType
229 -> GRHS Name -> TcM (GRHS TcId)
231 tcGRHS ctxt exp_ty' (GRHS guards rhs)
232 = do { (guards', rhs') <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
233 addErrCtxt (grhsCtxt match_ctxt rhs) $
234 tcCheckRho rhs exp_ty'
235 ; return (GRHS guards' rhs') }
237 match_ctxt = mc_what ctxt
238 stmt_ctxt = PatGuard match_ctxt
243 tcThingWithSig :: TcSigmaType -- Type signature
244 -> (TcRhoType -> TcM r) -- How to type check the thing inside
245 -> Expected TcRhoType -- Overall expected result type
247 -- Used for expressions with a type signature, and for result type signatures
249 tcThingWithSig sig_ty thing_inside res_ty
250 | not (isSigmaTy sig_ty)
251 = thing_inside sig_ty `thenM` \ result ->
252 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
253 returnM (co_fn, result)
255 | otherwise -- The signature has some outer foralls
256 = -- Must instantiate the outer for-alls of sig_tc_ty
257 -- else we risk instantiating a ? res_ty to a forall-type
258 -- which breaks the invariant that tcMonoExpr only returns phi-types
259 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
260 tcInstCall InstSigOrigin sig_ty `thenM` \ (inst_fn, _, inst_sig_ty) ->
261 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
262 returnM (co_fn <.> inst_fn <.> gen_fn, result)
263 -- Note that we generalise, then instantiate. Ah well.
267 %************************************************************************
269 \subsection{tcMatchPats}
271 %************************************************************************
274 tcMatchPats :: [LPat Name]
275 -> [Expected TcSigmaType] -- Pattern types
276 -> Expected TcRhoType -- Result type;
277 -- used only to check existential escape
279 -> TcM ([LPat TcId], a)
280 -- Typecheck the patterns, extend the environment to bind the variables,
281 -- do the thing inside, use any existentially-bound dictionaries to
282 -- discharge parts of the returning LIE, and deal with pattern type
285 tcMatchPats pats tys body_ty thing_inside
286 = do { (pats', ex_tvs, res) <- tcPats LamPat pats tys thing_inside
287 ; tcCheckExistentialPat pats' ex_tvs tys body_ty
288 ; returnM (pats', res) }
290 tcCheckExistentialPat :: [LPat TcId] -- Patterns (just for error message)
291 -> [TcTyVar] -- Existentially quantified tyvars bound by pattern
292 -> [Expected TcSigmaType] -- Types of the patterns
293 -> Expected TcRhoType -- Type of the body of the match
294 -- Tyvars in either of these must not escape
296 -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
297 -- For example, we must reject this program:
298 -- data C = forall a. C (a -> Int)
300 -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
302 tcCheckExistentialPat pats [] pat_tys body_ty
303 = return () -- Short cut for case when there are no existentials
305 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
306 = do { tys <- mapM readExpectedType (body_ty : pat_tys)
307 ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $
308 checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs }
312 %************************************************************************
314 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
316 %************************************************************************
319 tcDoStmts :: HsStmtContext Name
322 -> Expected TcRhoType
323 -> TcM (HsExpr TcId) -- Returns a HsDo
324 tcDoStmts ListComp stmts body res_ty
325 = do { elt_ty <- zapToListTy res_ty
326 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
327 addErrCtxt (doBodyCtxt ListComp body) $
328 tcCheckRho body elt_ty
329 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
331 tcDoStmts PArrComp stmts body res_ty
332 = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
333 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
334 addErrCtxt (doBodyCtxt PArrComp body) $
335 tcCheckRho body elt_ty
336 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
338 tcDoStmts DoExpr stmts body res_ty
339 = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
340 ; (m_ty, _) <- unifyAppTy res_ty'
341 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
342 addErrCtxt (doBodyCtxt DoExpr body) $
343 tcCheckRho body res_ty'
344 ; return (HsDo DoExpr stmts' body' res_ty') }
346 tcDoStmts cxt@(MDoExpr _) stmts body res_ty
347 = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
348 ; (m_ty, _) <- unifyAppTy res_ty'
349 ; let tc_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
350 ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
351 ; unifyTauTy m_ty n_ty
352 ; return (rhs', pat_ty) }
354 ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
355 addErrCtxt (doBodyCtxt cxt body) $
356 tcCheckRho body res_ty'
358 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
359 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
360 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
362 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
366 %************************************************************************
370 %************************************************************************
374 = forall thing. HsStmtContext Name
377 -> TcM (Stmt TcId, thing)
379 tcStmts :: HsStmtContext Name
380 -> TcStmtChecker -- NB: higher-rank type
383 -> TcM ([LStmt TcId], thing)
385 -- Note the higher-rank type. stmt_chk is applied at different
386 -- types in the equations for tcStmts
388 tcStmts ctxt stmt_chk [] thing_inside
389 = do { thing <- thing_inside
390 ; return ([], thing) }
392 -- LetStmts are handled uniformly, regardless of context
393 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
394 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
395 tcStmts ctxt stmt_chk stmts thing_inside
396 ; return (L loc (LetStmt binds') : stmts', thing) }
398 -- For the vanilla case, handle the location-setting part
399 tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
400 = do { (stmt', (stmts', thing)) <-
402 addErrCtxt (stmtCtxt ctxt stmt) $
405 tcStmts ctxt stmt_chk stmts $
407 ; return (L loc stmt' : stmts', thing) }
409 --------------------------------
411 tcGuardStmt :: TcType -> TcStmtChecker
412 tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
413 = do { guard' <- tcCheckRho guard boolTy
414 ; thing <- thing_inside
415 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
417 tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
418 = do { (rhs', rhs_ty) <- tcInferRho rhs
419 ; (pat', thing) <- tcBindPat pat rhs_ty res_ty thing_inside
420 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
422 tcGuardStmt res_ty ctxt stmt thing_inside
423 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
426 --------------------------------
427 -- List comprehensions and PArrays
429 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
430 -> TcType -- The element type of the list or PArray
433 -- A generator, pat <- rhs
434 tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
435 = do { (rhs', rhs_ty) <- tcInferRho rhs
436 ; [pat_ty] <- unifyTyConApp m_tc rhs_ty
437 ; (pat', thing) <- tcBindPat pat pat_ty elt_ty thing_inside
438 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
441 tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
442 = do { rhs' <- tcCheckRho rhs boolTy
443 ; thing <- thing_inside
444 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
446 -- A parallel set of comprehensions
447 -- [ (g x, h x) | ... ; let g v = ...
448 -- | ... ; let h v = ... ]
450 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
451 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
452 -- Similarly if we had an existential pattern match:
454 -- data T = forall a. Show a => C a
456 -- [ (show x, show y) | ... ; C x <- ...
457 -- | ... ; C y <- ... ]
459 -- Then we need the LIE from (show x, show y) to be simplified against
460 -- the bindings for x and y.
462 -- It's difficult to do this in parallel, so we rely on the renamer to
463 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
464 -- So the binders of the first parallel group will be in scope in the second
465 -- group. But that's fine; there's no shadowing to worry about.
467 tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
468 = do { (pairs', thing) <- loop bndr_stmts_s
469 ; return (ParStmt pairs', thing) }
471 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
472 loop [] = do { thing <- thing_inside
473 ; return ([], thing) }
475 loop ((stmts, names) : pairs)
476 = do { (stmts', (ids, pairs', thing))
477 <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
478 do { ids <- tcLookupLocalIds names
479 ; (pairs', thing) <- loop pairs
480 ; return (ids, pairs', thing) }
481 ; return ( (stmts', ids) : pairs', thing ) }
483 tcLcStmt m_tc elt_ty ctxt stmt thing_inside
484 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
486 --------------------------------
488 -- The main excitement here is dealing with rebindable syntax
490 tcDoStmt :: TcType -- Monad type, m
491 -> TcType -- Result type, m b
494 tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
495 = do { -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
496 ; (rhs', rhs_ty) <- tcInferRho rhs
497 -- We should use type *inference* for the RHS computations, becuase of GADTs.
498 -- do { pat <- rhs; <rest> }
500 -- case rhs of { pat -> <rest> }
501 -- We do inference on rhs, so that information about its type can be refined
502 -- when type-checking the pattern.
504 ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
505 ; unifyTauTy m_ty n_ty
506 ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
508 ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
510 -- Rebindable syntax stuff
511 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
512 -- If (but only if) the pattern can fail,
513 -- typecheck the 'fail' operator
514 ; fail_op' <- if isIrrefutableHsPat pat'
515 then return noSyntaxExpr
516 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
517 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
520 tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
521 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
522 a_ty <- newTyFlexiVarTy liftedTypeKind
523 ; let rhs_ty = mkAppTy m_ty a_ty
524 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
525 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
526 ; rhs' <- tcCheckSigma rhs rhs_ty
527 ; thing <- thing_inside
528 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
530 tcDoStmt m_ty res_ty ctxt stmt thing_inside
531 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
533 --------------------------------
535 -- The distinctive features here are
537 -- (b) no rebindable syntax
539 tcMDoStmt :: TcType -- Result type, m b
540 -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
542 tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
543 = do { (rhs', pat_ty) <- tc_rhs rhs
544 ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
545 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
547 tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
548 = do { (rhs', elt_ty) <- tc_rhs rhs
549 ; thing <- thing_inside
550 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
552 tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
553 = do { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
554 ; let rec_ids = zipWith mkLocalId recNames rec_tys
555 ; tcExtendIdEnv rec_ids $ do
556 { (stmts', (later_ids, rec_rets))
557 <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
558 -- ToDo: res_ty not really right
559 do { rec_rets <- zipWithM tc_ret recNames rec_tys
560 ; later_ids <- tcLookupLocalIds laterNames
561 ; return (later_ids, rec_rets) }
563 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
564 -- NB: The rec_ids for the recursive things
565 -- already scope over this part. This binding may shadow
566 -- some of them with polymorphic things with the same Name
567 -- (see note [RecStmt] in HsExpr)
568 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
570 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
573 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
574 tc_ret rec_name mono_ty
575 = tcLookupId rec_name `thenM` \ poly_id ->
576 -- poly_id may have a polymorphic type
577 -- but mono_ty is just a monomorphic type variable
578 tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
579 returnM (co_fn <$> HsVar poly_id)
581 tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
582 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
585 tcBindPat :: LPat Name -> TcType
586 -> TcType -- Result type; used only to check existential escape
588 -> TcM (LPat TcId, a)
589 tcBindPat pat pat_ty res_ty thing_inside
590 = do { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
591 (Check res_ty) thing_inside
592 ; return (pat', thing) }
596 %************************************************************************
598 \subsection{Errors and contexts}
600 %************************************************************************
602 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
603 number of args are used in each equation.
606 sameNoOfArgs :: MatchGroup Name -> Bool
607 sameNoOfArgs (MatchGroup matches _)
608 = 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 grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
624 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
625 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
628 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
631 sigPatCtxt bound_ids bound_tvs tys tidy_env
632 = -- tys is (body_ty : pat_tys)
633 mapM zonkTcType tys `thenM` \ tys' ->
635 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
636 (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
639 sep [ptext SLIT("When checking an existential match that binds"),
640 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
641 ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
642 ptext SLIT("The body has type:") <+> ppr tidy_body_ty
645 show_ids = filter is_interesting bound_ids
646 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
648 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
649 -- Don't zonk the types so we get the separate, un-unified versions