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, tcStmtsAndThen, 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') <- tcStmtsAndThen 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 elt_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_chk 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 _ _ (LastStmt body _) elt_ty thing_inside
361 = do { body' <- tcMonoExprNC body elt_ty
362 ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
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 <- tcStmtsAndThen 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 tcStmtsAndThen (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 { grpS_stmts = stmts, grpS_bndrs = bindersMap
446 , grpS_by = by, grpS_using = using
447 , grpS_explicit = explicit }) elt_ty thing_inside
448 = do { let (bndr_names, list_bndr_names) = unzip bindersMap
450 ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
451 tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
454 Nothing -> -- check that using :: forall a. [a] -> [[a]]
455 return (Nothing, mkForAllTy alphaTyVar $
456 alphaListTy `mkFunTy` alphaListListTy)
458 Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
460 do { (by_e', t_ty) <- tcInferRhoNC by_e
461 ; return (Just by_e', mkForAllTy alphaTyVar $
462 (alphaTy `mkFunTy` t_ty)
463 `mkFunTy` alphaListTy
464 `mkFunTy` alphaListListTy) }
465 -- Find the Ids (and hence types) of all old binders
466 bndr_ids <- tcLookupLocalIds bndr_names
468 return (bndr_ids, by', using_ty, elt_ty')
470 -- Ensure that every old binder of type b is linked up with
471 -- its new binder which should have type [b]
472 ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
473 bindersMap' = bndr_ids `zip` list_bndr_ids
474 -- See Note [GroupStmt binder map] in HsExpr
476 ; using' <- tcPolyExpr using using_ty
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 (emptyGroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
482 , grpS_by = by', grpS_using = using'
483 , grpS_explicit = explicit }, thing) }
485 alphaListTy = mkTyConApp m_tc [alphaTy]
486 alphaListListTy = mkTyConApp m_tc [alphaListTy]
488 mk_list_bndr :: Name -> TcId -> TcId
489 mk_list_bndr list_bndr_name bndr_id
490 = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
492 tcLcStmt _ _ stmt _ _
493 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
496 --------------------------------
497 -- Monad comprehensions
499 tcMcStmt :: TcStmtChecker
501 tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
502 = do { a_ty <- newFlexiTyVarTy liftedTypeKind
503 ; return_op' <- tcSyntaxOp MCompOrigin return_op
504 (a_ty `mkFunTy` res_ty)
505 ; body' <- tcMonoExprNC body a_ty
506 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
507 ; return (LastStmt body' return_op', thing) }
509 -- Generators for monad comprehensions ( pat <- rhs )
511 -- [ body | q <- gen ] -> gen :: m a
515 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
516 = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
517 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
518 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
520 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
521 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
522 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
524 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
525 ; fail_op' <- if isIrrefutableHsPat pat
526 then return noSyntaxExpr
527 else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
529 ; rhs' <- tcMonoExprNC rhs rhs_ty
530 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
531 thing_inside new_res_ty
533 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
535 -- Boolean expressions.
537 -- [ body | stmts, expr ] -> expr :: m Bool
539 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
540 = do { -- Deal with rebindable syntax:
541 -- guard_op :: test_ty -> rhs_ty
542 -- then_op :: rhs_ty -> new_res_ty -> res_ty
543 -- Where test_ty is, for example, Bool
544 test_ty <- newFlexiTyVarTy liftedTypeKind
545 ; rhs_ty <- newFlexiTyVarTy liftedTypeKind
546 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
547 ; rhs' <- tcMonoExpr rhs test_ty
548 ; guard_op' <- tcSyntaxOp MCompOrigin guard_op
549 (mkFunTy test_ty rhs_ty)
550 ; then_op' <- tcSyntaxOp MCompOrigin then_op
551 (mkFunTys [rhs_ty, new_res_ty] res_ty)
552 ; thing <- thing_inside new_res_ty
553 ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
555 -- Transform statements.
557 -- [ body | stmts, then f ] -> f :: forall a. m a -> m a
558 -- [ body | stmts, then f by e ] -> f :: forall a. (a -> t) -> m a -> m a
560 tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) res_ty thing_inside
561 = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
562 ; m1_ty <- newFlexiTyVarTy star_star_kind
563 ; m2_ty <- newFlexiTyVarTy star_star_kind
564 ; n_ty <- newFlexiTyVarTy star_star_kind
565 ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
566 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
567 ; let m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
569 -- 'stmts' returns a result of type (m1_ty tuple_ty),
570 -- typically something like [(Int,Bool,Int)]
571 -- We don't know what tuple_ty is yet, so we use a variable
572 ; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
573 tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
574 { (usingExpr', maybeByExpr') <-
577 -- We must validate that usingExpr :: forall a. m a -> m a
578 let using_ty = mkForAllTy alphaTyVar $
579 (m_ty `mkAppTy` alphaTy)
581 (m_ty `mkAppTy` alphaTy)
582 usingExpr' <- tcPolyExpr usingExpr using_ty
583 return (usingExpr', Nothing)
585 -- We must infer a type such that e :: t and then check that
586 -- usingExpr :: forall a. (a -> t) -> m a -> m a
587 (byExpr', tTy) <- tcInferRhoNC byExpr
588 let using_ty = mkForAllTy alphaTyVar $
589 (alphaTy `mkFunTy` tTy)
591 (m_ty `mkAppTy` alphaTy)
593 (m_ty `mkAppTy` alphaTy)
594 usingExpr' <- tcPolyExpr usingExpr using_ty
595 return (usingExpr', Just byExpr')
597 ; bndr_ids <- tcLookupLocalIds binders
599 -- `return` and `>>=` are used to pass around/modify our
600 -- binders, so we know their types:
602 -- return :: (a,b,c,..) -> m (a,b,c,..)
603 -- (>>=) :: m (a,b,c,..)
604 -- -> ( (a,b,c,..) -> m (a,b,c,..) )
607 ; let bndr_ty = mkBigCoreVarTupTy bndr_ids
608 m_bndr_ty = m_ty `mkAppTy` bndr_ty
610 ; return_op' <- tcSyntaxOp MCompOrigin return_op
611 (bndr_ty `mkFunTy` m_bndr_ty)
613 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
614 m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` res_ty)
617 -- Unify types of the inner comprehension and the binders type
618 ; _ <- unifyType res_ty' m_bndr_ty
620 -- Typecheck the `thing` with out old type (which is the type
621 -- of the final result of our comprehension)
622 ; thing <- thing_inside res_ty
624 ; return (bndr_ids, usingExpr', maybeByExpr', return_op', bind_op', thing) }
626 ; return (TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op', thing) }
628 -- Grouping statements
630 -- [ body | stmts, then group by e ]
632 -- [ body | stmts, then group by e using f ]
634 -- f :: forall a. (a -> t) -> m a -> m (m a)
635 -- [ body | stmts, then group using f ]
636 -- -> f :: forall a. m a -> m (m a)
638 tcMcStmt ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap
639 , grpS_by = by, grpS_using = using, grpS_explicit = explicit
640 , grpS_ret = return_op, grpS_bind = bind_op
641 , grpS_fmap = fmap_op }) res_ty thing_inside
642 = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
643 ; m1_ty <- newFlexiTyVarTy star_star_kind
644 ; m2_ty <- newFlexiTyVarTy star_star_kind
645 ; n_ty <- newFlexiTyVarTy star_star_kind
646 ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
647 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
648 ; let (bndr_names, n_bndr_names) = unzip bindersMap
649 m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
651 -- 'stmts' returns a result of type (m1_ty tuple_ty),
652 -- typically something like [(Int,Bool,Int)]
653 -- We don't know what tuple_ty is yet, so we use a variable
654 ; (stmts', (bndr_ids, by_e_ty, return_op')) <-
655 tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
656 { by_e_ty <- case by of
657 Nothing -> return Nothing
658 Just e -> do { e_ty <- tcInferRhoNC e; return (Just e_ty) }
660 -- Find the Ids (and hence types) of all old binders
661 ; bndr_ids <- tcLookupLocalIds bndr_names
663 -- 'return' is only used for the binders, so we know its type.
665 -- return :: (a,b,c,..) -> m (a,b,c,..)
666 ; return_op' <- tcSyntaxOp MCompOrigin return_op $
667 (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
669 ; return (bndr_ids, by_e_ty, return_op') }
673 ; let tup_ty = mkBigCoreVarTupTy bndr_ids -- (a,b,c)
674 using_arg_ty = m1_ty `mkAppTy` tup_ty -- m1 (a,b,c)
675 n_tup_ty = n_ty `mkAppTy` tup_ty -- n (a,b,c)
676 using_res_ty = m2_ty `mkAppTy` n_tup_ty -- m2 (n (a,b,c))
677 using_fun_ty = using_arg_ty `mkFunTy` using_arg_ty
679 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
680 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
682 --------------- Typecheck the 'bind' function -------------
683 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
684 using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty)
687 --------------- Typecheck the 'using' function -------------
688 ; let poly_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy`
689 (m2_ty `mkAppTy` (n_ty `mkAppTy` alphaTy))
690 using_poly_ty = case by_e_ty of
691 Nothing -> mkForAllTy alphaTyVar poly_fun_ty
692 -- using :: forall a. m1 a -> m2 (n a)
694 Just (_,t_ty) -> mkForAllTy alphaTyVar $
695 (alphaTy `mkFunTy` t_ty) `mkFunTy` poly_fun_ty
696 -- using :: forall a. (a->t) -> m1 a -> m2 (n a)
699 ; using' <- tcPolyExpr using using_poly_ty
700 ; coi <- unifyType (applyTy using_poly_ty tup_ty)
702 Nothing -> using_fun_ty
703 Just (_,t_ty) -> (tup_ty `mkFunTy` t_ty) `mkFunTy` using_fun_ty)
704 ; let final_using = fmap (mkHsWrapCoI coi . HsWrap (WpTyApp tup_ty)) using'
706 --------------- Typecheck the 'fmap' function -------------
707 ; fmap_op' <- fmap unLoc . tcPolyExpr (noLoc fmap_op) $
708 mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
709 (alphaTy `mkFunTy` betaTy)
710 `mkFunTy` (n_ty `mkAppTy` alphaTy)
711 `mkFunTy` (n_ty `mkAppTy` betaTy)
713 ; let mk_n_bndr :: Name -> TcId -> TcId
714 mk_n_bndr n_bndr_name bndr_id
715 = mkLocalId n_bndr_name (n_ty `mkAppTy` idType bndr_id)
717 -- Ensure that every old binder of type `b` is linked up with its
718 -- new binder which should have type `n b`
719 -- See Note [GroupStmt binder map] in HsExpr
720 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
721 bindersMap' = bndr_ids `zip` n_bndr_ids
723 -- Type check the thing in the environment with these new binders and
725 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
727 ; return (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
728 , grpS_by = fmap fst by_e_ty, grpS_using = final_using
729 , grpS_ret = return_op', grpS_bind = bind_op'
730 , grpS_fmap = fmap_op', grpS_explicit = explicit }, thing) }
732 -- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
735 -- Note: The `mzip` function will get typechecked via:
737 -- ParStmt [st1::t1, st2::t2, st3::t3]
740 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
741 -- -> m (st1, (st2, st3))
743 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
744 = do { (_,(m_ty,_)) <- matchExpectedAppTy res_ty
745 -- ToDo: what if the coercion isn't the identity?
747 ; (pairs', thing) <- loop m_ty bndr_stmts_s
749 ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
750 (m_ty `mkAppTy` alphaTy)
752 (m_ty `mkAppTy` betaTy)
754 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
755 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
758 ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
759 tuple_ty = mk_tuple_ty tys
761 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
762 (m_ty `mkAppTy` tuple_ty)
764 (tuple_ty `mkFunTy` res_ty)
768 ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
769 mkForAllTy alphaTyVar $
770 alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
772 ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
774 where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
776 -- loop :: Type -- m_ty
777 -- -> [([LStmt Name], [Name])]
778 -- -> TcM ([([LStmt TcId], [TcId])], thing)
779 loop _ [] = do { thing <- thing_inside res_ty
780 ; return ([], thing) } -- matching in the branches
782 loop m_ty ((stmts, names) : pairs)
783 = do { -- type dummy since we don't know all binder types yet
784 ty_dummy <- newFlexiTyVarTy liftedTypeKind
785 ; (stmts', (ids, pairs', thing))
786 <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
787 do { ids <- tcLookupLocalIds names
788 ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids)
789 ; (pairs', thing) <- loop m_ty pairs
790 ; return (ids, pairs', thing) }
791 ; return ( (stmts', ids) : pairs', thing ) }
794 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
796 --------------------------------
798 -- The main excitement here is dealing with rebindable syntax
800 tcDoStmt :: TcStmtChecker
802 tcDoStmt _ (LastStmt body _) res_ty thing_inside
803 = do { body' <- tcMonoExprNC body res_ty
804 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
805 ; return (LastStmt body' noSyntaxExpr, thing) }
807 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
808 = do { -- Deal with rebindable syntax:
809 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
810 -- This level of generality is needed for using do-notation
811 -- in full generality; see Trac #1537
813 -- I'd like to put this *after* the tcSyntaxOp
814 -- (see Note [Treat rebindable syntax first], but that breaks
815 -- the rigidity info for GADTs. When we move to the new story
816 -- for GADTs, we can move this after tcSyntaxOp
817 rhs_ty <- newFlexiTyVarTy liftedTypeKind
818 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
819 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
820 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
821 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
823 -- If (but only if) the pattern can fail,
824 -- typecheck the 'fail' operator
825 ; fail_op' <- if isIrrefutableHsPat pat
826 then return noSyntaxExpr
827 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
829 ; rhs' <- tcMonoExprNC rhs rhs_ty
830 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
831 thing_inside new_res_ty
833 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
836 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
837 = do { -- Deal with rebindable syntax;
838 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
839 -- See also Note [Treat rebindable syntax first]
840 rhs_ty <- newFlexiTyVarTy liftedTypeKind
841 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
842 ; then_op' <- tcSyntaxOp DoOrigin then_op
843 (mkFunTys [rhs_ty, new_res_ty] res_ty)
845 ; rhs' <- tcMonoExprNC rhs rhs_ty
846 ; thing <- thing_inside new_res_ty
847 ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
849 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
850 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
851 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
853 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
854 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
855 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
856 tup_ty = mkBoxedTupleTy tup_elt_tys
858 ; tcExtendIdEnv tup_ids $ do
859 { stmts_ty <- newFlexiTyVarTy liftedTypeKind
860 ; (stmts', (ret_op', tup_rets))
861 <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
862 do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
863 -- Unify the types of the "final" Ids (which may
864 -- be polymorphic) with those of "knot-tied" Ids
865 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
866 ; return (ret_op', tup_rets) }
868 ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
869 ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
870 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
872 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
873 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
874 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
876 ; thing <- thing_inside new_res_ty
877 -- ; lie_binds <- bindLocalMethods lie tup_ids
879 ; let rec_ids = takeList rec_names tup_ids
880 ; later_ids <- tcLookupLocalIds later_names
881 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
882 ppr later_ids <+> ppr (map idType later_ids)]
883 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
884 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
885 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
886 , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
890 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
893 Note [Treat rebindable syntax first]
894 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
896 do { bar; ... } :: IO ()
897 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
898 pushing info from the context into the RHS. To do this, we check the
899 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
900 Otherwise the error shows up when cheking the rebindable syntax, and
901 the expected/inferred stuff is back to front (see Trac #3613).
904 --------------------------------
906 -- The distinctive features here are
908 -- (b) no rebindable syntax
910 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
912 -- Used only by TcArrows... should be gotten rid of
913 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
914 = do { (rhs', pat_ty) <- tc_rhs rhs
915 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
917 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
919 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside
920 = do { (rhs', elt_ty) <- tc_rhs rhs
921 ; thing <- thing_inside res_ty
922 ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
924 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
925 , recS_rec_ids = recNames }) res_ty thing_inside
926 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
927 ; let rec_ids = zipWith mkLocalId recNames rec_tys
928 ; tcExtendIdEnv rec_ids $ do
929 { (stmts', (later_ids, rec_rets))
930 <- tcStmtsAndThen ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
931 -- ToDo: res_ty not really right
932 do { rec_rets <- zipWithM tcCheckId recNames rec_tys
933 ; later_ids <- tcLookupLocalIds laterNames
934 ; return (later_ids, rec_rets) }
936 ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
937 -- NB: The rec_ids for the recursive things
938 -- already scope over this part. This binding may shadow
939 -- some of them with polymorphic things with the same Name
940 -- (see note [RecStmt] in HsExpr)
942 ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
943 , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
944 , recS_ret_ty = res_ty }, thing)
947 tcMDoStmt _ _ stmt _ _
948 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
952 %************************************************************************
954 \subsection{Errors and contexts}
956 %************************************************************************
958 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
959 number of args are used in each equation.
962 checkArgs :: Name -> MatchGroup Name -> TcM ()
963 checkArgs fun (MatchGroup (match1:matches) _)
964 | null bad_matches = return ()
966 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
967 ptext (sLit "have different numbers of arguments"),
968 nest 2 (ppr (getLoc match1)),
969 nest 2 (ppr (getLoc (head bad_matches)))])
971 n_args1 = args_in_match match1
972 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
974 args_in_match :: LMatch Name -> Int
975 args_in_match (L _ (Match pats _ _)) = length pats
976 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty