2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcMatches: Typecheck some @Matches@
9 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
11 tcStmts, tcDoStmts, tcBody,
12 tcDoStmt, tcMDoStmt, tcGuardStmt
15 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
16 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
33 import Coercion ( mkSymCoI )
36 import BasicTypes ( Arity )
43 #include "HsVersions.h"
46 %************************************************************************
48 \subsection{tcMatchesFun, tcMatchesCase}
50 %************************************************************************
52 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
53 @FunMonoBind@. The second argument is the name of the function, which
54 is used in error messages. It checks that all the equations have the
55 same number of arguments before using @tcMatches@ to do the work.
57 Note [Polymorphic expected type for tcMatchesFun]
58 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
59 tcMatchesFun may be given a *sigma* (polymorphic) type
60 so it must be prepared to use tcGen to skolemise it.
61 See Note [sig_tau may be polymorphic] in TcPat.
64 tcMatchesFun :: Name -> Bool
66 -> TcSigmaType -- Expected type of function
67 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
68 tcMatchesFun fun_name inf matches exp_ty
69 = do { -- Check that they all have the same no of arguments
70 -- Location is in the monad, set the caller so that
71 -- any inter-equation error messages get some vaguely
72 -- sensible location. Note: we have to do this odd
73 -- ann-grabbing, because we don't always have annotations in
74 -- hand when we call tcMatchesFun...
75 traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
76 ; checkArgs fun_name matches
78 ; (wrap_gen, (wrap_fun, group))
79 <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho ->
80 -- Note [Polymorphic expected type for tcMatchesFun]
81 matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
82 tcMatches match_ctxt pat_tys rhs_ty matches
83 ; return (wrap_gen <.> wrap_fun, group) }
85 arity = matchGroupArity matches
86 herald = ptext (sLit "The equation(s) for")
87 <+> quotes (ppr fun_name) <+> ptext (sLit "have")
88 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
91 @tcMatchesCase@ doesn't do the argument-count check because the
92 parser guarantees that each equation has exactly one argument.
95 tcMatchesCase :: TcMatchCtxt -- Case context
96 -> TcRhoType -- Type of scrutinee
97 -> MatchGroup Name -- The case alternatives
98 -> TcRhoType -- Type of whole case expressions
99 -> TcM (MatchGroup TcId) -- Translated alternatives
101 tcMatchesCase ctxt scrut_ty matches res_ty
102 | isEmptyMatchGroup matches -- Allow empty case expressions
103 = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty))
106 = tcMatches ctxt [scrut_ty] res_ty matches
108 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
109 tcMatchLambda match res_ty
110 = matchFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
111 tcMatches match_ctxt pat_tys rhs_ty match
113 n_pats = matchGroupArity match
114 doc = sep [ ptext (sLit "The lambda expression")
115 <+> quotes (pprSetDepth (PartWay 1) $
116 pprMatches (LambdaExpr :: HsMatchContext Name) match),
117 -- The pprSetDepth makes the abstraction print briefly
118 ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
119 match_ctxt = MC { mc_what = LambdaExpr,
123 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
126 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
127 -- Used for pattern bindings
128 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
130 match_ctxt = MC { mc_what = PatBindRhs,
137 :: SDoc -- See Note [Herald for matchExpecteFunTys] in TcUnify
140 -> ([TcSigmaType] -> TcRhoType -> TcM a)
141 -> TcM (HsWrapper, a)
143 -- Written in CPS style for historical reasons;
144 -- could probably be un-CPSd, like matchExpectedTyConApp
146 matchFunTys herald arity res_ty thing_inside
147 = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
148 ; res <- thing_inside pat_tys res_ty
149 ; return (coiToHsWrapper (mkSymCoI coi), res) }
152 %************************************************************************
156 %************************************************************************
159 tcMatches :: TcMatchCtxt
160 -> [TcSigmaType] -- Expected pattern types
161 -> TcRhoType -- Expected result-type of the Match.
163 -> TcM (MatchGroup TcId)
165 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
166 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
167 mc_body :: LHsExpr Name -- Type checker for a body of
170 -> TcM (LHsExpr TcId) }
172 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
173 = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
174 do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
175 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
178 tcMatch :: TcMatchCtxt
179 -> [TcSigmaType] -- Expected pattern types
180 -> TcRhoType -- Expected result-type of the Match.
184 tcMatch ctxt pat_tys rhs_ty match
185 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
187 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
188 = add_match_ctxt match $
189 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
190 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
191 ; return (Match pats' Nothing grhss') }
193 tc_grhss ctxt Nothing grhss rhs_ty
194 = tcGRHSs ctxt grhss rhs_ty -- No result signature
196 -- Result type sigs are no longer supported
197 tc_grhss _ (Just {}) _ _
198 = panic "tc_ghrss" -- Rejected by renamer
200 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
201 -- so we don't want to add "In the lambda abstraction \x->e"
202 add_match_ctxt match thing_inside
203 = case mc_what ctxt of
204 LambdaExpr -> thing_inside
205 m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
208 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
211 -- Notice that we pass in the full res_ty, so that we get
212 -- good inference from simple things like
213 -- f = \(x::forall a.a->a) -> <stuff>
214 -- We used to force it to be a monotype when there was more than one guard
215 -- but we don't need to do that any more
217 tcGRHSs ctxt (GRHSs grhss binds) res_ty
218 = do { (binds', grhss') <- tcLocalBinds binds $
219 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
221 ; return (GRHSs grhss' binds') }
224 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
226 tcGRHS ctxt res_ty (GRHS guards rhs)
227 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
229 ; return (GRHS guards' rhs') }
231 stmt_ctxt = PatGuard (mc_what ctxt)
235 %************************************************************************
237 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
239 %************************************************************************
242 tcDoStmts :: HsStmtContext Name
246 -> TcM (HsExpr TcId) -- Returns a HsDo
247 tcDoStmts ListComp stmts body res_ty
248 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
249 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
252 ; return $ mkHsWrapCoI coi
253 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
255 tcDoStmts PArrComp stmts body res_ty
256 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
257 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
260 ; return $ mkHsWrapCoI coi
261 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
263 tcDoStmts DoExpr stmts body res_ty
264 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
266 ; return (HsDo DoExpr stmts' body' res_ty) }
268 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
269 = do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty
270 ; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty
271 tc_rhs rhs = tcInfer $ \ pat_ty ->
272 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
274 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
277 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
278 ; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names
279 ; return $ mkHsWrapCoI coi $
280 HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' }
282 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
284 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
286 = do { traceTc "tcBody" (ppr res_ty)
287 ; body' <- tcMonoExpr body res_ty
293 %************************************************************************
297 %************************************************************************
301 = forall thing. HsStmtContext Name
303 -> TcRhoType -- Result type for comprehension
304 -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt
305 -> TcM (Stmt TcId, thing)
307 tcStmts :: HsStmtContext Name
308 -> TcStmtChecker -- NB: higher-rank type
311 -> (TcRhoType -> TcM thing)
312 -> TcM ([LStmt TcId], thing)
314 -- Note the higher-rank type. stmt_chk is applied at different
315 -- types in the equations for tcStmts
317 tcStmts _ _ [] res_ty thing_inside
318 = do { thing <- thing_inside res_ty
319 ; return ([], thing) }
321 -- LetStmts are handled uniformly, regardless of context
322 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
323 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
324 tcStmts ctxt stmt_chk stmts res_ty thing_inside
325 ; return (L loc (LetStmt binds') : stmts', thing) }
327 -- For the vanilla case, handle the location-setting part
328 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
329 = do { (stmt', (stmts', thing)) <-
331 addErrCtxt (pprStmtInCtxt ctxt stmt) $
332 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
334 tcStmts ctxt stmt_chk stmts res_ty' $
336 ; return (L loc stmt' : stmts', thing) }
338 --------------------------------
340 tcGuardStmt :: TcStmtChecker
341 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
342 = do { guard' <- tcMonoExpr guard boolTy
343 ; thing <- thing_inside res_ty
344 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
346 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
347 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
348 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $
350 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
352 tcGuardStmt _ stmt _ _
353 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
356 --------------------------------
357 -- List comprehensions and PArrays
359 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
362 -- A generator, pat <- rhs
363 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
364 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
365 ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
366 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
368 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
371 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
372 = do { rhs' <- tcMonoExpr rhs boolTy
373 ; thing <- thing_inside res_ty
374 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
376 -- A parallel set of comprehensions
377 -- [ (g x, h x) | ... ; let g v = ...
378 -- | ... ; let h v = ... ]
380 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
381 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
382 -- Similarly if we had an existential pattern match:
384 -- data T = forall a. Show a => C a
386 -- [ (show x, show y) | ... ; C x <- ...
387 -- | ... ; C y <- ... ]
389 -- Then we need the LIE from (show x, show y) to be simplified against
390 -- the bindings for x and y.
392 -- It's difficult to do this in parallel, so we rely on the renamer to
393 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
394 -- So the binders of the first parallel group will be in scope in the second
395 -- group. But that's fine; there's no shadowing to worry about.
397 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
398 = do { (pairs', thing) <- loop bndr_stmts_s
399 ; return (ParStmt pairs', thing) }
401 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
402 loop [] = do { thing <- thing_inside elt_ty
403 ; return ([], thing) } -- matching in the branches
405 loop ((stmts, names) : pairs)
406 = do { (stmts', (ids, pairs', thing))
407 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
408 do { ids <- tcLookupLocalIds names
409 ; (pairs', thing) <- loop pairs
410 ; return (ids, pairs', thing) }
411 ; return ( (stmts', ids) : pairs', thing ) }
413 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
414 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
415 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
416 let alphaListTy = mkTyConApp m_tc [alphaTy]
418 (usingExpr', maybeByExpr') <-
421 -- We must validate that usingExpr :: forall a. [a] -> [a]
422 let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
423 usingExpr' <- tcPolyExpr usingExpr using_ty
424 return (usingExpr', Nothing)
426 -- We must infer a type such that e :: t and then check that
427 -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
428 (byExpr', tTy) <- tcInferRhoNC byExpr
429 let using_ty = mkForAllTy alphaTyVar $
430 (alphaTy `mkFunTy` tTy)
431 `mkFunTy` alphaListTy `mkFunTy` alphaListTy
432 usingExpr' <- tcPolyExpr usingExpr using_ty
433 return (usingExpr', Just byExpr')
435 binders' <- tcLookupLocalIds binders
436 thing <- thing_inside elt_ty'
438 return (binders', usingExpr', maybeByExpr', thing)
440 return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
442 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
443 = do { let (bndr_names, list_bndr_names) = unzip bindersMap
445 ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
446 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
449 Nothing -> -- check that using :: forall a. [a] -> [[a]]
450 return (Nothing, mkForAllTy alphaTyVar $
451 alphaListTy `mkFunTy` alphaListListTy)
453 Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
455 do { (by_e', t_ty) <- tcInferRhoNC by_e
456 ; return (Just by_e', mkForAllTy alphaTyVar $
457 (alphaTy `mkFunTy` t_ty)
458 `mkFunTy` alphaListTy
459 `mkFunTy` alphaListListTy) }
460 -- Find the Ids (and hence types) of all old binders
461 bndr_ids <- tcLookupLocalIds bndr_names
463 return (bndr_ids, by', using_ty, elt_ty')
465 -- Ensure that every old binder of type b is linked up with
466 -- its new binder which should have type [b]
467 ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
468 bindersMap' = bndr_ids `zip` list_bndr_ids
469 -- See Note [GroupStmt binder map] in HsExpr
471 ; using' <- case using of
472 Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
473 Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
475 -- Type check the thing in the environment with
476 -- these new binders and return the result
477 ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
478 ; return (GroupStmt stmts' bindersMap' by' using', thing) }
480 alphaListTy = mkTyConApp m_tc [alphaTy]
481 alphaListListTy = mkTyConApp m_tc [alphaListTy]
483 mk_list_bndr :: Name -> TcId -> TcId
484 mk_list_bndr list_bndr_name bndr_id
485 = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
487 tcLcStmt _ _ stmt _ _
488 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
490 --------------------------------
492 -- The main excitement here is dealing with rebindable syntax
494 tcDoStmt :: TcStmtChecker
496 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
497 = do { -- Deal with rebindable syntax:
498 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
499 -- This level of generality is needed for using do-notation
500 -- in full generality; see Trac #1537
502 -- I'd like to put this *after* the tcSyntaxOp
503 -- (see Note [Treat rebindable syntax first], but that breaks
504 -- the rigidity info for GADTs. When we move to the new story
505 -- for GADTs, we can move this after tcSyntaxOp
506 rhs_ty <- newFlexiTyVarTy liftedTypeKind
507 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
508 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
509 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
510 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_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 new_res_ty)
518 ; rhs' <- tcMonoExprNC rhs rhs_ty
519 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $
520 thing_inside new_res_ty
522 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
525 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
526 = do { -- Deal with rebindable syntax;
527 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
528 -- See also Note [Treat rebindable syntax first]
529 rhs_ty <- newFlexiTyVarTy liftedTypeKind
530 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
531 ; then_op' <- tcSyntaxOp DoOrigin then_op
532 (mkFunTys [rhs_ty, new_res_ty] res_ty)
534 ; rhs' <- tcMonoExprNC rhs rhs_ty
535 ; thing <- thing_inside new_res_ty
536 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
538 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
539 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
540 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
542 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
543 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
544 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
545 tup_ty = mkBoxedTupleTy tup_elt_tys
547 ; tcExtendIdEnv tup_ids $ do
548 { stmts_ty <- newFlexiTyVarTy liftedTypeKind
549 ; (stmts', (ret_op', tup_rets))
550 <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
551 do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
552 -- Unify the types of the "final" Ids (which may
553 -- be polymorphic) with those of "knot-tied" Ids
554 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
555 ; return (ret_op', tup_rets) }
557 ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
558 ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
559 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
561 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
562 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
563 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
565 ; thing <- thing_inside new_res_ty
566 -- ; lie_binds <- bindLocalMethods lie tup_ids
568 ; let rec_ids = takeList rec_names tup_ids
569 ; later_ids <- tcLookupLocalIds later_names
570 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
571 ppr later_ids <+> ppr (map idType later_ids)]
572 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
573 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
574 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
575 , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing)
579 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
582 Note [Treat rebindable syntax first]
583 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
585 do { bar; ... } :: IO ()
586 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
587 pushing info from the context into the RHS. To do this, we check the
588 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
589 Otherwise the error shows up when cheking the rebindable syntax, and
590 the expected/inferred stuff is back to front (see Trac #3613).
593 --------------------------------
595 -- The distinctive features here are
597 -- (b) no rebindable syntax
599 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
601 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
602 = do { (rhs', pat_ty) <- tc_rhs rhs
603 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
605 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
607 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
608 = do { (rhs', elt_ty) <- tc_rhs rhs
609 ; thing <- thing_inside res_ty
610 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
612 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
613 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
614 ; let rec_ids = zipWith mkLocalId recNames rec_tys
615 ; tcExtendIdEnv rec_ids $ do
616 { (stmts', (later_ids, rec_rets))
617 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
618 -- ToDo: res_ty not really right
619 do { rec_rets <- zipWithM tcCheckId recNames rec_tys
620 ; later_ids <- tcLookupLocalIds laterNames
621 ; return (later_ids, rec_rets) }
623 ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
624 -- NB: The rec_ids for the recursive things
625 -- already scope over this part. This binding may shadow
626 -- some of them with polymorphic things with the same Name
627 -- (see note [RecStmt] in HsExpr)
629 -- Need the bindLocalMethods if we re-add Method constraints
630 -- ; lie_binds <- bindLocalMethods lie later_ids
631 ; let lie_binds = emptyTcEvBinds
633 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
636 tcMDoStmt _ _ stmt _ _
637 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
641 %************************************************************************
643 \subsection{Errors and contexts}
645 %************************************************************************
647 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
648 number of args are used in each equation.
651 checkArgs :: Name -> MatchGroup Name -> TcM ()
652 checkArgs fun (MatchGroup (match1:matches) _)
653 | null bad_matches = return ()
655 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
656 ptext (sLit "have different numbers of arguments"),
657 nest 2 (ppr (getLoc match1)),
658 nest 2 (ppr (getLoc (head bad_matches)))])
660 n_args1 = args_in_match match1
661 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
663 args_in_match :: LMatch Name -> Int
664 args_in_match (L _ (Match pats _ _)) = length pats
665 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty