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 checkArgs fun_name matches
70 -- ToDo: Don't use "expected" stuff if there ain't a type signature
71 -- because inconsistency between branches
72 -- may show up as something wrong with the (non-existent) type signature
74 -- This is one of two places places we call subFunTys
75 -- The point is that if expected_y is a "hole", we want
76 -- to make pat_tys and rhs_ty as "holes" too.
77 ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
78 tcMatches match_ctxt pat_tys rhs_ty matches
81 doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
82 <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
83 n_pats = matchGroupArity matches
84 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
87 @tcMatchesCase@ doesn't do the argument-count check because the
88 parser guarantees that each equation has exactly one argument.
91 tcMatchesCase :: TcMatchCtxt -- Case context
92 -> TcRhoType -- Type of scrutinee
93 -> MatchGroup Name -- The case alternatives
94 -> BoxyRhoType -- Type of whole case expressions
95 -> TcM (MatchGroup TcId) -- Translated alternatives
97 tcMatchesCase ctxt scrut_ty matches res_ty
98 | isEmptyMatchGroup matches
99 = -- Allow empty case expressions
100 do { -- Make sure we follow the invariant that res_ty is filled in
101 res_ty' <- refineBoxToTau res_ty
102 ; return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
105 = tcMatches ctxt [scrut_ty] res_ty matches
107 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
108 tcMatchLambda match res_ty
109 = subFunTys doc n_pats res_ty Nothing $ \ 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 -> BoxyRhoType -> 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,
134 %************************************************************************
138 %************************************************************************
141 tcMatches :: TcMatchCtxt
142 -> [BoxySigmaType] -- Expected pattern types
143 -> BoxyRhoType -- Expected result-type of the Match.
145 -> TcM (MatchGroup TcId)
147 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
148 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
149 mc_body :: LHsExpr Name -- Type checker for a body of
152 -> TcM (LHsExpr TcId) }
154 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
155 = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
156 do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
157 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
160 tcMatch :: TcMatchCtxt
161 -> [BoxySigmaType] -- Expected pattern types
162 -> BoxyRhoType -- Expected result-type of the Match.
166 tcMatch ctxt pat_tys rhs_ty match
167 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
169 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
170 = add_match_ctxt match $
171 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
172 tc_grhss ctxt maybe_rhs_sig grhss
173 ; return (Match pats' Nothing grhss') }
175 tc_grhss ctxt Nothing grhss rhs_ty
176 = tcGRHSs ctxt grhss rhs_ty -- No result signature
178 -- Result type sigs are no longer supported
179 tc_grhss _ (Just {}) _ _
180 = panic "tc_ghrss" -- Rejected by renamer
182 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
183 -- so we don't want to add "In the lambda abstraction \x->e"
184 add_match_ctxt match thing_inside
185 = case mc_what ctxt of
186 LambdaExpr -> thing_inside
187 m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
190 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
193 -- Notice that we pass in the full res_ty, so that we get
194 -- good inference from simple things like
195 -- f = \(x::forall a.a->a) -> <stuff>
196 -- We used to force it to be a monotype when there was more than one guard
197 -- but we don't need to do that any more
199 tcGRHSs ctxt (GRHSs grhss binds) res_ty
200 = do { (binds', grhss') <- tcLocalBinds binds $
201 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
203 ; return (GRHSs grhss' binds') }
206 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
208 tcGRHS ctxt res_ty (GRHS guards rhs)
209 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
211 ; return (GRHS guards' rhs') }
213 stmt_ctxt = PatGuard (mc_what ctxt)
217 %************************************************************************
219 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
221 %************************************************************************
224 tcDoStmts :: HsStmtContext Name
228 -> TcM (HsExpr TcId) -- Returns a HsDo
229 tcDoStmts ListComp stmts body res_ty
230 = do { (elt_ty, coi) <- boxySplitListTy res_ty
231 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
234 ; return $ mkHsWrapCoI coi
235 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
237 tcDoStmts PArrComp stmts body res_ty
238 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
239 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
242 ; return $ mkHsWrapCoI coi
243 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
245 tcDoStmts DoExpr stmts body res_ty
246 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
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) groupByClause) elt_ty thing_inside = do
421 (stmts', (bindersMap', groupByClause', thing)) <-
422 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
423 let alphaListTy = mkTyConApp m_tc [alphaTy]
424 alphaListListTy = mkTyConApp m_tc [alphaListTy]
427 case groupByClause of
428 GroupByNothing usingExpr ->
429 -- We must validate that usingExpr :: forall a. [a] -> [[a]]
430 tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
431 GroupBySomething eitherUsingExpr byExpr -> do
432 -- We must infer a type such that byExpr :: t
433 (byExpr', tTy) <- tcInferRhoNC byExpr
435 -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
436 let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
438 case eitherUsingExpr of
439 Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
440 Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
441 return $ GroupBySomething eitherUsingExpr' byExpr'
443 -- Find the IDs and types of all old binders
444 let (oldBinders, newBinders) = unzip bindersMap
445 oldBinders' <- tcLookupLocalIds oldBinders
447 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
448 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
450 -- Type check the thing in the environment with these new binders and return the result
451 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
452 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
454 return (GroupStmt (stmts', bindersMap') groupByClause', thing)
456 associateNewBinder :: TcId -> Name -> TcId
457 associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
459 tcLcStmt _ _ stmt _ _
460 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
462 --------------------------------
464 -- The main excitement here is dealing with rebindable syntax
466 tcDoStmt :: TcStmtChecker
468 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
469 = do { -- Deal with rebindable syntax:
470 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
471 -- This level of generality is needed for using do-notation
472 -- in full generality; see Trac #1537
474 -- I'd like to put this *after* the tcSyntaxOp
475 -- (see Note [Treat rebindable syntax first], but that breaks
476 -- the rigidity info for GADTs. When we move to the new story
477 -- for GADTs, we can move this after tcSyntaxOp
478 (rhs', rhs_ty) <- tcInferRhoNC rhs
480 ; ((bind_op', new_res_ty), pat_ty) <-
481 withBox liftedTypeKind $ \ pat_ty ->
482 withBox liftedTypeKind $ \ new_res_ty ->
483 tcSyntaxOp DoOrigin bind_op
484 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
486 -- If (but only if) the pattern can fail,
487 -- typecheck the 'fail' operator
488 ; fail_op' <- if isIrrefutableHsPat pat
489 then return noSyntaxExpr
490 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
492 -- We should typecheck the RHS *before* the pattern,
494 -- do { pat <- rhs; <rest> }
496 -- case rhs of { pat -> <rest> }
497 -- We do inference on rhs, so that information about its type
498 -- can be refined when type-checking the pattern.
500 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
502 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
505 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
506 = do { -- Deal with rebindable syntax;
507 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
508 -- See also Note [Treat rebindable syntax first]
509 ((then_op', rhs_ty), new_res_ty) <-
510 withBox liftedTypeKind $ \ new_res_ty ->
511 withBox liftedTypeKind $ \ rhs_ty ->
512 tcSyntaxOp DoOrigin then_op
513 (mkFunTys [rhs_ty, new_res_ty] res_ty)
515 ; rhs' <- tcMonoExprNC rhs rhs_ty
516 ; thing <- thing_inside new_res_ty
517 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
519 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
520 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
521 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
523 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
524 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
525 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
526 tup_ty = mkBoxedTupleTy tup_elt_tys
528 ; tcExtendIdEnv tup_ids $ do
529 { ((stmts', (ret_op', tup_rets)), stmts_ty)
530 <- withBox liftedTypeKind $ \ stmts_ty ->
531 tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
532 do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys
533 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
534 ; return (ret_op', tup_rets) }
536 ; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty ->
537 tcSyntaxOp DoOrigin mfix_op
538 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
540 ; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty ->
541 tcSyntaxOp DoOrigin bind_op
542 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
544 ; (thing,lie) <- getLIE (thing_inside new_res_ty)
545 ; lie_binds <- bindInstsOfLocalFuns lie tup_ids
547 ; let rec_ids = takeList rec_names tup_ids
548 ; later_ids <- tcLookupLocalIds later_names
549 ; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids),
550 ppr later_ids <+> ppr (map idType later_ids)])
551 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
552 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
553 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
554 , recS_rec_rets = tup_rets, recS_dicts = lie_binds }, thing)
557 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
558 tc_ret rec_name mono_ty
559 = do { poly_id <- tcLookupId rec_name
560 -- poly_id may have a polymorphic type
561 -- but mono_ty is just a monomorphic type variable
562 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
563 ; return (mkHsWrap co_fn (HsVar poly_id)) }
566 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
569 Note [Treat rebindable syntax first]
570 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572 do { bar; ... } :: IO ()
573 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
574 pushing info from the context into the RHS. To do this, we check the
575 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
576 Otherwise the error shows up when cheking the rebindable syntax, and
577 the expected/inferred stuff is back to front (see Trac #3613).
580 --------------------------------
582 -- The distinctive features here are
584 -- (b) no rebindable syntax
586 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
588 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
589 = do { (rhs', pat_ty) <- tc_rhs rhs
590 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
591 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
593 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
594 = do { (rhs', elt_ty) <- tc_rhs rhs
595 ; thing <- thing_inside res_ty
596 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
598 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
599 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
600 ; let rec_ids = zipWith mkLocalId recNames rec_tys
601 ; tcExtendIdEnv rec_ids $ do
602 { (stmts', (later_ids, rec_rets))
603 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
604 -- ToDo: res_ty not really right
605 do { rec_rets <- zipWithM tc_ret recNames rec_tys
606 ; later_ids <- tcLookupLocalIds laterNames
607 ; return (later_ids, rec_rets) }
609 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
610 -- NB: The rec_ids for the recursive things
611 -- already scope over this part. This binding may shadow
612 -- some of them with polymorphic things with the same Name
613 -- (see note [RecStmt] in HsExpr)
614 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
616 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
619 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
620 tc_ret rec_name mono_ty
621 = do { poly_id <- tcLookupId rec_name
622 -- poly_id may have a polymorphic type
623 -- but mono_ty is just a monomorphic type variable
624 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
625 ; return (mkHsWrap co_fn (HsVar poly_id)) }
627 tcMDoStmt _ _ stmt _ _
628 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
633 %************************************************************************
635 \subsection{Errors and contexts}
637 %************************************************************************
639 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
640 number of args are used in each equation.
643 checkArgs :: Name -> MatchGroup Name -> TcM ()
644 checkArgs fun (MatchGroup (match1:matches) _)
645 | null bad_matches = return ()
647 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
648 ptext (sLit "have different numbers of arguments"),
649 nest 2 (ppr (getLoc match1)),
650 nest 2 (ppr (getLoc (head bad_matches)))])
652 n_args1 = args_in_match match1
653 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
655 args_in_match :: LMatch Name -> Int
656 args_in_match (L _ (Match pats _ _)) = length pats
657 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty