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,
16 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
41 #include "HsVersions.h"
44 %************************************************************************
46 \subsection{tcMatchesFun, tcMatchesCase}
48 %************************************************************************
50 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
51 @FunMonoBind@. The second argument is the name of the function, which
52 is used in error messages. It checks that all the equations have the
53 same number of arguments before using @tcMatches@ to do the work.
56 tcMatchesFun :: Name -> Bool
58 -> BoxyRhoType -- Expected type of function
59 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
61 tcMatchesFun fun_name inf matches exp_ty
62 = do { -- Check that they all have the same no of arguments
63 -- Location is in the monad, set the caller so that
64 -- any inter-equation error messages get some vaguely
65 -- sensible location. Note: we have to do this odd
66 -- ann-grabbing, because we don't always have annotations in
67 -- hand when we call tcMatchesFun...
68 traceTc (text "tcMatchesFun" <+> (ppr fun_name $$ ppr exp_ty))
69 ; checkArgs fun_name matches
71 -- ToDo: Don't use "expected" stuff if there ain't a type signature
72 -- because inconsistency between branches
73 -- may show up as something wrong with the (non-existent) type signature
75 -- This is one of two places places we call subFunTys
76 -- The point is that if expected_y is a "hole", we want
77 -- to make pat_tys and rhs_ty as "holes" too.
78 ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
79 tcMatches match_ctxt pat_tys rhs_ty matches
82 doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
83 <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
84 n_pats = matchGroupArity matches
85 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
88 @tcMatchesCase@ doesn't do the argument-count check because the
89 parser guarantees that each equation has exactly one argument.
92 tcMatchesCase :: TcMatchCtxt -- Case context
93 -> TcRhoType -- Type of scrutinee
94 -> MatchGroup Name -- The case alternatives
95 -> BoxyRhoType -- Type of whole case expressions
96 -> TcM (MatchGroup TcId) -- Translated alternatives
98 tcMatchesCase ctxt scrut_ty matches res_ty
99 | isEmptyMatchGroup matches
100 = -- Allow empty case expressions
101 do { -- Make sure we follow the invariant that res_ty is filled in
102 res_ty' <- refineBoxToTau res_ty
103 ; return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
106 = tcMatches ctxt [scrut_ty] res_ty matches
108 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
109 tcMatchLambda match res_ty
110 = subFunTys doc n_pats res_ty Nothing $ \ 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 -> BoxyRhoType -> 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,
135 %************************************************************************
139 %************************************************************************
142 tcMatches :: TcMatchCtxt
143 -> [BoxySigmaType] -- Expected pattern types
144 -> BoxyRhoType -- 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
153 -> TcM (LHsExpr TcId) }
155 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
156 = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
157 do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
158 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
161 tcMatch :: TcMatchCtxt
162 -> [BoxySigmaType] -- Expected pattern types
163 -> BoxyRhoType -- 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 = add_match_ctxt match $
172 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
173 tc_grhss ctxt maybe_rhs_sig grhss
174 ; return (Match pats' Nothing grhss') }
176 tc_grhss ctxt Nothing grhss rhs_ty
177 = tcGRHSs ctxt grhss rhs_ty -- No result signature
179 -- Result type sigs are no longer supported
180 tc_grhss _ (Just {}) _ _
181 = panic "tc_ghrss" -- Rejected by renamer
183 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
184 -- so we don't want to add "In the lambda abstraction \x->e"
185 add_match_ctxt match thing_inside
186 = case mc_what ctxt of
187 LambdaExpr -> thing_inside
188 m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
191 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
194 -- Notice that we pass in the full res_ty, so that we get
195 -- good inference from simple things like
196 -- f = \(x::forall a.a->a) -> <stuff>
197 -- We used to force it to be a monotype when there was more than one guard
198 -- but we don't need to do that any more
200 tcGRHSs ctxt (GRHSs grhss binds) res_ty
201 = do { (binds', grhss') <- tcLocalBinds binds $
202 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
204 ; return (GRHSs grhss' binds') }
207 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
209 tcGRHS ctxt res_ty (GRHS guards rhs)
210 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
212 ; return (GRHS guards' rhs') }
214 stmt_ctxt = PatGuard (mc_what ctxt)
218 %************************************************************************
220 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
222 %************************************************************************
225 tcDoStmts :: HsStmtContext Name
229 -> TcM (HsExpr TcId) -- Returns a HsDo
230 tcDoStmts ListComp stmts body res_ty
231 = do { (elt_ty, coi) <- boxySplitListTy res_ty
232 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
235 ; return $ mkHsWrapCoI coi
236 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
238 tcDoStmts PArrComp stmts body res_ty
239 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
240 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
243 ; return $ mkHsWrapCoI coi
244 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
246 tcDoStmts DoExpr stmts body res_ty
247 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
249 ; return (HsDo DoExpr stmts' body' res_ty) }
251 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
252 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
253 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
254 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
255 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
257 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
261 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
262 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
265 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
267 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
269 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
271 = do { traceTc (text "tcBody" <+> ppr res_ty)
272 ; body' <- tcMonoExpr body res_ty
278 %************************************************************************
282 %************************************************************************
286 = forall thing. HsStmtContext Name
288 -> BoxyRhoType -- Result type for comprehension
289 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
290 -> TcM (Stmt TcId, thing)
292 tcStmts :: HsStmtContext Name
293 -> TcStmtChecker -- NB: higher-rank type
296 -> (BoxyRhoType -> TcM thing)
297 -> TcM ([LStmt TcId], thing)
299 -- Note the higher-rank type. stmt_chk is applied at different
300 -- types in the equations for tcStmts
302 tcStmts _ _ [] res_ty thing_inside
303 = do { thing <- thing_inside res_ty
304 ; return ([], thing) }
306 -- LetStmts are handled uniformly, regardless of context
307 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
308 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
309 tcStmts ctxt stmt_chk stmts res_ty thing_inside
310 ; return (L loc (LetStmt binds') : stmts', thing) }
312 -- For the vanilla case, handle the location-setting part
313 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
314 = do { (stmt', (stmts', thing)) <-
316 addErrCtxt (pprStmtInCtxt ctxt stmt) $
317 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
319 tcStmts ctxt stmt_chk stmts res_ty' $
321 ; return (L loc stmt' : stmts', thing) }
323 --------------------------------
325 tcGuardStmt :: TcStmtChecker
326 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
327 = do { guard' <- tcMonoExpr guard boolTy
328 ; thing <- thing_inside res_ty
329 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
331 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
332 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
333 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
334 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
336 tcGuardStmt _ stmt _ _
337 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
340 --------------------------------
341 -- List comprehensions and PArrays
343 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
346 -- A generator, pat <- rhs
347 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
348 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
349 tcMonoExpr rhs (mkTyConApp m_tc [ty])
350 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
351 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
354 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
355 = do { rhs' <- tcMonoExpr rhs boolTy
356 ; thing <- thing_inside res_ty
357 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
359 -- A parallel set of comprehensions
360 -- [ (g x, h x) | ... ; let g v = ...
361 -- | ... ; let h v = ... ]
363 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
364 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
365 -- Similarly if we had an existential pattern match:
367 -- data T = forall a. Show a => C a
369 -- [ (show x, show y) | ... ; C x <- ...
370 -- | ... ; C y <- ... ]
372 -- Then we need the LIE from (show x, show y) to be simplified against
373 -- the bindings for x and y.
375 -- It's difficult to do this in parallel, so we rely on the renamer to
376 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
377 -- So the binders of the first parallel group will be in scope in the second
378 -- group. But that's fine; there's no shadowing to worry about.
380 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
381 = do { (pairs', thing) <- loop bndr_stmts_s
382 ; return (ParStmt pairs', thing) }
384 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
385 loop [] = do { thing <- thing_inside elt_ty
386 ; return ([], thing) } -- matching in the branches
388 loop ((stmts, names) : pairs)
389 = do { (stmts', (ids, pairs', thing))
390 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
391 do { ids <- tcLookupLocalIds names
392 ; (pairs', thing) <- loop pairs
393 ; return (ids, pairs', thing) }
394 ; return ( (stmts', ids) : pairs', thing ) }
396 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
397 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
398 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
399 let alphaListTy = mkTyConApp m_tc [alphaTy]
401 (usingExpr', maybeByExpr') <-
404 -- We must validate that usingExpr :: forall a. [a] -> [a]
405 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
406 return (usingExpr', Nothing)
408 -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
409 (byExpr', tTy) <- tcInferRhoNC byExpr
410 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
411 return (usingExpr', Just byExpr')
413 binders' <- tcLookupLocalIds binders
414 thing <- thing_inside elt_ty'
416 return (binders', usingExpr', maybeByExpr', thing)
418 return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
420 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
421 = do { let (bndr_names, list_bndr_names) = unzip bindersMap
423 ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
424 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
425 (by', using_ty) <- case by of
426 Nothing -> -- check that using :: forall a. [a] -> [[a]]
427 return (Nothing, mkForAllTy alphaTyVar $
428 alphaListTy `mkFunTy` alphaListListTy)
430 Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
432 do { (by_e', t_ty) <- tcInferRhoNC by_e
433 ; return (Just by_e', mkForAllTy alphaTyVar $
434 (alphaTy `mkFunTy` t_ty)
435 `mkFunTy` alphaListTy
436 `mkFunTy` alphaListListTy) }
437 -- Find the Ids (and hence types) of all old binders
438 bndr_ids <- tcLookupLocalIds bndr_names
440 return (bndr_ids, by', using_ty, elt_ty')
442 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
443 ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
444 bindersMap' = bndr_ids `zip` list_bndr_ids
445 -- See Note [GroupStmt binder map] in HsExpr
447 ; using' <- case using of
448 Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
449 Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
451 -- Type check the thing in the environment with these new binders and return the result
452 ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
453 ; return (GroupStmt stmts' bindersMap' by' using', thing) }
455 alphaListTy = mkTyConApp m_tc [alphaTy]
456 alphaListListTy = mkTyConApp m_tc [alphaListTy]
458 mk_list_bndr :: Name -> TcId -> TcId
459 mk_list_bndr list_bndr_name bndr_id = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
461 tcLcStmt _ _ stmt _ _
462 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
464 --------------------------------
466 -- The main excitement here is dealing with rebindable syntax
468 tcDoStmt :: TcStmtChecker
470 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
471 = do { -- Deal with rebindable syntax:
472 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
473 -- This level of generality is needed for using do-notation
474 -- in full generality; see Trac #1537
476 -- I'd like to put this *after* the tcSyntaxOp
477 -- (see Note [Treat rebindable syntax first], but that breaks
478 -- the rigidity info for GADTs. When we move to the new story
479 -- for GADTs, we can move this after tcSyntaxOp
480 (rhs', rhs_ty) <- tcInferRhoNC rhs
482 ; ((bind_op', new_res_ty), pat_ty) <-
483 withBox liftedTypeKind $ \ pat_ty ->
484 withBox liftedTypeKind $ \ new_res_ty ->
485 tcSyntaxOp DoOrigin bind_op
486 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
488 -- If (but only if) the pattern can fail,
489 -- typecheck the 'fail' operator
490 ; fail_op' <- if isIrrefutableHsPat pat
491 then return noSyntaxExpr
492 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
494 -- We should typecheck the RHS *before* the pattern,
496 -- do { pat <- rhs; <rest> }
498 -- case rhs of { pat -> <rest> }
499 -- We do inference on rhs, so that information about its type
500 -- can be refined when type-checking the pattern.
502 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
504 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
507 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
508 = do { -- Deal with rebindable syntax;
509 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
510 -- See also Note [Treat rebindable syntax first]
511 ((then_op', rhs_ty), new_res_ty) <-
512 withBox liftedTypeKind $ \ new_res_ty ->
513 withBox liftedTypeKind $ \ rhs_ty ->
514 tcSyntaxOp DoOrigin then_op
515 (mkFunTys [rhs_ty, new_res_ty] res_ty)
517 ; rhs' <- tcMonoExprNC rhs rhs_ty
518 ; thing <- thing_inside new_res_ty
519 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
521 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
522 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
523 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
525 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
526 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
527 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
528 tup_ty = mkBoxedTupleTy tup_elt_tys
530 ; tcExtendIdEnv tup_ids $ do
531 { ((stmts', (ret_op', tup_rets)), stmts_ty)
532 <- withBox liftedTypeKind $ \ stmts_ty ->
533 tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
534 do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys
535 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
536 ; return (ret_op', tup_rets) }
538 ; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty ->
539 tcSyntaxOp DoOrigin mfix_op
540 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
542 ; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty ->
543 tcSyntaxOp DoOrigin bind_op
544 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
546 ; (thing,lie) <- getLIE (thing_inside new_res_ty)
547 ; lie_binds <- bindInstsOfLocalFuns lie tup_ids
549 ; let rec_ids = takeList rec_names tup_ids
550 ; later_ids <- tcLookupLocalIds later_names
551 ; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids),
552 ppr later_ids <+> ppr (map idType later_ids)])
553 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
554 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
555 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
556 , recS_rec_rets = tup_rets, recS_dicts = lie_binds }, thing)
559 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
560 tc_ret rec_name mono_ty
561 = do { poly_id <- tcLookupId rec_name
562 -- poly_id may have a polymorphic type
563 -- but mono_ty is just a monomorphic type variable
564 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
565 ; return (mkHsWrap co_fn (HsVar poly_id)) }
568 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
571 Note [Treat rebindable syntax first]
572 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
574 do { bar; ... } :: IO ()
575 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
576 pushing info from the context into the RHS. To do this, we check the
577 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
578 Otherwise the error shows up when cheking the rebindable syntax, and
579 the expected/inferred stuff is back to front (see Trac #3613).
582 --------------------------------
584 -- The distinctive features here are
586 -- (b) no rebindable syntax
588 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
590 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
591 = do { (rhs', pat_ty) <- tc_rhs rhs
592 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
593 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
595 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
596 = do { (rhs', elt_ty) <- tc_rhs rhs
597 ; thing <- thing_inside res_ty
598 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
600 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
601 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
602 ; let rec_ids = zipWith mkLocalId recNames rec_tys
603 ; tcExtendIdEnv rec_ids $ do
604 { (stmts', (later_ids, rec_rets))
605 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
606 -- ToDo: res_ty not really right
607 do { rec_rets <- zipWithM tc_ret recNames rec_tys
608 ; later_ids <- tcLookupLocalIds laterNames
609 ; return (later_ids, rec_rets) }
611 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
612 -- NB: The rec_ids for the recursive things
613 -- already scope over this part. This binding may shadow
614 -- some of them with polymorphic things with the same Name
615 -- (see note [RecStmt] in HsExpr)
616 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
618 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
621 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
622 tc_ret rec_name mono_ty
623 = do { poly_id <- tcLookupId rec_name
624 -- poly_id may have a polymorphic type
625 -- but mono_ty is just a monomorphic type variable
626 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
627 ; return (mkHsWrap co_fn (HsVar poly_id)) }
629 tcMDoStmt _ _ stmt _ _
630 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
635 %************************************************************************
637 \subsection{Errors and contexts}
639 %************************************************************************
641 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
642 number of args are used in each equation.
645 checkArgs :: Name -> MatchGroup Name -> TcM ()
646 checkArgs fun (MatchGroup (match1:matches) _)
647 | null bad_matches = return ()
649 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
650 ptext (sLit "have different numbers of arguments"),
651 nest 2 (ppr (getLoc match1)),
652 nest 2 (ppr (getLoc (head bad_matches)))])
654 n_args1 = args_in_match match1
655 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
657 args_in_match :: LMatch Name -> Int
658 args_in_match (L _ (Match pats _ _)) = length pats
659 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty