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 )
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.
57 tcMatchesFun :: Name -> Bool
59 -> BoxyRhoType -- Expected type of function
60 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
62 tcMatchesFun fun_name inf matches exp_ty
63 = do { -- Check that they all have the same no of arguments
64 -- Location is in the monad, set the caller so that
65 -- any inter-equation error messages get some vaguely
66 -- sensible location. Note: we have to do this odd
67 -- ann-grabbing, because we don't always have annotations in
68 -- hand when we call tcMatchesFun...
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
250 ; return (HsDo DoExpr stmts' body' res_ty) }
252 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
253 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
254 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
255 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
256 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
258 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
262 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
263 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
266 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
268 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
270 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
272 = do { traceTc (text "tcBody" <+> ppr res_ty)
273 ; body' <- tcMonoExpr body res_ty
279 %************************************************************************
283 %************************************************************************
287 = forall thing. HsStmtContext Name
289 -> BoxyRhoType -- Result type for comprehension
290 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
291 -> TcM (Stmt TcId, thing)
293 tcStmts :: HsStmtContext Name
294 -> TcStmtChecker -- NB: higher-rank type
297 -> (BoxyRhoType -> TcM thing)
298 -> TcM ([LStmt TcId], thing)
300 -- Note the higher-rank type. stmt_chk is applied at different
301 -- types in the equations for tcStmts
303 tcStmts _ _ [] res_ty thing_inside
304 = do { thing <- thing_inside res_ty
305 ; return ([], thing) }
307 -- LetStmts are handled uniformly, regardless of context
308 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
309 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
310 tcStmts ctxt stmt_chk stmts res_ty thing_inside
311 ; return (L loc (LetStmt binds') : stmts', thing) }
313 -- For the vanilla case, handle the location-setting part
314 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
315 = do { (stmt', (stmts', thing)) <-
317 addErrCtxt (pprStmtInCtxt ctxt stmt) $
318 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
320 tcStmts ctxt stmt_chk stmts res_ty' $
322 ; return (L loc stmt' : stmts', thing) }
324 --------------------------------
326 tcGuardStmt :: TcStmtChecker
327 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
328 = do { guard' <- tcMonoExpr guard boolTy
329 ; thing <- thing_inside res_ty
330 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
332 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
333 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
334 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
335 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
337 tcGuardStmt _ stmt _ _
338 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
341 --------------------------------
342 -- List comprehensions and PArrays
344 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
347 -- A generator, pat <- rhs
348 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
349 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
350 tcMonoExpr rhs (mkTyConApp m_tc [ty])
351 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
352 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
355 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
356 = do { rhs' <- tcMonoExpr rhs boolTy
357 ; thing <- thing_inside res_ty
358 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
360 -- A parallel set of comprehensions
361 -- [ (g x, h x) | ... ; let g v = ...
362 -- | ... ; let h v = ... ]
364 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
365 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
366 -- Similarly if we had an existential pattern match:
368 -- data T = forall a. Show a => C a
370 -- [ (show x, show y) | ... ; C x <- ...
371 -- | ... ; C y <- ... ]
373 -- Then we need the LIE from (show x, show y) to be simplified against
374 -- the bindings for x and y.
376 -- It's difficult to do this in parallel, so we rely on the renamer to
377 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
378 -- So the binders of the first parallel group will be in scope in the second
379 -- group. But that's fine; there's no shadowing to worry about.
381 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
382 = do { (pairs', thing) <- loop bndr_stmts_s
383 ; return (ParStmt pairs', thing) }
385 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
386 loop [] = do { thing <- thing_inside elt_ty
387 ; return ([], thing) } -- matching in the branches
389 loop ((stmts, names) : pairs)
390 = do { (stmts', (ids, pairs', thing))
391 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
392 do { ids <- tcLookupLocalIds names
393 ; (pairs', thing) <- loop pairs
394 ; return (ids, pairs', thing) }
395 ; return ( (stmts', ids) : pairs', thing ) }
397 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
398 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
399 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
400 let alphaListTy = mkTyConApp m_tc [alphaTy]
402 (usingExpr', maybeByExpr') <-
405 -- We must validate that usingExpr :: forall a. [a] -> [a]
406 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
407 return (usingExpr', Nothing)
409 -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
410 (byExpr', tTy) <- tcInferRhoNC byExpr
411 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
412 return (usingExpr', Just byExpr')
414 binders' <- tcLookupLocalIds binders
415 thing <- thing_inside elt_ty'
417 return (binders', usingExpr', maybeByExpr', thing)
419 return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
421 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
422 (stmts', (bindersMap', groupByClause', thing)) <-
423 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
424 let alphaListTy = mkTyConApp m_tc [alphaTy]
425 alphaListListTy = mkTyConApp m_tc [alphaListTy]
428 case groupByClause of
429 GroupByNothing usingExpr ->
430 -- We must validate that usingExpr :: forall a. [a] -> [[a]]
431 tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
432 GroupBySomething eitherUsingExpr byExpr -> do
433 -- We must infer a type such that byExpr :: t
434 (byExpr', tTy) <- tcInferRhoNC byExpr
436 -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
437 let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
439 case eitherUsingExpr of
440 Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
441 Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
442 return $ GroupBySomething eitherUsingExpr' byExpr'
444 -- Find the IDs and types of all old binders
445 let (oldBinders, newBinders) = unzip bindersMap
446 oldBinders' <- tcLookupLocalIds oldBinders
448 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
449 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
451 -- Type check the thing in the environment with these new binders and return the result
452 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
453 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
455 return (GroupStmt (stmts', bindersMap') groupByClause', thing)
457 associateNewBinder :: TcId -> Name -> TcId
458 associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
460 tcLcStmt _ _ stmt _ _
461 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
463 --------------------------------
465 -- The main excitement here is dealing with rebindable syntax
467 tcDoStmt :: TcStmtChecker
469 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
470 = do { -- Deal with rebindable syntax:
471 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
472 -- This level of generality is needed for using do-notation
473 -- in full generality; see Trac #1537
475 -- I'd like to put this *after* the tcSyntaxOp
476 -- (see Note [Treat rebindable syntax first], but that breaks
477 -- the rigidity info for GADTs. When we move to the new story
478 -- for GADTs, we can move this after tcSyntaxOp
479 (rhs', rhs_ty) <- tcInferRhoNC rhs
481 ; ((bind_op', new_res_ty), pat_ty) <-
482 withBox liftedTypeKind $ \ pat_ty ->
483 withBox liftedTypeKind $ \ new_res_ty ->
484 tcSyntaxOp DoOrigin bind_op
485 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
487 -- If (but only if) the pattern can fail,
488 -- typecheck the 'fail' operator
489 ; fail_op' <- if isIrrefutableHsPat pat
490 then return noSyntaxExpr
491 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
493 -- We should typecheck the RHS *before* the pattern,
495 -- do { pat <- rhs; <rest> }
497 -- case rhs of { pat -> <rest> }
498 -- We do inference on rhs, so that information about its type
499 -- can be refined when type-checking the pattern.
501 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
503 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
506 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
507 = do { -- Deal with rebindable syntax;
508 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
509 -- See also Note [Treat rebindable syntax first]
510 ((then_op', rhs_ty), new_res_ty) <-
511 withBox liftedTypeKind $ \ new_res_ty ->
512 withBox liftedTypeKind $ \ rhs_ty ->
513 tcSyntaxOp DoOrigin then_op
514 (mkFunTys [rhs_ty, new_res_ty] res_ty)
516 ; rhs' <- tcMonoExprNC rhs rhs_ty
517 ; thing <- thing_inside new_res_ty
518 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
520 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
521 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
522 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
524 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
525 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
526 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
527 tup_ty = mkCoreTupTy tup_elt_tys
529 ; tcExtendIdEnv tup_ids $ do
530 { ((stmts', (ret_op', tup_rets)), stmts_ty)
531 <- withBox liftedTypeKind $ \ stmts_ty ->
532 tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
533 do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys
534 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
535 ; return (ret_op', tup_rets) }
537 ; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty ->
538 tcSyntaxOp DoOrigin mfix_op
539 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
541 ; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty ->
542 tcSyntaxOp DoOrigin bind_op
543 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
545 ; (thing,lie) <- getLIE (thing_inside new_res_ty)
546 ; lie_binds <- bindInstsOfLocalFuns lie tup_ids
548 ; let rec_ids = takeList rec_names tup_ids
549 ; later_ids <- tcLookupLocalIds later_names
550 ; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids),
551 ppr later_ids <+> ppr (map idType later_ids)])
552 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
553 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
554 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
555 , recS_rec_rets = tup_rets, recS_dicts = lie_binds }, thing)
558 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
559 tc_ret rec_name mono_ty
560 = do { poly_id <- tcLookupId rec_name
561 -- poly_id may have a polymorphic type
562 -- but mono_ty is just a monomorphic type variable
563 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
564 ; return (mkHsWrap co_fn (HsVar poly_id)) }
567 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
570 Note [Treat rebindable syntax first]
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
573 do { bar; ... } :: IO ()
574 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
575 pushing info from the context into the RHS. To do this, we check the
576 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
577 Otherwise the error shows up when cheking the rebindable syntax, and
578 the expected/inferred stuff is back to front (see Trac #3613).
581 --------------------------------
583 -- The distinctive features here are
585 -- (b) no rebindable syntax
587 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
589 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
590 = do { (rhs', pat_ty) <- tc_rhs rhs
591 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
592 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
594 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
595 = do { (rhs', elt_ty) <- tc_rhs rhs
596 ; thing <- thing_inside res_ty
597 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
599 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
600 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
601 ; let rec_ids = zipWith mkLocalId recNames rec_tys
602 ; tcExtendIdEnv rec_ids $ do
603 { (stmts', (later_ids, rec_rets))
604 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
605 -- ToDo: res_ty not really right
606 do { rec_rets <- zipWithM tc_ret recNames rec_tys
607 ; later_ids <- tcLookupLocalIds laterNames
608 ; return (later_ids, rec_rets) }
610 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
611 -- NB: The rec_ids for the recursive things
612 -- already scope over this part. This binding may shadow
613 -- some of them with polymorphic things with the same Name
614 -- (see note [RecStmt] in HsExpr)
615 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
617 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
620 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
621 tc_ret rec_name mono_ty
622 = do { poly_id <- tcLookupId rec_name
623 -- poly_id may have a polymorphic type
624 -- but mono_ty is just a monomorphic type variable
625 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
626 ; return (mkHsWrap co_fn (HsVar poly_id)) }
628 tcMDoStmt _ _ stmt _ _
629 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
634 %************************************************************************
636 \subsection{Errors and contexts}
638 %************************************************************************
640 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
641 number of args are used in each equation.
644 checkArgs :: Name -> MatchGroup Name -> TcM ()
645 checkArgs fun (MatchGroup (match1:matches) _)
646 | null bad_matches = return ()
648 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
649 ptext (sLit "have different numbers of arguments"),
650 nest 2 (ppr (getLoc match1)),
651 nest 2 (ppr (getLoc (head bad_matches)))])
653 n_args1 = args_in_match match1
654 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
656 args_in_match :: LMatch Name -> Int
657 args_in_match (L _ (Match pats _ _)) = length pats
658 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty