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 )
35 import BasicTypes ( Arity )
42 #include "HsVersions.h"
45 %************************************************************************
47 \subsection{tcMatchesFun, tcMatchesCase}
49 %************************************************************************
51 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
52 @FunMonoBind@. The second argument is the name of the function, which
53 is used in error messages. It checks that all the equations have the
54 same number of arguments before using @tcMatches@ to do the work.
56 Note [Polymorphic expected type for tcMatchesFun]
57 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
58 tcMatchesFun may be given a *sigma* (polymorphic) type
59 so it must be prepared to use tcGen to skolemise it.
60 See Note [sig_tau may be polymorphic] in TcPat.
63 tcMatchesFun :: Name -> Bool
65 -> TcSigmaType -- Expected type of function
66 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
67 tcMatchesFun fun_name inf matches exp_ty
68 = do { -- Check that they all have the same no of arguments
69 -- Location is in the monad, set the caller so that
70 -- any inter-equation error messages get some vaguely
71 -- sensible location. Note: we have to do this odd
72 -- ann-grabbing, because we don't always have annotations in
73 -- hand when we call tcMatchesFun...
74 traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
75 ; checkArgs fun_name matches
77 ; (wrap_gen, (wrap_fun, group))
78 <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho ->
79 -- Note [Polymorphic expected type for tcMatchesFun]
80 matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
81 tcMatches match_ctxt pat_tys rhs_ty matches
82 ; return (wrap_gen <.> wrap_fun, group) }
84 arity = matchGroupArity matches
85 herald = ptext (sLit "The equation(s) for")
86 <+> quotes (ppr fun_name) <+> ptext (sLit "have")
87 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
90 @tcMatchesCase@ doesn't do the argument-count check because the
91 parser guarantees that each equation has exactly one argument.
94 tcMatchesCase :: TcMatchCtxt -- Case context
95 -> TcRhoType -- Type of scrutinee
96 -> MatchGroup Name -- The case alternatives
97 -> TcRhoType -- Type of whole case expressions
98 -> TcM (MatchGroup TcId) -- Translated alternatives
100 tcMatchesCase ctxt scrut_ty matches res_ty
101 | isEmptyMatchGroup matches -- Allow empty case expressions
102 = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty))
105 = tcMatches ctxt [scrut_ty] res_ty matches
107 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
108 tcMatchLambda match res_ty
109 = matchFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
110 tcMatches match_ctxt pat_tys rhs_ty match
112 n_pats = matchGroupArity match
113 doc = sep [ ptext (sLit "The lambda expression")
114 <+> quotes (pprSetDepth (PartWay 1) $
115 pprMatches (LambdaExpr :: HsMatchContext Name) match),
116 -- The pprSetDepth makes the abstraction print briefly
117 ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
118 match_ctxt = MC { mc_what = LambdaExpr,
122 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
125 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
126 -- Used for pattern bindings
127 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
129 match_ctxt = MC { mc_what = PatBindRhs,
136 :: SDoc -- See Note [Herald for matchExpecteFunTys] in TcUnify
139 -> ([TcSigmaType] -> TcRhoType -> TcM a)
140 -> TcM (HsWrapper, a)
142 -- Written in CPS style for historical reasons;
143 -- could probably be un-CPSd, like matchExpectedTyConApp
145 matchFunTys herald arity res_ty thing_inside
146 = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
147 ; res <- thing_inside pat_tys res_ty
148 ; return (coiToHsWrapper (mkSymCoI coi), res) }
151 %************************************************************************
155 %************************************************************************
158 tcMatches :: TcMatchCtxt
159 -> [TcSigmaType] -- Expected pattern types
160 -> TcRhoType -- Expected result-type of the Match.
162 -> TcM (MatchGroup TcId)
164 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
165 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
166 mc_body :: LHsExpr Name -- Type checker for a body of
169 -> TcM (LHsExpr TcId) }
171 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
172 = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
173 do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
174 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
177 tcMatch :: TcMatchCtxt
178 -> [TcSigmaType] -- Expected pattern types
179 -> TcRhoType -- Expected result-type of the Match.
183 tcMatch ctxt pat_tys rhs_ty match
184 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
186 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
187 = add_match_ctxt match $
188 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
189 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
190 ; return (Match pats' Nothing grhss') }
192 tc_grhss ctxt Nothing grhss rhs_ty
193 = tcGRHSs ctxt grhss rhs_ty -- No result signature
195 -- Result type sigs are no longer supported
196 tc_grhss _ (Just {}) _ _
197 = panic "tc_ghrss" -- Rejected by renamer
199 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
200 -- so we don't want to add "In the lambda abstraction \x->e"
201 add_match_ctxt match thing_inside
202 = case mc_what ctxt of
203 LambdaExpr -> thing_inside
204 m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
207 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
210 -- Notice that we pass in the full res_ty, so that we get
211 -- good inference from simple things like
212 -- f = \(x::forall a.a->a) -> <stuff>
213 -- We used to force it to be a monotype when there was more than one guard
214 -- but we don't need to do that any more
216 tcGRHSs ctxt (GRHSs grhss binds) res_ty
217 = do { (binds', grhss') <- tcLocalBinds binds $
218 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
220 ; return (GRHSs grhss' binds') }
223 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
225 tcGRHS ctxt res_ty (GRHS guards rhs)
226 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
228 ; return (GRHS guards' rhs') }
230 stmt_ctxt = PatGuard (mc_what ctxt)
234 %************************************************************************
236 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
238 %************************************************************************
241 tcDoStmts :: HsStmtContext Name
245 -> TcM (HsExpr TcId) -- Returns a HsDo
246 tcDoStmts ListComp stmts body res_ty
247 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
248 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
251 ; return $ mkHsWrapCoI coi
252 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
254 tcDoStmts PArrComp stmts body res_ty
255 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
256 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
259 ; return $ mkHsWrapCoI coi
260 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
262 tcDoStmts DoExpr stmts body res_ty
263 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
265 ; return (HsDo DoExpr stmts' body' res_ty) }
267 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
268 = do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty
269 ; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty
270 tc_rhs rhs = tcInfer $ \ pat_ty ->
271 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
273 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
276 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
277 ; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names
278 ; return $ mkHsWrapCoI coi $
279 HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' }
281 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
283 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
285 = do { traceTc "tcBody" (ppr res_ty)
286 ; body' <- tcMonoExpr body res_ty
292 %************************************************************************
296 %************************************************************************
300 = forall thing. HsStmtContext Name
302 -> TcRhoType -- Result type for comprehension
303 -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt
304 -> TcM (Stmt TcId, thing)
306 tcStmts :: HsStmtContext Name
307 -> TcStmtChecker -- NB: higher-rank type
310 -> (TcRhoType -> TcM thing)
311 -> TcM ([LStmt TcId], thing)
313 -- Note the higher-rank type. stmt_chk is applied at different
314 -- types in the equations for tcStmts
316 tcStmts _ _ [] res_ty thing_inside
317 = do { thing <- thing_inside res_ty
318 ; return ([], thing) }
320 -- LetStmts are handled uniformly, regardless of context
321 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
322 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
323 tcStmts ctxt stmt_chk stmts res_ty thing_inside
324 ; return (L loc (LetStmt binds') : stmts', thing) }
326 -- For the vanilla case, handle the location-setting part
327 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
328 = do { (stmt', (stmts', thing)) <-
330 addErrCtxt (pprStmtInCtxt ctxt stmt) $
331 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
333 tcStmts ctxt stmt_chk stmts res_ty' $
335 ; return (L loc stmt' : stmts', thing) }
337 --------------------------------
339 tcGuardStmt :: TcStmtChecker
340 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
341 = do { guard' <- tcMonoExpr guard boolTy
342 ; thing <- thing_inside res_ty
343 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
345 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
346 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
347 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $
349 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
351 tcGuardStmt _ stmt _ _
352 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
355 --------------------------------
356 -- List comprehensions and PArrays
358 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
361 -- A generator, pat <- rhs
362 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
363 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
364 ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
365 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
367 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
370 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
371 = do { rhs' <- tcMonoExpr rhs boolTy
372 ; thing <- thing_inside res_ty
373 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
375 -- A parallel set of comprehensions
376 -- [ (g x, h x) | ... ; let g v = ...
377 -- | ... ; let h v = ... ]
379 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
380 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
381 -- Similarly if we had an existential pattern match:
383 -- data T = forall a. Show a => C a
385 -- [ (show x, show y) | ... ; C x <- ...
386 -- | ... ; C y <- ... ]
388 -- Then we need the LIE from (show x, show y) to be simplified against
389 -- the bindings for x and y.
391 -- It's difficult to do this in parallel, so we rely on the renamer to
392 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
393 -- So the binders of the first parallel group will be in scope in the second
394 -- group. But that's fine; there's no shadowing to worry about.
396 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
397 = do { (pairs', thing) <- loop bndr_stmts_s
398 ; return (ParStmt pairs', thing) }
400 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
401 loop [] = do { thing <- thing_inside elt_ty
402 ; return ([], thing) } -- matching in the branches
404 loop ((stmts, names) : pairs)
405 = do { (stmts', (ids, pairs', thing))
406 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
407 do { ids <- tcLookupLocalIds names
408 ; (pairs', thing) <- loop pairs
409 ; return (ids, pairs', thing) }
410 ; return ( (stmts', ids) : pairs', thing ) }
412 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
413 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
414 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
415 let alphaListTy = mkTyConApp m_tc [alphaTy]
417 (usingExpr', maybeByExpr') <-
420 -- We must validate that usingExpr :: forall a. [a] -> [a]
421 let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
422 usingExpr' <- tcPolyExpr usingExpr using_ty
423 return (usingExpr', Nothing)
425 -- We must infer a type such that e :: t and then check that
426 -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
427 (byExpr', tTy) <- tcInferRhoNC byExpr
428 let using_ty = mkForAllTy alphaTyVar $
429 (alphaTy `mkFunTy` tTy)
430 `mkFunTy` alphaListTy `mkFunTy` alphaListTy
431 usingExpr' <- tcPolyExpr usingExpr using_ty
432 return (usingExpr', Just byExpr')
434 binders' <- tcLookupLocalIds binders
435 thing <- thing_inside elt_ty'
437 return (binders', usingExpr', maybeByExpr', thing)
439 return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
441 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
442 = do { let (bndr_names, list_bndr_names) = unzip bindersMap
444 ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
445 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
448 Nothing -> -- check that using :: forall a. [a] -> [[a]]
449 return (Nothing, mkForAllTy alphaTyVar $
450 alphaListTy `mkFunTy` alphaListListTy)
452 Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
454 do { (by_e', t_ty) <- tcInferRhoNC by_e
455 ; return (Just by_e', mkForAllTy alphaTyVar $
456 (alphaTy `mkFunTy` t_ty)
457 `mkFunTy` alphaListTy
458 `mkFunTy` alphaListListTy) }
459 -- Find the Ids (and hence types) of all old binders
460 bndr_ids <- tcLookupLocalIds bndr_names
462 return (bndr_ids, by', using_ty, elt_ty')
464 -- Ensure that every old binder of type b is linked up with
465 -- its new binder which should have type [b]
466 ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
467 bindersMap' = bndr_ids `zip` list_bndr_ids
468 -- See Note [GroupStmt binder map] in HsExpr
470 ; using' <- case using of
471 Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
472 Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
474 -- Type check the thing in the environment with
475 -- these new binders and return the result
476 ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
477 ; return (GroupStmt stmts' bindersMap' by' using', thing) }
479 alphaListTy = mkTyConApp m_tc [alphaTy]
480 alphaListListTy = mkTyConApp m_tc [alphaListTy]
482 mk_list_bndr :: Name -> TcId -> TcId
483 mk_list_bndr list_bndr_name bndr_id
484 = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
486 tcLcStmt _ _ stmt _ _
487 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
489 --------------------------------
491 -- The main excitement here is dealing with rebindable syntax
493 tcDoStmt :: TcStmtChecker
495 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
496 = do { -- Deal with rebindable syntax:
497 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
498 -- This level of generality is needed for using do-notation
499 -- in full generality; see Trac #1537
501 -- I'd like to put this *after* the tcSyntaxOp
502 -- (see Note [Treat rebindable syntax first], but that breaks
503 -- the rigidity info for GADTs. When we move to the new story
504 -- for GADTs, we can move this after tcSyntaxOp
505 rhs_ty <- newFlexiTyVarTy liftedTypeKind
506 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
507 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
508 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
509 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
511 -- If (but only if) the pattern can fail,
512 -- typecheck the 'fail' operator
513 ; fail_op' <- if isIrrefutableHsPat pat
514 then return noSyntaxExpr
515 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
517 ; rhs' <- tcMonoExprNC rhs rhs_ty
518 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
519 thing_inside new_res_ty
521 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
524 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
525 = do { -- Deal with rebindable syntax;
526 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
527 -- See also Note [Treat rebindable syntax first]
528 rhs_ty <- newFlexiTyVarTy liftedTypeKind
529 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
530 ; then_op' <- tcSyntaxOp DoOrigin then_op
531 (mkFunTys [rhs_ty, new_res_ty] res_ty)
533 ; rhs' <- tcMonoExprNC rhs rhs_ty
534 ; thing <- thing_inside new_res_ty
535 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
537 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
538 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
539 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
541 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
542 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
543 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
544 tup_ty = mkBoxedTupleTy tup_elt_tys
546 ; tcExtendIdEnv tup_ids $ do
547 { stmts_ty <- newFlexiTyVarTy liftedTypeKind
548 ; (stmts', (ret_op', tup_rets))
549 <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
550 do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
551 -- Unify the types of the "final" Ids (which may
552 -- be polymorphic) with those of "knot-tied" Ids
553 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
554 ; return (ret_op', tup_rets) }
556 ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
557 ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
558 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
560 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
561 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
562 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
564 ; thing <- thing_inside new_res_ty
565 -- ; lie_binds <- bindLocalMethods lie tup_ids
567 ; let rec_ids = takeList rec_names tup_ids
568 ; later_ids <- tcLookupLocalIds later_names
569 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
570 ppr later_ids <+> ppr (map idType later_ids)]
571 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
572 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
573 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
574 , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing)
578 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
581 Note [Treat rebindable syntax first]
582 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
584 do { bar; ... } :: IO ()
585 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
586 pushing info from the context into the RHS. To do this, we check the
587 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
588 Otherwise the error shows up when cheking the rebindable syntax, and
589 the expected/inferred stuff is back to front (see Trac #3613).
592 --------------------------------
594 -- The distinctive features here are
596 -- (b) no rebindable syntax
598 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
600 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
601 = do { (rhs', pat_ty) <- tc_rhs rhs
602 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
604 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
606 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
607 = do { (rhs', elt_ty) <- tc_rhs rhs
608 ; thing <- thing_inside res_ty
609 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
611 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
612 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
613 ; let rec_ids = zipWith mkLocalId recNames rec_tys
614 ; tcExtendIdEnv rec_ids $ do
615 { (stmts', (later_ids, rec_rets))
616 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
617 -- ToDo: res_ty not really right
618 do { rec_rets <- zipWithM tcCheckId recNames rec_tys
619 ; later_ids <- tcLookupLocalIds laterNames
620 ; return (later_ids, rec_rets) }
622 ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
623 -- NB: The rec_ids for the recursive things
624 -- already scope over this part. This binding may shadow
625 -- some of them with polymorphic things with the same Name
626 -- (see note [RecStmt] in HsExpr)
628 -- Need the bindLocalMethods if we re-add Method constraints
629 -- ; lie_binds <- bindLocalMethods lie later_ids
630 ; let lie_binds = emptyTcEvBinds
632 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
635 tcMDoStmt _ _ stmt _ _
636 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
640 %************************************************************************
642 \subsection{Errors and contexts}
644 %************************************************************************
646 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
647 number of args are used in each equation.
650 checkArgs :: Name -> MatchGroup Name -> TcM ()
651 checkArgs fun (MatchGroup (match1:matches) _)
652 | null bad_matches = return ()
654 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
655 ptext (sLit "have different numbers of arguments"),
656 nest 2 (ppr (getLoc match1)),
657 nest 2 (ppr (getLoc (head bad_matches)))])
659 n_args1 = args_in_match match1
660 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
662 args_in_match :: LMatch Name -> Int
663 args_in_match (L _ (Match pats _ _)) = length pats
664 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty