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 )
32 import Coercion ( mkSymCoI )
38 -- Create chunkified tuple tybes for monad comprehensions
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 (FunSigCtxt fun_name) 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 herald n_pats res_ty $ \ pat_tys rhs_ty ->
111 tcMatches match_ctxt pat_tys rhs_ty match
113 n_pats = matchGroupArity match
114 herald = 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
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 $
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
245 -> TcM (HsExpr TcId) -- Returns a HsDo
246 tcDoStmts ListComp stmts res_ty
247 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
248 ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts res_ty
249 ; return $ mkHsWrapCoI coi
250 (HsDo ListComp stmts' (mkListTy elt_ty)) }
252 tcDoStmts PArrComp stmts res_ty
253 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
254 ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
255 ; return $ mkHsWrapCoI coi
256 (HsDo PArrComp stmts' (mkPArrTy elt_ty)) }
258 tcDoStmts DoExpr stmts res_ty
259 = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
260 ; return (HsDo DoExpr stmts' res_ty) }
262 tcDoStmts MDoExpr stmts res_ty
263 = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
264 ; return (HsDo MDoExpr stmts' res_ty) }
266 tcDoStmts MonadComp stmts res_ty
267 = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
268 ; return (HsDo MonadComp stmts' res_ty) }
270 tcDoStmts ctxt _ _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
272 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
274 = do { traceTc "tcBody" (ppr res_ty)
275 ; body' <- tcMonoExpr body res_ty
281 %************************************************************************
285 %************************************************************************
289 = forall thing. HsStmtContext Name
291 -> TcRhoType -- Result type for comprehension
292 -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt
293 -> TcM (Stmt TcId, thing)
295 tcStmts :: HsStmtContext Name
296 -> TcStmtChecker -- NB: higher-rank type
300 tcStmts ctxt stmt_chk stmts res_ty
301 = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_check stmts res_ty $
305 tcStmtsAndThen :: HsStmtContext Name
306 -> TcStmtChecker -- NB: higher-rank type
309 -> (TcRhoType -> TcM thing)
310 -> TcM ([LStmt TcId], thing)
312 -- Note the higher-rank type. stmt_chk is applied at different
313 -- types in the equations for tcStmts
315 tcStmtsAndThen _ _ [] res_ty thing_inside
316 = do { thing <- thing_inside res_ty
317 ; return ([], thing) }
319 -- LetStmts are handled uniformly, regardless of context
320 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
321 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
322 tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
323 ; return (L loc (LetStmt binds') : stmts', thing) }
325 -- For the vanilla case, handle the location-setting part
326 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
327 = do { (stmt', (stmts', thing)) <-
329 addErrCtxt (pprStmtInCtxt ctxt stmt) $
330 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
332 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
334 ; return (L loc stmt' : stmts', thing) }
336 --------------------------------
338 tcGuardStmt :: TcStmtChecker
339 tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
340 = do { guard' <- tcMonoExpr guard boolTy
341 ; thing <- thing_inside res_ty
342 ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
344 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
345 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
346 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $
348 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
350 tcGuardStmt _ stmt _ _
351 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
354 --------------------------------
355 -- List comprehensions and PArrays
357 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
360 tcLcStmt m_tc ctxt (LastStmt body _) elt_ty thing_inside
361 = do { body' <- tcMonoExpr body elt_ty
362 ; thing <- thing_inside elt_ty
363 ; return (LastStmt body' noSyntaxExpr, thing) }
365 -- A generator, pat <- rhs
366 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
367 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
368 ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
369 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
371 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
374 tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
375 = do { rhs' <- tcMonoExpr rhs boolTy
376 ; thing <- thing_inside elt_ty
377 ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
379 -- A parallel set of comprehensions
380 -- [ (g x, h x) | ... ; let g v = ...
381 -- | ... ; let h v = ... ]
383 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
384 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
385 -- Similarly if we had an existential pattern match:
387 -- data T = forall a. Show a => C a
389 -- [ (show x, show y) | ... ; C x <- ...
390 -- | ... ; C y <- ... ]
392 -- Then we need the LIE from (show x, show y) to be simplified against
393 -- the bindings for x and y.
395 -- It's difficult to do this in parallel, so we rely on the renamer to
396 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
397 -- So the binders of the first parallel group will be in scope in the second
398 -- group. But that's fine; there's no shadowing to worry about.
400 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
401 = do { (pairs', thing) <- loop bndr_stmts_s
402 ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
404 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
405 loop [] = do { thing <- thing_inside elt_ty
406 ; return ([], thing) } -- matching in the branches
408 loop ((stmts, names) : pairs)
409 = do { (stmts', (ids, pairs', thing))
410 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
411 do { ids <- tcLookupLocalIds names
412 ; (pairs', thing) <- loop pairs
413 ; return (ids, pairs', thing) }
414 ; return ( (stmts', ids) : pairs', thing ) }
416 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_ty thing_inside = do
417 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
418 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
419 let alphaListTy = mkTyConApp m_tc [alphaTy]
421 (usingExpr', maybeByExpr') <-
424 -- We must validate that usingExpr :: forall a. [a] -> [a]
425 let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
426 usingExpr' <- tcPolyExpr usingExpr using_ty
427 return (usingExpr', Nothing)
429 -- We must infer a type such that e :: t and then check that
430 -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
431 (byExpr', tTy) <- tcInferRhoNC byExpr
432 let using_ty = mkForAllTy alphaTyVar $
433 (alphaTy `mkFunTy` tTy)
434 `mkFunTy` alphaListTy `mkFunTy` alphaListTy
435 usingExpr' <- tcPolyExpr usingExpr using_ty
436 return (usingExpr', Just byExpr')
438 binders' <- tcLookupLocalIds binders
439 thing <- thing_inside elt_ty'
441 return (binders', usingExpr', maybeByExpr', thing)
443 return (TransformStmt stmts' binders' usingExpr' maybeByExpr' noSyntaxExpr noSyntaxExpr, thing)
445 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_inside
446 = do { let (bndr_names, list_bndr_names) = unzip bindersMap
448 ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
449 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
452 Nothing -> -- check that using :: forall a. [a] -> [[a]]
453 return (Nothing, mkForAllTy alphaTyVar $
454 alphaListTy `mkFunTy` alphaListListTy)
456 Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
458 do { (by_e', t_ty) <- tcInferRhoNC by_e
459 ; return (Just by_e', mkForAllTy alphaTyVar $
460 (alphaTy `mkFunTy` t_ty)
461 `mkFunTy` alphaListTy
462 `mkFunTy` alphaListListTy) }
463 -- Find the Ids (and hence types) of all old binders
464 bndr_ids <- tcLookupLocalIds bndr_names
466 return (bndr_ids, by', using_ty, elt_ty')
468 -- Ensure that every old binder of type b is linked up with
469 -- its new binder which should have type [b]
470 ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
471 bindersMap' = bndr_ids `zip` list_bndr_ids
472 -- See Note [GroupStmt binder map] in HsExpr
474 ; using' <- case using of
475 Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
476 Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
478 -- Type check the thing in the environment with
479 -- these new binders and return the result
480 ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
481 ; return (GroupStmt stmts' bindersMap' by' using' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
483 alphaListTy = mkTyConApp m_tc [alphaTy]
484 alphaListListTy = mkTyConApp m_tc [alphaListTy]
486 mk_list_bndr :: Name -> TcId -> TcId
487 mk_list_bndr list_bndr_name bndr_id
488 = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
490 tcLcStmt _ _ stmt _ _
491 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
494 --------------------------------
495 -- Monad comprehensions
497 tcMcStmt :: TcStmtChecker
499 tcMcStmt ctxt (LastStmt body return_op) res_ty thing_inside
500 = do { a_ty <- newFlexiTyVarTy liftedTypeKind
501 ; return_op' <- tcSyntaxOp MCompOrigin return_op
502 (a_ty `mkFunTy` res_ty)
503 ; body' <- tcMonoExpr body a_ty
504 ; return (body', return_op') }
506 -- Generators for monad comprehensions ( pat <- rhs )
508 -- [ body | q <- gen ] -> gen :: m a
512 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
513 = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
514 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
515 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
517 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
518 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
519 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
521 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
522 ; fail_op' <- if isIrrefutableHsPat pat
523 then return noSyntaxExpr
524 else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
526 ; rhs' <- tcMonoExprNC rhs rhs_ty
527 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
528 thing_inside new_res_ty
530 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
532 -- Boolean expressions.
534 -- [ body | stmts, expr ] -> expr :: m Bool
536 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
537 = do { -- Deal with rebindable syntax:
538 -- guard_op :: test_ty -> rhs_ty
539 -- then_op :: rhs_ty -> new_res_ty -> res_ty
540 -- Where test_ty is, for example, Bool
541 test_ty <- newFlexiTyVarTy liftedTypeKind
542 ; rhs_ty <- newFlexiTyVarTy liftedTypeKind
543 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
544 ; rhs' <- tcMonoExpr rhs test_ty
545 ; guard_op' <- tcSyntaxOp MCompOrigin guard_op
546 (mkFunTy test_ty rhs_ty)
547 ; then_op' <- tcSyntaxOp MCompOrigin then_op
548 (mkFunTys [rhs_ty, new_res_ty] res_ty)
549 ; thing <- thing_inside new_res_ty
550 ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
552 -- Transform statements.
554 -- [ body | stmts, then f ] -> f :: forall a. m a -> m a
555 -- [ body | stmts, then f by e ] -> f :: forall a. (a -> t) -> m a -> m a
557 tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) res_ty thing_inside
559 -- We don't know the types of binders yet, so we use this dummy and
560 -- later unify this type with the `m_bndr_ty`
561 ty_dummy <- newFlexiTyVarTy liftedTypeKind
563 ; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
564 tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do
565 { (_, (m_ty, _)) <- matchExpectedAppTy res_ty'
566 ; (usingExpr', maybeByExpr') <-
569 -- We must validate that usingExpr :: forall a. m a -> m a
570 let using_ty = mkForAllTy alphaTyVar $
571 (m_ty `mkAppTy` alphaTy)
573 (m_ty `mkAppTy` alphaTy)
574 usingExpr' <- tcPolyExpr usingExpr using_ty
575 return (usingExpr', Nothing)
577 -- We must infer a type such that e :: t and then check that
578 -- usingExpr :: forall a. (a -> t) -> m a -> m a
579 (byExpr', tTy) <- tcInferRhoNC byExpr
580 let using_ty = mkForAllTy alphaTyVar $
581 (alphaTy `mkFunTy` tTy)
583 (m_ty `mkAppTy` alphaTy)
585 (m_ty `mkAppTy` alphaTy)
586 usingExpr' <- tcPolyExpr usingExpr using_ty
587 return (usingExpr', Just byExpr')
589 ; bndr_ids <- tcLookupLocalIds binders
591 -- `return` and `>>=` are used to pass around/modify our
592 -- binders, so we know their types:
594 -- return :: (a,b,c,..) -> m (a,b,c,..)
595 -- (>>=) :: m (a,b,c,..)
596 -- -> ( (a,b,c,..) -> m (a,b,c,..) )
599 ; let bndr_ty = mkBigCoreVarTupTy bndr_ids
600 m_bndr_ty = m_ty `mkAppTy` bndr_ty
602 ; return_op' <- tcSyntaxOp MCompOrigin return_op
603 (bndr_ty `mkFunTy` m_bndr_ty)
605 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
606 m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` res_ty)
609 -- Unify types of the inner comprehension and the binders type
610 ; _ <- unifyType res_ty' m_bndr_ty
612 -- Typecheck the `thing` with out old type (which is the type
613 -- of the final result of our comprehension)
614 ; thing <- thing_inside res_ty
616 ; return (bndr_ids, usingExpr', maybeByExpr', return_op', bind_op', thing) }
618 ; return (TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op', thing) }
620 -- Grouping statements
622 -- [ body | stmts, then group by e ]
624 -- [ body | stmts, then group by e using f ]
626 -- f :: forall a. (a -> t) -> m a -> m (m a)
627 -- [ body | stmts, then group using f ]
628 -- -> f :: forall a. m a -> m (m a)
630 tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) res_ty thing_inside
631 = do { m1_ty <- newFlexiTyVarTy liftedTypeKind
632 ; m2_ty <- newFlexiTyVarTy liftedTypeKind
633 ; n_ty <- newFlexiTyVarTy liftedTypeKind
634 ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
635 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
636 ; let (bndr_names, n_bndr_names) = unzip bindersMap
637 m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
639 -- 'stmts' returns a result of type (m1_ty tuple_ty),
640 -- typically something like [(Int,Bool,Int)]
641 -- We don't know what tuple_ty is yet, so we use a variable
642 ; (stmts', (bndr_ids, by_e_ty, return_op')) <-
643 tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
644 { by_e_ty <- mapM tcInferRhoNC by_e
646 -- Find the Ids (and hence types) of all old binders
647 ; bndr_ids <- tcLookupLocalIds bndr_names
649 -- 'return' is only used for the binders, so we know its type.
651 -- return :: (a,b,c,..) -> m (a,b,c,..)
652 ; return_op' <- tcSyntaxOp MCompOrigin return_op $
653 (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
655 ; return (bndr_ids, by_e_ty, return_op') }
659 ; let tup_ty = mkBigCoreVarTupTy bndr_ids -- (a,b,c)
660 using_arg_ty = m1_ty `mkAppTy` tup_ty -- m1 (a,b,c)
661 n_tup_ty = n_ty `mkAppTy` tup_ty -- n (a,b,c)
662 using_res_ty = m2_ty `mkAppTy` n_tup_ty -- m2 (n (a,b,c))
663 using_fun_ty = using_arg_ty `mkFunTy` using_arg_ty
665 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
666 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
668 --------------- Typecheck the 'bind' function -------------
669 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
670 using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty)
673 --------------- Typecheck the 'using' function -------------
674 ; let using_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy`
675 (m2_ty `mkAppTy` (n_ty `mkAppTy` alphaTy))
676 using_poly_ty = case by_e_ty of
677 Nothing -> mkForAllTy alphaTyVar using_fun_ty
678 -- using :: forall a. m1 a -> m2 (n a)
680 Just (_,t_ty) -> mkForAllTy alphaTyVar $
681 (alphaTy `mkFunTy` t_ty) `mkFunTy` using_fun_ty
682 -- using :: forall a. (a->t) -> m1 a -> m2 (n a)
685 ; using' <- case using of
686 Left e -> do { e' <- tcPolyExpr e using_poly_ty
688 Right e -> do { e' <- tcPolyExpr (noLoc e) using_poly_ty
689 ; return (Right (unLoc e')) }
690 ; coi <- unifyType (applyTy using_poly_ty tup_ty)
692 Nothing -> using_fun_ty
693 Just (_,t_ty) -> (tup_ty `mkFunTy` t_ty) `mkFunTy` using_fun_ty)
694 ; let final_using = mkHsWrapCoI coi (HsWrap (WpTyApp tup_ty) using')
696 --------------- Typecheck the 'fmap' function -------------
697 ; fmap_op' <- fmap unLoc . tcPolyExpr (noLoc fmap_op) $
698 mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
699 (alphaTy `mkFunTy` betaTy)
701 (m_ty `mkAppTy` alphaTy)
703 (m_ty `mkAppTy` betaTy)
705 ; let mk_n_bndr :: Name -> TcId -> TcId
706 mk_n_bndr n_bndr_name bndr_id
707 = mkLocalId bndr_name (n_ty `mkAppTy` idType bndr_id)
709 -- Ensure that every old binder of type `b` is linked up with its
710 -- new binder which should have type `n b`
711 -- See Note [GroupStmt binder map] in HsExpr
712 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
713 bindersMap' = bndr_ids `zip` n_bndr_ids
715 -- Type check the thing in the environment with these new binders and
717 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
719 ; return (GroupStmt stmts' bindersMap'
720 (fmap fst by_e_ty) final_using
721 return_op' bind_op' fmap_op', thing) }
723 -- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
726 -- Note: The `mzip` function will get typechecked via:
728 -- ParStmt [st1::t1, st2::t2, st3::t3]
731 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
732 -- -> m (st1, (st2, st3))
734 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
735 = do { (_,(m_ty,_)) <- matchExpectedAppTy res_ty
736 ; (pairs', thing) <- loop m_ty bndr_stmts_s
738 ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
739 (m_ty `mkAppTy` alphaTy)
741 (m_ty `mkAppTy` betaTy)
743 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
744 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
747 ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
748 tuple_ty = mk_tuple_ty tys
750 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
751 (m_ty `mkAppTy` tuple_ty)
753 (tuple_ty `mkFunTy` res_ty)
757 ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
758 mkForAllTy alphaTyVar $
759 alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
760 ; return_op' <- tcSyntaxOp MCompOrigin return_op
761 (bndr_ty `mkFunTy` m_bndr_ty)
763 ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
765 where mk_tuple_ty tys = foldr (\tn tm -> mkBoxedTupleTy [tn, tm]) (last tys) (init tys)
767 -- loop :: Type -- m_ty
768 -- -> [([LStmt Name], [Name])]
769 -- -> TcM ([([LStmt TcId], [TcId])], thing)
770 loop _ [] = do { thing <- thing_inside res_ty
771 ; return ([], thing) } -- matching in the branches
773 loop m_ty ((stmts, names) : pairs)
774 = do { -- type dummy since we don't know all binder types yet
775 ty_dummy <- newFlexiTyVarTy liftedTypeKind
776 ; (stmts', (ids, pairs', thing))
777 <- tcStmts ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
778 do { ids <- tcLookupLocalIds names
779 ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids)
780 ; (pairs', thing) <- loop m_ty pairs
781 ; return (ids, pairs', thing) }
782 ; return ( (stmts', ids) : pairs', thing ) }
785 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
787 --------------------------------
789 -- The main excitement here is dealing with rebindable syntax
791 tcDoStmt :: TcStmtChecker
793 tcDoStmt ctxt (LastStmt body _) res_ty thing_inside
794 = do { body' <- tcMonoExpr body res_ty
795 ; thing <- thing_inside body_ty
796 ; return (LastStmt body' noSyntaxExpr, thing) }
798 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
799 = do { -- Deal with rebindable syntax:
800 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
801 -- This level of generality is needed for using do-notation
802 -- in full generality; see Trac #1537
804 -- I'd like to put this *after* the tcSyntaxOp
805 -- (see Note [Treat rebindable syntax first], but that breaks
806 -- the rigidity info for GADTs. When we move to the new story
807 -- for GADTs, we can move this after tcSyntaxOp
808 rhs_ty <- newFlexiTyVarTy liftedTypeKind
809 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
810 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
811 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
812 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
814 -- If (but only if) the pattern can fail,
815 -- typecheck the 'fail' operator
816 ; fail_op' <- if isIrrefutableHsPat pat
817 then return noSyntaxExpr
818 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
820 ; rhs' <- tcMonoExprNC rhs rhs_ty
821 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
822 thing_inside new_res_ty
824 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
827 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
828 = do { -- Deal with rebindable syntax;
829 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
830 -- See also Note [Treat rebindable syntax first]
831 rhs_ty <- newFlexiTyVarTy liftedTypeKind
832 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
833 ; then_op' <- tcSyntaxOp DoOrigin then_op
834 (mkFunTys [rhs_ty, new_res_ty] res_ty)
836 ; rhs' <- tcMonoExprNC rhs rhs_ty
837 ; thing <- thing_inside new_res_ty
838 ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
840 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
841 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
842 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
844 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
845 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
846 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
847 tup_ty = mkBoxedTupleTy tup_elt_tys
849 ; tcExtendIdEnv tup_ids $ do
850 { stmts_ty <- newFlexiTyVarTy liftedTypeKind
851 ; (stmts', (ret_op', tup_rets))
852 <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
853 do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
854 -- Unify the types of the "final" Ids (which may
855 -- be polymorphic) with those of "knot-tied" Ids
856 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
857 ; return (ret_op', tup_rets) }
859 ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
860 ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
861 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
863 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
864 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
865 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
867 ; thing <- thing_inside new_res_ty
868 -- ; lie_binds <- bindLocalMethods lie tup_ids
870 ; let rec_ids = takeList rec_names tup_ids
871 ; later_ids <- tcLookupLocalIds later_names
872 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
873 ppr later_ids <+> ppr (map idType later_ids)]
874 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
875 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
876 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
877 , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
881 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
884 Note [Treat rebindable syntax first]
885 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
887 do { bar; ... } :: IO ()
888 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
889 pushing info from the context into the RHS. To do this, we check the
890 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
891 Otherwise the error shows up when cheking the rebindable syntax, and
892 the expected/inferred stuff is back to front (see Trac #3613).
895 --------------------------------
897 -- The distinctive features here are
899 -- (b) no rebindable syntax
901 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
903 -- Used only by TcArrows... should be gotten rid of
904 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
905 = do { (rhs', pat_ty) <- tc_rhs rhs
906 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
908 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
910 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside
911 = do { (rhs', elt_ty) <- tc_rhs rhs
912 ; thing <- thing_inside res_ty
913 ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
915 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
916 , recS_rec_ids = recNames }) res_ty thing_inside
917 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
918 ; let rec_ids = zipWith mkLocalId recNames rec_tys
919 ; tcExtendIdEnv rec_ids $ do
920 { (stmts', (later_ids, rec_rets))
921 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
922 -- ToDo: res_ty not really right
923 do { rec_rets <- zipWithM tcCheckId recNames rec_tys
924 ; later_ids <- tcLookupLocalIds laterNames
925 ; return (later_ids, rec_rets) }
927 ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
928 -- NB: The rec_ids for the recursive things
929 -- already scope over this part. This binding may shadow
930 -- some of them with polymorphic things with the same Name
931 -- (see note [RecStmt] in HsExpr)
933 ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
936 tcMDoStmt _ _ stmt _ _
937 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
942 %************************************************************************
944 \subsection{Errors and contexts}
946 %************************************************************************
948 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
949 number of args are used in each equation.
952 checkArgs :: Name -> MatchGroup Name -> TcM ()
953 checkArgs fun (MatchGroup (match1:matches) _)
954 | null bad_matches = return ()
956 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
957 ptext (sLit "have different numbers of arguments"),
958 nest 2 (ppr (getLoc match1)),
959 nest 2 (ppr (getLoc (head bad_matches)))])
961 n_args1 = args_in_match match1
962 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
964 args_in_match :: LMatch Name -> Int
965 args_in_match (L _ (Match pats _ _)) = length pats
966 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty