2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcMatches: Typecheck some @Matches@
9 {-# OPTIONS_GHC -w #-} -- debugging
10 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
11 TcMatchCtxt(..), TcStmtChecker,
12 tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
16 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
17 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
33 import Coercion ( isIdentityCoI, mkSymCoI )
39 -- Create chunkified tuple tybes for monad comprehensions
44 #include "HsVersions.h"
47 %************************************************************************
49 \subsection{tcMatchesFun, tcMatchesCase}
51 %************************************************************************
53 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
54 @FunMonoBind@. The second argument is the name of the function, which
55 is used in error messages. It checks that all the equations have the
56 same number of arguments before using @tcMatches@ to do the work.
58 Note [Polymorphic expected type for tcMatchesFun]
59 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60 tcMatchesFun may be given a *sigma* (polymorphic) type
61 so it must be prepared to use tcGen to skolemise it.
62 See Note [sig_tau may be polymorphic] in TcPat.
65 tcMatchesFun :: Name -> Bool
67 -> TcSigmaType -- Expected type of function
68 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
69 tcMatchesFun fun_name inf matches exp_ty
70 = do { -- Check that they all have the same no of arguments
71 -- Location is in the monad, set the caller so that
72 -- any inter-equation error messages get some vaguely
73 -- sensible location. Note: we have to do this odd
74 -- ann-grabbing, because we don't always have annotations in
75 -- hand when we call tcMatchesFun...
76 traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
77 ; checkArgs fun_name matches
79 ; (wrap_gen, (wrap_fun, group))
80 <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
81 -- Note [Polymorphic expected type for tcMatchesFun]
82 matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
83 tcMatches match_ctxt pat_tys rhs_ty matches
84 ; return (wrap_gen <.> wrap_fun, group) }
86 arity = matchGroupArity matches
87 herald = ptext (sLit "The equation(s) for")
88 <+> quotes (ppr fun_name) <+> ptext (sLit "have")
89 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
92 @tcMatchesCase@ doesn't do the argument-count check because the
93 parser guarantees that each equation has exactly one argument.
96 tcMatchesCase :: TcMatchCtxt -- Case context
97 -> TcRhoType -- Type of scrutinee
98 -> MatchGroup Name -- The case alternatives
99 -> TcRhoType -- Type of whole case expressions
100 -> TcM (MatchGroup TcId) -- Translated alternatives
102 tcMatchesCase ctxt scrut_ty matches res_ty
103 | isEmptyMatchGroup matches -- Allow empty case expressions
104 = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty))
107 = tcMatches ctxt [scrut_ty] res_ty matches
109 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
110 tcMatchLambda match res_ty
111 = matchFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
112 tcMatches match_ctxt pat_tys rhs_ty match
114 n_pats = matchGroupArity match
115 herald = sep [ ptext (sLit "The lambda expression")
116 <+> quotes (pprSetDepth (PartWay 1) $
117 pprMatches (LambdaExpr :: HsMatchContext Name) match),
118 -- The pprSetDepth makes the abstraction print briefly
120 match_ctxt = MC { mc_what = LambdaExpr,
124 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
127 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
128 -- Used for pattern bindings
129 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
131 match_ctxt = MC { mc_what = PatBindRhs,
138 :: SDoc -- See Note [Herald for matchExpecteFunTys] in TcUnify
141 -> ([TcSigmaType] -> TcRhoType -> TcM a)
142 -> TcM (HsWrapper, a)
144 -- Written in CPS style for historical reasons;
145 -- could probably be un-CPSd, like matchExpectedTyConApp
147 matchFunTys herald arity res_ty thing_inside
148 = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
149 ; res <- thing_inside pat_tys res_ty
150 ; return (coiToHsWrapper (mkSymCoI coi), res) }
153 %************************************************************************
157 %************************************************************************
160 tcMatches :: TcMatchCtxt
161 -> [TcSigmaType] -- Expected pattern types
162 -> TcRhoType -- Expected result-type of the Match.
164 -> TcM (MatchGroup TcId)
166 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
167 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
168 mc_body :: LHsExpr Name -- Type checker for a body of
171 -> TcM (LHsExpr TcId) }
173 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
174 = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
175 do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
176 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
179 tcMatch :: TcMatchCtxt
180 -> [TcSigmaType] -- Expected pattern types
181 -> TcRhoType -- Expected result-type of the Match.
185 tcMatch ctxt pat_tys rhs_ty match
186 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
188 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
189 = add_match_ctxt match $
190 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
191 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
192 ; return (Match pats' Nothing grhss') }
194 tc_grhss ctxt Nothing grhss rhs_ty
195 = tcGRHSs ctxt grhss rhs_ty -- No result signature
197 -- Result type sigs are no longer supported
198 tc_grhss _ (Just {}) _ _
199 = panic "tc_ghrss" -- Rejected by renamer
201 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
202 -- so we don't want to add "In the lambda abstraction \x->e"
203 add_match_ctxt match thing_inside
204 = case mc_what ctxt of
205 LambdaExpr -> thing_inside
206 m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
209 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
212 -- Notice that we pass in the full res_ty, so that we get
213 -- good inference from simple things like
214 -- f = \(x::forall a.a->a) -> <stuff>
215 -- We used to force it to be a monotype when there was more than one guard
216 -- but we don't need to do that any more
218 tcGRHSs ctxt (GRHSs grhss binds) res_ty
219 = do { (binds', grhss') <- tcLocalBinds binds $
220 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
222 ; return (GRHSs grhss' binds') }
225 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
227 tcGRHS ctxt res_ty (GRHS guards rhs)
228 = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
230 ; return (GRHS guards' rhs') }
232 stmt_ctxt = PatGuard (mc_what ctxt)
236 %************************************************************************
238 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
240 %************************************************************************
243 tcDoStmts :: HsStmtContext Name
246 -> TcM (HsExpr TcId) -- Returns a HsDo
247 tcDoStmts ListComp stmts res_ty
248 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
249 ; let list_ty = mkListTy elt_ty
250 ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
251 ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) }
253 tcDoStmts PArrComp stmts res_ty
254 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
255 ; let parr_ty = mkPArrTy elt_ty
256 ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
257 ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) }
259 tcDoStmts DoExpr stmts res_ty
260 = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
261 ; return (HsDo DoExpr stmts' res_ty) }
263 tcDoStmts MDoExpr stmts res_ty
264 = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
265 ; return (HsDo MDoExpr stmts' res_ty) }
267 tcDoStmts MonadComp stmts res_ty
268 = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
269 ; return (HsDo MonadComp stmts' res_ty) }
271 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
273 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
275 = do { traceTc "tcBody" (ppr res_ty)
276 ; body' <- tcMonoExpr body res_ty
282 %************************************************************************
286 %************************************************************************
290 = forall thing. HsStmtContext Name
292 -> TcRhoType -- Result type for comprehension
293 -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt
294 -> TcM (Stmt TcId, thing)
296 tcStmts :: HsStmtContext Name
297 -> TcStmtChecker -- NB: higher-rank type
301 tcStmts ctxt stmt_chk stmts res_ty
302 = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
306 tcStmtsAndThen :: HsStmtContext Name
307 -> TcStmtChecker -- NB: higher-rank type
310 -> (TcRhoType -> TcM thing)
311 -> TcM ([LStmt TcId], thing)
313 -- Note the higher-rank type. stmt_chk is applied at different
314 -- types in the equations for tcStmts
316 tcStmtsAndThen _ _ [] res_ty thing_inside
317 = do { thing <- thing_inside res_ty
318 ; return ([], thing) }
320 -- LetStmts are handled uniformly, regardless of context
321 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
322 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
323 tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
324 ; return (L loc (LetStmt binds') : stmts', thing) }
326 -- For the vanilla case, handle the location-setting part
327 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
328 = do { (stmt', (stmts', thing)) <-
330 addErrCtxt (pprStmtInCtxt ctxt stmt) $
331 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
333 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
335 ; return (L loc stmt' : stmts', thing) }
337 ---------------------------------------------------
339 ---------------------------------------------------
341 tcGuardStmt :: TcStmtChecker
342 tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
343 = do { guard' <- tcMonoExpr guard boolTy
344 ; thing <- thing_inside res_ty
345 ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
347 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
348 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
349 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $
351 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
353 tcGuardStmt _ stmt _ _
354 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
357 ---------------------------------------------------
358 -- List comprehensions and PArrays
359 -- (no rebindable syntax)
360 ---------------------------------------------------
362 -- Dealt with separately, rather than by tcMcStmt, because
363 -- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
364 -- b) We have special desugaring rules for list comprehensions,
365 -- which avoid creating intermediate lists. They in turn
366 -- assume that the bind/return operations are the regular
367 -- polymorphic ones, and in particular don't have any
368 -- coercion matching stuff in them. It's hard to avoid the
369 -- potential for non-trivial coercions in tcMcStmt
371 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
374 tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
375 = do { body' <- tcMonoExprNC body elt_ty
376 ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
377 ; return (LastStmt body' noSyntaxExpr, thing) }
379 -- A generator, pat <- rhs
380 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
381 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
382 ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
383 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
385 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
388 tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
389 = do { rhs' <- tcMonoExpr rhs boolTy
390 ; thing <- thing_inside elt_ty
391 ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
393 -- ParStmt: See notes with tcMcStmt
394 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
395 = do { (pairs', thing) <- loop bndr_stmts_s
396 ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
398 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
399 loop [] = do { thing <- thing_inside elt_ty
400 ; return ([], thing) } -- matching in the branches
402 loop ((stmts, names) : pairs)
403 = do { (stmts', (ids, pairs', thing))
404 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
405 do { ids <- tcLookupLocalIds names
406 ; (pairs', thing) <- loop pairs
407 ; return (ids, pairs', thing) }
408 ; return ( (stmts', ids) : pairs', thing ) }
410 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
411 , trS_bndrs = bindersMap
412 , trS_by = by, trS_using = using }) elt_ty thing_inside
413 = do { let (bndr_names, n_bndr_names) = unzip bindersMap
414 unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
415 -- The inner 'stmts' lack a LastStmt, so the element type
416 -- passed in to tcStmtsAndThen is never looked at
417 ; (stmts', (bndr_ids, by'))
418 <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
420 Nothing -> return Nothing
421 Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) }
422 ; bndr_ids <- tcLookupLocalIds bndr_names
423 ; return (bndr_ids, by') }
425 ; let m_app ty = mkTyConApp m_tc [ty]
427 --------------- Typecheck the 'using' function -------------
428 -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
429 -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
431 -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
432 ; let n_app = case form of
433 ThenForm -> (\ty -> ty)
436 by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
437 by_arrow = case by' of
439 Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
441 tup_ty = mkBigCoreVarTupTy bndr_ids
442 poly_arg_ty = m_app alphaTy
443 poly_res_ty = m_app (n_app alphaTy)
444 using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
445 poly_arg_ty `mkFunTy` poly_res_ty
447 ; using' <- tcPolyExpr using using_poly_ty
448 ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
450 -- 'stmts' returns a result of type (m1_ty tuple_ty),
451 -- typically something like [(Int,Bool,Int)]
452 -- We don't know what tuple_ty is yet, so we use a variable
453 ; let mk_n_bndr :: Name -> TcId -> TcId
454 mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
456 -- Ensure that every old binder of type `b` is linked up with its
457 -- new binder which should have type `n b`
458 -- See Note [GroupStmt binder map] in HsExpr
459 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
460 bindersMap' = bndr_ids `zip` n_bndr_ids
462 -- Type check the thing in the environment with
463 -- these new binders and return the result
464 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
466 ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
467 , trS_by = fmap fst by', trS_using = final_using
468 , trS_form = form }, thing) }
470 tcLcStmt _ _ stmt _ _
471 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
474 ---------------------------------------------------
475 -- Monad comprehensions
476 -- (supports rebindable syntax)
477 ---------------------------------------------------
479 tcMcStmt :: TcStmtChecker
481 tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
482 = do { a_ty <- newFlexiTyVarTy liftedTypeKind
483 ; return_op' <- tcSyntaxOp MCompOrigin return_op
484 (a_ty `mkFunTy` res_ty)
485 ; body' <- tcMonoExprNC body a_ty
486 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
487 ; return (LastStmt body' return_op', thing) }
489 -- Generators for monad comprehensions ( pat <- rhs )
491 -- [ body | q <- gen ] -> gen :: m a
495 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
496 = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
497 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
498 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
500 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
501 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
502 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
504 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
505 ; fail_op' <- if isIrrefutableHsPat pat
506 then return noSyntaxExpr
507 else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
509 ; rhs' <- tcMonoExprNC rhs rhs_ty
510 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
511 thing_inside new_res_ty
513 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
515 -- Boolean expressions.
517 -- [ body | stmts, expr ] -> expr :: m Bool
519 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
520 = do { -- Deal with rebindable syntax:
521 -- guard_op :: test_ty -> rhs_ty
522 -- then_op :: rhs_ty -> new_res_ty -> res_ty
523 -- Where test_ty is, for example, Bool
524 test_ty <- newFlexiTyVarTy liftedTypeKind
525 ; rhs_ty <- newFlexiTyVarTy liftedTypeKind
526 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
527 ; rhs' <- tcMonoExpr rhs test_ty
528 ; guard_op' <- tcSyntaxOp MCompOrigin guard_op
529 (mkFunTy test_ty rhs_ty)
530 ; then_op' <- tcSyntaxOp MCompOrigin then_op
531 (mkFunTys [rhs_ty, new_res_ty] res_ty)
532 ; thing <- thing_inside new_res_ty
533 ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
535 -- Grouping statements
537 -- [ body | stmts, then group by e ]
539 -- [ body | stmts, then group by e using f ]
541 -- f :: forall a. (a -> t) -> m a -> m (m a)
542 -- [ body | stmts, then group using f ]
543 -- -> f :: forall a. m a -> m (m a)
545 -- We type [ body | (stmts, group by e using f), ... ]
546 -- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
548 -- We type the functions as follows:
549 -- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
550 -- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
551 -- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
552 -- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
554 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
555 , trS_by = by, trS_using = using, trS_form = form
556 , trS_ret = return_op, trS_bind = bind_op
557 , trS_fmap = fmap_op }) res_ty thing_inside
558 = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
559 ; m1_ty <- newFlexiTyVarTy star_star_kind
560 ; m2_ty <- newFlexiTyVarTy star_star_kind
561 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
562 ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
564 -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
565 ; n_app <- case form of
566 ThenForm -> return (\ty -> ty)
567 _ -> do { n_ty <- newFlexiTyVarTy star_star_kind
568 ; return (n_ty `mkAppTy`) }
569 ; let by_arrow :: Type -> Type
570 -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
571 -- or res ('by' absent)
572 by_arrow = case by of
573 Nothing -> \res -> res
574 Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
576 poly_arg_ty = m1_ty `mkAppTy` alphaTy
577 using_arg_ty = m1_ty `mkAppTy` tup_ty
578 poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
579 using_res_ty = m2_ty `mkAppTy` n_app tup_ty
580 using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
581 poly_arg_ty `mkFunTy` poly_res_ty
583 -- 'stmts' returns a result of type (m1_ty tuple_ty),
584 -- typically something like [(Int,Bool,Int)]
585 -- We don't know what tuple_ty is yet, so we use a variable
586 ; let (bndr_names, n_bndr_names) = unzip bindersMap
587 ; (stmts', (bndr_ids, by', return_op')) <-
588 tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
590 Nothing -> return Nothing
591 Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
593 -- Find the Ids (and hence types) of all old binders
594 ; bndr_ids <- tcLookupLocalIds bndr_names
596 -- 'return' is only used for the binders, so we know its type.
597 -- return :: (a,b,c,..) -> m (a,b,c,..)
598 ; return_op' <- tcSyntaxOp MCompOrigin return_op $
599 (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
601 ; return (bndr_ids, by', return_op') }
603 --------------- Typecheck the 'bind' function -------------
604 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
605 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
606 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
607 using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
610 --------------- Typecheck the 'fmap' function -------------
611 ; fmap_op' <- case form of
612 ThenForm -> return noSyntaxExpr
613 _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
614 mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
615 (alphaTy `mkFunTy` betaTy)
616 `mkFunTy` (n_app alphaTy)
617 `mkFunTy` (n_app betaTy)
619 --------------- Typecheck the 'using' function -------------
620 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
622 ; using' <- tcPolyExpr using using_poly_ty
623 ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
625 --------------- Bulding the bindersMap ----------------
626 ; let mk_n_bndr :: Name -> TcId -> TcId
627 mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
629 -- Ensure that every old binder of type `b` is linked up with its
630 -- new binder which should have type `n b`
631 -- See Note [GroupStmt binder map] in HsExpr
632 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
633 bindersMap' = bndr_ids `zip` n_bndr_ids
635 -- Type check the thing in the environment with
636 -- these new binders and return the result
637 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty)
639 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
640 , trS_by = by', trS_using = final_using
641 , trS_ret = return_op', trS_bind = bind_op'
642 , trS_fmap = fmap_op', trS_form = form }, thing) }
644 -- A parallel set of comprehensions
645 -- [ (g x, h x) | ... ; let g v = ...
646 -- | ... ; let h v = ... ]
648 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
649 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
650 -- Similarly if we had an existential pattern match:
652 -- data T = forall a. Show a => C a
654 -- [ (show x, show y) | ... ; C x <- ...
655 -- | ... ; C y <- ... ]
657 -- Then we need the LIE from (show x, show y) to be simplified against
658 -- the bindings for x and y.
660 -- It's difficult to do this in parallel, so we rely on the renamer to
661 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
662 -- So the binders of the first parallel group will be in scope in the second
663 -- group. But that's fine; there's no shadowing to worry about.
665 -- Note: The `mzip` function will get typechecked via:
667 -- ParStmt [st1::t1, st2::t2, st3::t3]
670 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
671 -- -> m (st1, (st2, st3))
673 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
674 = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
675 ; m_ty <- newFlexiTyVarTy star_star_kind
677 ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
678 (m_ty `mkAppTy` alphaTy)
680 (m_ty `mkAppTy` betaTy)
682 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
683 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
685 ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
686 mkForAllTy alphaTyVar $
687 alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
689 ; (pairs', thing) <- loop m_ty bndr_stmts_s
692 ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
693 tuple_ty = mk_tuple_ty tys
695 ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
696 (m_ty `mkAppTy` tuple_ty)
697 `mkFunTy` (tuple_ty `mkFunTy` res_ty)
700 ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
703 mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
705 -- loop :: Type -- m_ty
706 -- -> [([LStmt Name], [Name])]
707 -- -> TcM ([([LStmt TcId], [TcId])], thing)
708 loop _ [] = do { thing <- thing_inside res_ty
709 ; return ([], thing) } -- matching in the branches
711 loop m_ty ((stmts, names) : pairs)
712 = do { -- type dummy since we don't know all binder types yet
713 ty_dummy <- newFlexiTyVarTy liftedTypeKind
714 ; (stmts', (ids, pairs', thing))
715 <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
716 do { ids <- tcLookupLocalIds names
717 ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
719 ; check_same m_tup_ty res_ty'
720 ; check_same m_tup_ty ty_dummy
722 ; (pairs', thing) <- loop m_ty pairs
723 ; return (ids, pairs', thing) }
724 ; return ( (stmts', ids) : pairs', thing ) }
726 -- Check that the types match up.
727 -- This is a grevious hack. They always *will* match
728 -- If (>>=) and (>>) are polymorpic in the return type,
729 -- but we don't have any good way to incorporate the coercion
730 -- so for now we just check that it's the identity
731 check_same actual expected
732 = do { coi <- unifyType actual expected
733 ; unless (isIdentityCoI coi) $
734 failWithMisMatch [UnifyOrigin { uo_expected = expected
735 , uo_actual = actual }] }
738 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
741 ---------------------------------------------------
743 -- (supports rebindable syntax)
744 ---------------------------------------------------
746 tcDoStmt :: TcStmtChecker
748 tcDoStmt _ (LastStmt body _) res_ty thing_inside
749 = do { body' <- tcMonoExprNC body res_ty
750 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
751 ; return (LastStmt body' noSyntaxExpr, thing) }
753 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
754 = do { -- Deal with rebindable syntax:
755 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
756 -- This level of generality is needed for using do-notation
757 -- in full generality; see Trac #1537
759 -- I'd like to put this *after* the tcSyntaxOp
760 -- (see Note [Treat rebindable syntax first], but that breaks
761 -- the rigidity info for GADTs. When we move to the new story
762 -- for GADTs, we can move this after tcSyntaxOp
763 rhs_ty <- newFlexiTyVarTy liftedTypeKind
764 ; pat_ty <- newFlexiTyVarTy liftedTypeKind
765 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
766 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
767 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
769 -- If (but only if) the pattern can fail,
770 -- typecheck the 'fail' operator
771 ; fail_op' <- if isIrrefutableHsPat pat
772 then return noSyntaxExpr
773 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
775 ; rhs' <- tcMonoExprNC rhs rhs_ty
776 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
777 thing_inside new_res_ty
779 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
782 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
783 = do { -- Deal with rebindable syntax;
784 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
785 -- See also Note [Treat rebindable syntax first]
786 rhs_ty <- newFlexiTyVarTy liftedTypeKind
787 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
788 ; then_op' <- tcSyntaxOp DoOrigin then_op
789 (mkFunTys [rhs_ty, new_res_ty] res_ty)
791 ; rhs' <- tcMonoExprNC rhs rhs_ty
792 ; thing <- thing_inside new_res_ty
793 ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
795 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
796 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
797 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
799 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
800 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
801 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
802 tup_ty = mkBoxedTupleTy tup_elt_tys
804 ; tcExtendIdEnv tup_ids $ do
805 { stmts_ty <- newFlexiTyVarTy liftedTypeKind
806 ; (stmts', (ret_op', tup_rets))
807 <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
808 do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
809 -- Unify the types of the "final" Ids (which may
810 -- be polymorphic) with those of "knot-tied" Ids
811 ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
812 ; return (ret_op', tup_rets) }
814 ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
815 ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
816 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
818 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
819 ; bind_op' <- tcSyntaxOp DoOrigin bind_op
820 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
822 ; thing <- thing_inside new_res_ty
824 ; let rec_ids = takeList rec_names tup_ids
825 ; later_ids <- tcLookupLocalIds later_names
826 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
827 ppr later_ids <+> ppr (map idType later_ids)]
828 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
829 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
830 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
831 , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
835 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
838 Note [Treat rebindable syntax first]
839 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
841 do { bar; ... } :: IO ()
842 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
843 pushing info from the context into the RHS. To do this, we check the
844 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
845 Otherwise the error shows up when cheking the rebindable syntax, and
846 the expected/inferred stuff is back to front (see Trac #3613).
849 %************************************************************************
851 \subsection{Errors and contexts}
853 %************************************************************************
855 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
856 number of args are used in each equation.
859 checkArgs :: Name -> MatchGroup Name -> TcM ()
860 checkArgs fun (MatchGroup (match1:matches) _)
861 | null bad_matches = return ()
863 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
864 ptext (sLit "have different numbers of arguments"),
865 nest 2 (ppr (getLoc match1)),
866 nest 2 (ppr (getLoc (head bad_matches)))])
868 n_args1 = args_in_match match1
869 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
871 args_in_match :: LMatch Name -> Int
872 args_in_match (L _ (Match pats _ _)) = length pats
873 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty