Break up TcRnTypes, among other modules.
[ghc.git] / compiler / typecheck / TcMatches.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 TcMatches: Typecheck some @Matches@
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE RankNTypes #-}
11 {-# LANGUAGE MultiWayIf #-}
12 {-# LANGUAGE TupleSections #-}
13 {-# LANGUAGE FlexibleContexts #-}
14 {-# LANGUAGE TypeFamilies #-}
15
16 module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
17 TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
18 tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
19 tcDoStmt, tcGuardStmt
20 ) where
21
22 import GhcPrelude
23
24 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho
25 , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
26
27 import BasicTypes (LexicalFixity(..))
28 import GHC.Hs
29 import TcRnMonad
30 import TcEnv
31 import TcPat
32 import TcMType
33 import TcType
34 import TcBinds
35 import TcUnify
36 import TcOrigin
37 import Name
38 import TysWiredIn
39 import Id
40 import TyCon
41 import TysPrim
42 import TcEvidence
43 import Outputable
44 import Util
45 import SrcLoc
46
47 -- Create chunkified tuple tybes for monad comprehensions
48 import MkCore
49
50 import Control.Monad
51 import Control.Arrow ( second )
52
53 #include "HsVersions.h"
54
55 {-
56 ************************************************************************
57 * *
58 \subsection{tcMatchesFun, tcMatchesCase}
59 * *
60 ************************************************************************
61
62 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
63 @FunMonoBind@. The second argument is the name of the function, which
64 is used in error messages. It checks that all the equations have the
65 same number of arguments before using @tcMatches@ to do the work.
66
67 Note [Polymorphic expected type for tcMatchesFun]
68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
69 tcMatchesFun may be given a *sigma* (polymorphic) type
70 so it must be prepared to use tcSkolemise to skolemise it.
71 See Note [sig_tau may be polymorphic] in TcPat.
72 -}
73
74 tcMatchesFun :: Located Name
75 -> MatchGroup GhcRn (LHsExpr GhcRn)
76 -> ExpSigmaType -- Expected type of function
77 -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
78 -- Returns type of body
79 tcMatchesFun fn@(L _ fun_name) matches exp_ty
80 = do { -- Check that they all have the same no of arguments
81 -- Location is in the monad, set the caller so that
82 -- any inter-equation error messages get some vaguely
83 -- sensible location. Note: we have to do this odd
84 -- ann-grabbing, because we don't always have annotations in
85 -- hand when we call tcMatchesFun...
86 traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
87 ; checkArgs fun_name matches
88
89 ; (wrap_gen, (wrap_fun, group))
90 <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
91 -- Note [Polymorphic expected type for tcMatchesFun]
92 do { (matches', wrap_fun)
93 <- matchExpectedFunTys herald arity exp_rho $
94 \ pat_tys rhs_ty ->
95 tcMatches match_ctxt pat_tys rhs_ty matches
96 ; return (wrap_fun, matches') }
97 ; return (wrap_gen <.> wrap_fun, group) }
98 where
99 arity = matchGroupArity matches
100 herald = text "The equation(s) for"
101 <+> quotes (ppr fun_name) <+> text "have"
102 what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
103 match_ctxt = MC { mc_what = what, mc_body = tcBody }
104 strictness
105 | [L _ match] <- unLoc $ mg_alts matches
106 , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
107 = SrcStrict
108 | otherwise
109 = NoSrcStrict
110
111 {-
112 @tcMatchesCase@ doesn't do the argument-count check because the
113 parser guarantees that each equation has exactly one argument.
114 -}
115
116 tcMatchesCase :: (Outputable (body GhcRn)) =>
117 TcMatchCtxt body -- Case context
118 -> TcSigmaType -- Type of scrutinee
119 -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives
120 -> ExpRhoType -- Type of whole case expressions
121 -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
122 -- Translated alternatives
123 -- wrapper goes from MatchGroup's ty to expected ty
124
125 tcMatchesCase ctxt scrut_ty matches res_ty
126 = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
127
128 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
129 -> TcMatchCtxt HsExpr
130 -> MatchGroup GhcRn (LHsExpr GhcRn)
131 -> ExpRhoType -- deeply skolemised
132 -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
133 tcMatchLambda herald match_ctxt match res_ty
134 = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
135 tcMatches match_ctxt pat_tys rhs_ty match
136 where
137 n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
138 | otherwise = matchGroupArity match
139
140 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
141
142 tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
143 -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
144 -- Used for pattern bindings
145 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
146 where
147 match_ctxt = MC { mc_what = PatBindRhs,
148 mc_body = tcBody }
149
150 {-
151 ************************************************************************
152 * *
153 \subsection{tcMatch}
154 * *
155 ************************************************************************
156
157 Note [Case branches must never infer a non-tau type]
158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 Consider
160
161 case ... of
162 ... -> \(x :: forall a. a -> a) -> x
163 ... -> \y -> y
164
165 Should that type-check? The problem is that, if we check the second branch
166 first, then we'll get a type (b -> b) for the branches, which won't unify
167 with the polytype in the first branch. If we check the first branch first,
168 then everything is OK. This order-dependency is terrible. So we want only
169 proper tau-types in branches (unless a sigma-type is pushed down).
170 This is what expTypeToType ensures: it replaces an Infer with a fresh
171 tau-type.
172
173 An even trickier case looks like
174
175 f x True = x undefined
176 f x False = x ()
177
178 Here, we see that the arguments must also be non-Infer. Thus, we must
179 use expTypeToType on the output of matchExpectedFunTys, not the input.
180
181 But we make a special case for a one-branch case. This is so that
182
183 f = \(x :: forall a. a -> a) -> x
184
185 still gets assigned a polytype.
186 -}
187
188 -- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
189 -- expected type into TauTvs.
190 -- See Note [Case branches must never infer a non-tau type]
191 tauifyMultipleMatches :: [LMatch id body]
192 -> [ExpType] -> TcM [ExpType]
193 tauifyMultipleMatches group exp_tys
194 | isSingletonMatchGroup group = return exp_tys
195 | otherwise = mapM tauifyExpType exp_tys
196 -- NB: In the empty-match case, this ensures we fill in the ExpType
197
198 -- | Type-check a MatchGroup.
199 tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
200 -> [ExpSigmaType] -- Expected pattern types
201 -> ExpRhoType -- Expected result-type of the Match.
202 -> MatchGroup GhcRn (Located (body GhcRn))
203 -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
204
205 data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
206 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
207 mc_body :: Located (body GhcRn) -- Type checker for a body of
208 -- an alternative
209 -> ExpRhoType
210 -> TcM (Located (body GhcTcId)) }
211
212 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
213 , mg_origin = origin })
214 = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
215 -- See Note [Case branches must never infer a non-tau type]
216
217 ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
218 ; pat_tys <- mapM readExpType pat_tys
219 ; rhs_ty <- readExpType rhs_ty
220 ; return (MG { mg_alts = L l matches'
221 , mg_ext = MatchGroupTc pat_tys rhs_ty
222 , mg_origin = origin }) }
223 tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec
224
225 -------------
226 tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
227 -> [ExpSigmaType] -- Expected pattern types
228 -> ExpRhoType -- Expected result-type of the Match.
229 -> LMatch GhcRn (Located (body GhcRn))
230 -> TcM (LMatch GhcTcId (Located (body GhcTcId)))
231
232 tcMatch ctxt pat_tys rhs_ty match
233 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
234 where
235 tc_match ctxt pat_tys rhs_ty
236 match@(Match { m_pats = pats, m_grhss = grhss })
237 = add_match_ctxt match $
238 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
239 tcGRHSs ctxt grhss rhs_ty
240 ; return (Match { m_ext = noExtField
241 , m_ctxt = mc_what ctxt, m_pats = pats'
242 , m_grhss = grhss' }) }
243 tc_match _ _ _ (XMatch nec) = noExtCon nec
244
245 -- For (\x -> e), tcExpr has already said "In the expression \x->e"
246 -- so we don't want to add "In the lambda abstraction \x->e"
247 add_match_ctxt match thing_inside
248 = case mc_what ctxt of
249 LambdaExpr -> thing_inside
250 _ -> addErrCtxt (pprMatchInCtxt match) thing_inside
251
252 -------------
253 tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
254 -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
255
256 -- Notice that we pass in the full res_ty, so that we get
257 -- good inference from simple things like
258 -- f = \(x::forall a.a->a) -> <stuff>
259 -- We used to force it to be a monotype when there was more than one guard
260 -- but we don't need to do that any more
261
262 tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
263 = do { (binds', grhss')
264 <- tcLocalBinds binds $
265 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
266
267 ; return (GRHSs noExtField grhss' (L l binds')) }
268 tcGRHSs _ (XGRHSs nec) _ = noExtCon nec
269
270 -------------
271 tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
272 -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
273
274 tcGRHS ctxt res_ty (GRHS _ guards rhs)
275 = do { (guards', rhs')
276 <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
277 mc_body ctxt rhs
278 ; return (GRHS noExtField guards' rhs') }
279 where
280 stmt_ctxt = PatGuard (mc_what ctxt)
281 tcGRHS _ _ (XGRHS nec) = noExtCon nec
282
283 {-
284 ************************************************************************
285 * *
286 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
287 * *
288 ************************************************************************
289 -}
290
291 tcDoStmts :: HsStmtContext Name
292 -> Located [LStmt GhcRn (LHsExpr GhcRn)]
293 -> ExpRhoType
294 -> TcM (HsExpr GhcTcId) -- Returns a HsDo
295 tcDoStmts ListComp (L l stmts) res_ty
296 = do { res_ty <- expTypeToType res_ty
297 ; (co, elt_ty) <- matchExpectedListTy res_ty
298 ; let list_ty = mkListTy elt_ty
299 ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
300 (mkCheckExpType elt_ty)
301 ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
302
303 tcDoStmts DoExpr (L l stmts) res_ty
304 = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
305 ; res_ty <- readExpType res_ty
306 ; return (HsDo res_ty DoExpr (L l stmts')) }
307
308 tcDoStmts MDoExpr (L l stmts) res_ty
309 = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
310 ; res_ty <- readExpType res_ty
311 ; return (HsDo res_ty MDoExpr (L l stmts')) }
312
313 tcDoStmts MonadComp (L l stmts) res_ty
314 = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
315 ; res_ty <- readExpType res_ty
316 ; return (HsDo res_ty MonadComp (L l stmts')) }
317
318 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
319
320 tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
321 tcBody body res_ty
322 = do { traceTc "tcBody" (ppr res_ty)
323 ; tcMonoExpr body res_ty
324 }
325
326 {-
327 ************************************************************************
328 * *
329 \subsection{tcStmts}
330 * *
331 ************************************************************************
332 -}
333
334 type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
335 type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
336
337 type TcStmtChecker body rho_type
338 = forall thing. HsStmtContext Name
339 -> Stmt GhcRn (Located (body GhcRn))
340 -> rho_type -- Result type for comprehension
341 -> (rho_type -> TcM thing) -- Checker for what follows the stmt
342 -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
343
344 tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
345 -> TcStmtChecker body rho_type -- NB: higher-rank type
346 -> [LStmt GhcRn (Located (body GhcRn))]
347 -> rho_type
348 -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
349 tcStmts ctxt stmt_chk stmts res_ty
350 = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
351 const (return ())
352 ; return stmts' }
353
354 tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
355 -> TcStmtChecker body rho_type -- NB: higher-rank type
356 -> [LStmt GhcRn (Located (body GhcRn))]
357 -> rho_type
358 -> (rho_type -> TcM thing)
359 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
360
361 -- Note the higher-rank type. stmt_chk is applied at different
362 -- types in the equations for tcStmts
363
364 tcStmtsAndThen _ _ [] res_ty thing_inside
365 = do { thing <- thing_inside res_ty
366 ; return ([], thing) }
367
368 -- LetStmts are handled uniformly, regardless of context
369 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
370 res_ty thing_inside
371 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
372 tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
373 ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
374
375 -- Don't set the error context for an ApplicativeStmt. It ought to be
376 -- possible to do this with a popErrCtxt in the tcStmt case for
377 -- ApplicativeStmt, but it did someting strange and broke a test (ado002).
378 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
379 | ApplicativeStmt{} <- stmt
380 = do { (stmt', (stmts', thing)) <-
381 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
382 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
383 thing_inside
384 ; return (L loc stmt' : stmts', thing) }
385
386 -- For the vanilla case, handle the location-setting part
387 | otherwise
388 = do { (stmt', (stmts', thing)) <-
389 setSrcSpan loc $
390 addErrCtxt (pprStmtInCtxt ctxt stmt) $
391 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
392 popErrCtxt $
393 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
394 thing_inside
395 ; return (L loc stmt' : stmts', thing) }
396
397 ---------------------------------------------------
398 -- Pattern guards
399 ---------------------------------------------------
400
401 tcGuardStmt :: TcExprStmtChecker
402 tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
403 = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
404 ; thing <- thing_inside res_ty
405 ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
406
407 tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
408 = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
409 -- Stmt has a context already
410 ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
411 pat (mkCheckExpType rhs_ty) $
412 thing_inside res_ty
413 ; return (mkTcBindStmt pat' rhs', thing) }
414
415 tcGuardStmt _ stmt _ _
416 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
417
418
419 ---------------------------------------------------
420 -- List comprehensions
421 -- (no rebindable syntax)
422 ---------------------------------------------------
423
424 -- Dealt with separately, rather than by tcMcStmt, because
425 -- a) We have special desugaring rules for list comprehensions,
426 -- which avoid creating intermediate lists. They in turn
427 -- assume that the bind/return operations are the regular
428 -- polymorphic ones, and in particular don't have any
429 -- coercion matching stuff in them. It's hard to avoid the
430 -- potential for non-trivial coercions in tcMcStmt
431
432 tcLcStmt :: TyCon -- The list type constructor ([])
433 -> TcExprStmtChecker
434
435 tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
436 = do { body' <- tcMonoExprNC body elt_ty
437 ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
438 ; return (LastStmt x body' noret noSyntaxExpr, thing) }
439
440 -- A generator, pat <- rhs
441 tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
442 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
443 ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
444 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
445 thing_inside elt_ty
446 ; return (mkTcBindStmt pat' rhs', thing) }
447
448 -- A boolean guard
449 tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
450 = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy)
451 ; thing <- thing_inside elt_ty
452 ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
453
454 -- ParStmt: See notes with tcMcStmt
455 tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
456 = do { (pairs', thing) <- loop bndr_stmts_s
457 ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
458 where
459 -- loop :: [([LStmt GhcRn], [GhcRn])]
460 -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
461 loop [] = do { thing <- thing_inside elt_ty
462 ; return ([], thing) } -- matching in the branches
463
464 loop (ParStmtBlock x stmts names _ : pairs)
465 = do { (stmts', (ids, pairs', thing))
466 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
467 do { ids <- tcLookupLocalIds names
468 ; (pairs', thing) <- loop pairs
469 ; return (ids, pairs', thing) }
470 ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
471 loop (XParStmtBlock nec:_) = noExtCon nec
472
473 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
474 , trS_bndrs = bindersMap
475 , trS_by = by, trS_using = using }) elt_ty thing_inside
476 = do { let (bndr_names, n_bndr_names) = unzip bindersMap
477 unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
478 -- The inner 'stmts' lack a LastStmt, so the element type
479 -- passed in to tcStmtsAndThen is never looked at
480 ; (stmts', (bndr_ids, by'))
481 <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
482 { by' <- traverse tcInferRho by
483 ; bndr_ids <- tcLookupLocalIds bndr_names
484 ; return (bndr_ids, by') }
485
486 ; let m_app ty = mkTyConApp m_tc [ty]
487
488 --------------- Typecheck the 'using' function -------------
489 -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
490 -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
491
492 -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
493 ; let n_app = case form of
494 ThenForm -> (\ty -> ty)
495 _ -> m_app
496
497 by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
498 by_arrow = case by' of
499 Nothing -> \ty -> ty
500 Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty
501
502 tup_ty = mkBigCoreVarTupTy bndr_ids
503 poly_arg_ty = m_app alphaTy
504 poly_res_ty = m_app (n_app alphaTy)
505 using_poly_ty = mkInvForAllTy alphaTyVar $
506 by_arrow $
507 poly_arg_ty `mkVisFunTy` poly_res_ty
508
509 ; using' <- tcPolyExpr using using_poly_ty
510 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
511
512 -- 'stmts' returns a result of type (m1_ty tuple_ty),
513 -- typically something like [(Int,Bool,Int)]
514 -- We don't know what tuple_ty is yet, so we use a variable
515 ; let mk_n_bndr :: Name -> TcId -> TcId
516 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
517
518 -- Ensure that every old binder of type `b` is linked up with its
519 -- new binder which should have type `n b`
520 -- See Note [GroupStmt binder map] in GHC.Hs.Expr
521 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
522 bindersMap' = bndr_ids `zip` n_bndr_ids
523
524 -- Type check the thing in the environment with
525 -- these new binders and return the result
526 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
527
528 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
529 , trS_by = fmap fst by', trS_using = final_using
530 , trS_ret = noSyntaxExpr
531 , trS_bind = noSyntaxExpr
532 , trS_fmap = noExpr
533 , trS_ext = unitTy
534 , trS_form = form }, thing) }
535
536 tcLcStmt _ _ stmt _ _
537 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
538
539
540 ---------------------------------------------------
541 -- Monad comprehensions
542 -- (supports rebindable syntax)
543 ---------------------------------------------------
544
545 tcMcStmt :: TcExprStmtChecker
546
547 tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
548 = do { (body', return_op')
549 <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
550 \ [a_ty] ->
551 tcMonoExprNC body (mkCheckExpType a_ty)
552 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
553 ; return (LastStmt x body' noret return_op', thing) }
554
555 -- Generators for monad comprehensions ( pat <- rhs )
556 --
557 -- [ body | q <- gen ] -> gen :: m a
558 -- q :: a
559 --
560
561 tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
562 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
563 = do { ((rhs', pat', thing, new_res_ty), bind_op')
564 <- tcSyntaxOp MCompOrigin bind_op
565 [SynRho, SynFun SynAny SynRho] res_ty $
566 \ [rhs_ty, pat_ty, new_res_ty] ->
567 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
568 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
569 (mkCheckExpType pat_ty) $
570 thing_inside (mkCheckExpType new_res_ty)
571 ; return (rhs', pat', thing, new_res_ty) }
572
573 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
574 ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
575
576 ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
577
578 -- Boolean expressions.
579 --
580 -- [ body | stmts, expr ] -> expr :: m Bool
581 --
582 tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
583 = do { -- Deal with rebindable syntax:
584 -- guard_op :: test_ty -> rhs_ty
585 -- then_op :: rhs_ty -> new_res_ty -> res_ty
586 -- Where test_ty is, for example, Bool
587 ; ((thing, rhs', rhs_ty, guard_op'), then_op')
588 <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
589 \ [rhs_ty, new_res_ty] ->
590 do { (rhs', guard_op')
591 <- tcSyntaxOp MCompOrigin guard_op [SynAny]
592 (mkCheckExpType rhs_ty) $
593 \ [test_ty] ->
594 tcMonoExpr rhs (mkCheckExpType test_ty)
595 ; thing <- thing_inside (mkCheckExpType new_res_ty)
596 ; return (thing, rhs', rhs_ty, guard_op') }
597 ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
598
599 -- Grouping statements
600 --
601 -- [ body | stmts, then group by e using f ]
602 -- -> e :: t
603 -- f :: forall a. (a -> t) -> m a -> m (m a)
604 -- [ body | stmts, then group using f ]
605 -- -> f :: forall a. m a -> m (m a)
606
607 -- We type [ body | (stmts, group by e using f), ... ]
608 -- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
609 --
610 -- We type the functions as follows:
611 -- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
612 -- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
613 -- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
614 -- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
615 --
616 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
617 , trS_by = by, trS_using = using, trS_form = form
618 , trS_ret = return_op, trS_bind = bind_op
619 , trS_fmap = fmap_op }) res_ty thing_inside
620 = do { m1_ty <- newFlexiTyVarTy typeToTypeKind
621 ; m2_ty <- newFlexiTyVarTy typeToTypeKind
622 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
623 ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
624
625 -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
626 ; n_app <- case form of
627 ThenForm -> return (\ty -> ty)
628 _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
629 ; return (n_ty `mkAppTy`) }
630 ; let by_arrow :: Type -> Type
631 -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
632 -- or res ('by' absent)
633 by_arrow = case by of
634 Nothing -> \res -> res
635 Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res
636
637 poly_arg_ty = m1_ty `mkAppTy` alphaTy
638 using_arg_ty = m1_ty `mkAppTy` tup_ty
639 poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
640 using_res_ty = m2_ty `mkAppTy` n_app tup_ty
641 using_poly_ty = mkInvForAllTy alphaTyVar $
642 by_arrow $
643 poly_arg_ty `mkVisFunTy` poly_res_ty
644
645 -- 'stmts' returns a result of type (m1_ty tuple_ty),
646 -- typically something like [(Int,Bool,Int)]
647 -- We don't know what tuple_ty is yet, so we use a variable
648 ; let (bndr_names, n_bndr_names) = unzip bindersMap
649 ; (stmts', (bndr_ids, by', return_op')) <-
650 tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
651 (mkCheckExpType using_arg_ty) $ \res_ty' -> do
652 { by' <- case by of
653 Nothing -> return Nothing
654 Just e -> do { e' <- tcMonoExpr e
655 (mkCheckExpType by_e_ty)
656 ; return (Just e') }
657
658 -- Find the Ids (and hence types) of all old binders
659 ; bndr_ids <- tcLookupLocalIds bndr_names
660
661 -- 'return' is only used for the binders, so we know its type.
662 -- return :: (a,b,c,..) -> m (a,b,c,..)
663 ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
664 [synKnownType (mkBigCoreVarTupTy bndr_ids)]
665 res_ty' $ \ _ -> return ()
666
667 ; return (bndr_ids, by', return_op') }
668
669 --------------- Typecheck the 'bind' function -------------
670 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
671 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
672 ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
673 [ synKnownType using_res_ty
674 , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ]
675 res_ty $ \ _ -> return ()
676
677 --------------- Typecheck the 'fmap' function -------------
678 ; fmap_op' <- case form of
679 ThenForm -> return noExpr
680 _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
681 mkInvForAllTy alphaTyVar $
682 mkInvForAllTy betaTyVar $
683 (alphaTy `mkVisFunTy` betaTy)
684 `mkVisFunTy` (n_app alphaTy)
685 `mkVisFunTy` (n_app betaTy)
686
687 --------------- Typecheck the 'using' function -------------
688 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
689
690 ; using' <- tcPolyExpr using using_poly_ty
691 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
692
693 --------------- Bulding the bindersMap ----------------
694 ; let mk_n_bndr :: Name -> TcId -> TcId
695 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
696
697 -- Ensure that every old binder of type `b` is linked up with its
698 -- new binder which should have type `n b`
699 -- See Note [GroupStmt binder map] in GHC.Hs.Expr
700 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
701 bindersMap' = bndr_ids `zip` n_bndr_ids
702
703 -- Type check the thing in the environment with
704 -- these new binders and return the result
705 ; thing <- tcExtendIdEnv n_bndr_ids $
706 thing_inside (mkCheckExpType new_res_ty)
707
708 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
709 , trS_by = by', trS_using = final_using
710 , trS_ret = return_op', trS_bind = bind_op'
711 , trS_ext = n_app tup_ty
712 , trS_fmap = fmap_op', trS_form = form }, thing) }
713
714 -- A parallel set of comprehensions
715 -- [ (g x, h x) | ... ; let g v = ...
716 -- | ... ; let h v = ... ]
717 --
718 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
719 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
720 -- Similarly if we had an existential pattern match:
721 --
722 -- data T = forall a. Show a => C a
723 --
724 -- [ (show x, show y) | ... ; C x <- ...
725 -- | ... ; C y <- ... ]
726 --
727 -- Then we need the LIE from (show x, show y) to be simplified against
728 -- the bindings for x and y.
729 --
730 -- It's difficult to do this in parallel, so we rely on the renamer to
731 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
732 -- So the binders of the first parallel group will be in scope in the second
733 -- group. But that's fine; there's no shadowing to worry about.
734 --
735 -- Note: The `mzip` function will get typechecked via:
736 --
737 -- ParStmt [st1::t1, st2::t2, st3::t3]
738 --
739 -- mzip :: m st1
740 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
741 -- -> m (st1, (st2, st3))
742 --
743 tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
744 = do { m_ty <- newFlexiTyVarTy typeToTypeKind
745
746 ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
747 (m_ty `mkAppTy` alphaTy)
748 `mkVisFunTy`
749 (m_ty `mkAppTy` betaTy)
750 `mkVisFunTy`
751 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
752 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
753
754 -- type dummies since we don't know all binder types yet
755 ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
756 [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
757
758 -- Typecheck bind:
759 ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
760 tuple_ty = mk_tuple_ty tup_tys
761
762 ; (((blocks', thing), inner_res_ty), bind_op')
763 <- tcSyntaxOp MCompOrigin bind_op
764 [ synKnownType (m_ty `mkAppTy` tuple_ty)
765 , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
766 \ [inner_res_ty] ->
767 do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
768 tup_tys bndr_stmts_s
769 ; return (stuff, inner_res_ty) }
770
771 ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
772
773 where
774 mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
775
776 -- loop :: Type -- m_ty
777 -- -> ExpRhoType -- inner_res_ty
778 -- -> [TcType] -- tup_tys
779 -- -> [ParStmtBlock Name]
780 -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
781 loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
782 ; return ([], thing) }
783 -- matching in the branches
784
785 loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
786 (ParStmtBlock x stmts names return_op : pairs)
787 = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
788 ; (stmts', (ids, return_op', pairs', thing))
789 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
790 \m_tup_ty' ->
791 do { ids <- tcLookupLocalIds names
792 ; let tup_ty = mkBigCoreVarTupTy ids
793 ; (_, return_op') <-
794 tcSyntaxOp MCompOrigin return_op
795 [synKnownType tup_ty] m_tup_ty' $
796 \ _ -> return ()
797 ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
798 ; return (ids, return_op', pairs', thing) }
799 ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
800 loop _ _ _ _ = panic "tcMcStmt.loop"
801
802 tcMcStmt _ stmt _ _
803 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
804
805
806 ---------------------------------------------------
807 -- Do-notation
808 -- (supports rebindable syntax)
809 ---------------------------------------------------
810
811 tcDoStmt :: TcExprStmtChecker
812
813 tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
814 = do { body' <- tcMonoExprNC body res_ty
815 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
816 ; return (LastStmt x body' noret noSyntaxExpr, thing) }
817
818 tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
819 = do { -- Deal with rebindable syntax:
820 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
821 -- This level of generality is needed for using do-notation
822 -- in full generality; see #1537
823
824 ((rhs', pat', new_res_ty, thing), bind_op')
825 <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
826 \ [rhs_ty, pat_ty, new_res_ty] ->
827 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
828 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
829 (mkCheckExpType pat_ty) $
830 thing_inside (mkCheckExpType new_res_ty)
831 ; return (rhs', pat', new_res_ty, thing) }
832
833 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
834 ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
835
836 ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
837
838 tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
839 = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
840 thing_inside . mkCheckExpType
841 ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
842 Nothing -> (, Nothing) <$> tc_app_stmts res_ty
843 Just join_op ->
844 second Just <$>
845 (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
846 \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
847
848 ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
849
850 tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
851 = do { -- Deal with rebindable syntax;
852 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
853 ; ((rhs', rhs_ty, thing), then_op')
854 <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
855 \ [rhs_ty, new_res_ty] ->
856 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
857 ; thing <- thing_inside (mkCheckExpType new_res_ty)
858 ; return (rhs', rhs_ty, thing) }
859 ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
860
861 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
862 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
863 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
864 res_ty thing_inside
865 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
866 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
867 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
868 tup_ty = mkBigCoreTupTy tup_elt_tys
869
870 ; tcExtendIdEnv tup_ids $ do
871 { ((stmts', (ret_op', tup_rets)), stmts_ty)
872 <- tcInferInst $ \ exp_ty ->
873 tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
874 do { tup_rets <- zipWithM tcCheckId tup_names
875 (map mkCheckExpType tup_elt_tys)
876 -- Unify the types of the "final" Ids (which may
877 -- be polymorphic) with those of "knot-tied" Ids
878 ; (_, ret_op')
879 <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
880 inner_res_ty $ \_ -> return ()
881 ; return (ret_op', tup_rets) }
882
883 ; ((_, mfix_op'), mfix_res_ty)
884 <- tcInferInst $ \ exp_ty ->
885 tcSyntaxOp DoOrigin mfix_op
886 [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $
887 \ _ -> return ()
888
889 ; ((thing, new_res_ty), bind_op')
890 <- tcSyntaxOp DoOrigin bind_op
891 [ synKnownType mfix_res_ty
892 , synKnownType tup_ty `SynFun` SynRho ]
893 res_ty $
894 \ [new_res_ty] ->
895 do { thing <- thing_inside (mkCheckExpType new_res_ty)
896 ; return (thing, new_res_ty) }
897
898 ; let rec_ids = takeList rec_names tup_ids
899 ; later_ids <- tcLookupLocalIds later_names
900 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
901 ppr later_ids <+> ppr (map idType later_ids)]
902 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
903 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
904 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
905 , recS_ext = RecStmtTc
906 { recS_bind_ty = new_res_ty
907 , recS_later_rets = []
908 , recS_rec_rets = tup_rets
909 , recS_ret_ty = stmts_ty} }, thing)
910 }}
911
912 tcDoStmt _ stmt _ _
913 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
914
915
916
917 ---------------------------------------------------
918 -- MonadFail Proposal warnings
919 ---------------------------------------------------
920
921 -- The idea behind issuing MonadFail warnings is that we add them whenever a
922 -- failable pattern is encountered. However, instead of throwing a type error
923 -- when the constraint cannot be satisfied, we only issue a warning in
924 -- TcErrors.hs.
925
926 tcMonadFailOp :: CtOrigin
927 -> LPat GhcTcId
928 -> SyntaxExpr GhcRn -- The fail op
929 -> TcType -- Type of the whole do-expression
930 -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op
931 -- Get a 'fail' operator expression, to use if the pattern
932 -- match fails. If the pattern is irrefutatable, just return
933 -- noSyntaxExpr; it won't be used
934 tcMonadFailOp orig pat fail_op res_ty
935 | isIrrefutableHsPat pat
936 = return noSyntaxExpr
937
938 | otherwise
939 = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
940 (mkCheckExpType res_ty) $ \_ -> return ())
941
942 {-
943 Note [Treat rebindable syntax first]
944 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
945 When typechecking
946 do { bar; ... } :: IO ()
947 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
948 pushing info from the context into the RHS. To do this, we check the
949 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
950 Otherwise the error shows up when checking the rebindable syntax, and
951 the expected/inferred stuff is back to front (see #3613).
952
953 Note [typechecking ApplicativeStmt]
954
955 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
956
957 fresh type variables:
958 pat_ty_1..pat_ty_n
959 exp_ty_1..exp_ty_n
960 t_1..t_(n-1)
961
962 body :: body_ty
963 (\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
964 pat_i :: pat_ty_i
965 e_i :: exp_ty_i
966 <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
967 <*>_i :: t_(i-1) -> exp_ty_i -> t_i
968 join :: tn -> res_ty
969 -}
970
971 tcApplicativeStmts
972 :: HsStmtContext Name
973 -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
974 -> ExpRhoType -- rhs_ty
975 -> (TcRhoType -> TcM t) -- thing_inside
976 -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
977
978 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
979 = do { body_ty <- newFlexiTyVarTy liftedTypeKind
980 ; let arity = length pairs
981 ; ts <- replicateM (arity-1) $ newInferExpTypeInst
982 ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
983 ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
984 ; let fun_ty = mkVisFunTys pat_tys body_ty
985
986 -- NB. do the <$>,<*> operators first, we don't want type errors here
987 -- i.e. goOps before goArgs
988 -- See Note [Treat rebindable syntax first]
989 ; let (ops, args) = unzip pairs
990 ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
991
992 -- Typecheck each ApplicativeArg separately
993 -- See Note [ApplicativeDo and constraints]
994 ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
995
996 -- Bring into scope all the things bound by the args,
997 -- and typecheck the thing_inside
998 -- See Note [ApplicativeDo and constraints]
999 ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
1000 thing_inside body_ty
1001
1002 ; return (zip ops' args', body_ty, res) }
1003 where
1004 goOps _ [] = return []
1005 goOps t_left ((op,t_i,exp_ty) : ops)
1006 = do { (_, op')
1007 <- tcSyntaxOp DoOrigin op
1008 [synKnownType t_left, synKnownType exp_ty] t_i $
1009 \ _ -> return ()
1010 ; t_i <- readExpType t_i
1011 ; ops' <- goOps t_i ops
1012 ; return (op' : ops') }
1013
1014 goArg :: (ApplicativeArg GhcRn, Type, Type)
1015 -> TcM (ApplicativeArg GhcTcId)
1016
1017 goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)
1018 = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
1019 addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $
1020 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
1021 ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
1022 return ()
1023 ; return (ApplicativeArgOne x pat' rhs' isBody) }
1024
1025 goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
1026 = do { (stmts', (ret',pat')) <-
1027 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
1028 \res_ty -> do
1029 { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
1030 ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
1031 return ()
1032 ; return (ret', pat')
1033 }
1034 ; return (ApplicativeArgMany x stmts' ret' pat') }
1035
1036 goArg (XApplicativeArg nec, _, _) = noExtCon nec
1037
1038 get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
1039 get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat
1040 get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
1041 get_arg_bndrs (XApplicativeArg nec) = noExtCon nec
1042
1043
1044 {- Note [ApplicativeDo and constraints]
1045 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1046 An applicative-do is supposed to take place in parallel, so
1047 constraints bound in one arm can't possibly be available in another
1048 (#13242). Our current rule is this (more details and discussion
1049 on the ticket). Consider
1050
1051 ...stmts...
1052 ApplicativeStmts [arg1, arg2, ... argN]
1053 ...more stmts...
1054
1055 where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
1056 Now, we say that:
1057
1058 * Constraints required by the argi can be solved from
1059 constraint bound by ...stmts...
1060
1061 * Constraints and existentials bound by the argi are not available
1062 to solve constraints required either by argj (where i /= j),
1063 or by ...more stmts....
1064
1065 * Within the stmts of each 'argi' individually, however, constraints bound
1066 by earlier stmts can be used to solve later ones.
1067
1068 To achieve this, we just typecheck each 'argi' separately, bring all
1069 the variables they bind into scope, and typecheck the thing_inside.
1070
1071 ************************************************************************
1072 * *
1073 \subsection{Errors and contexts}
1074 * *
1075 ************************************************************************
1076
1077 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
1078 number of args are used in each equation.
1079 -}
1080
1081 checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
1082 checkArgs _ (MG { mg_alts = L _ [] })
1083 = return ()
1084 checkArgs fun (MG { mg_alts = L _ (match1:matches) })
1085 | null bad_matches
1086 = return ()
1087 | otherwise
1088 = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
1089 text "have different numbers of arguments"
1090 , nest 2 (ppr (getLoc match1))
1091 , nest 2 (ppr (getLoc (head bad_matches)))])
1092 where
1093 n_args1 = args_in_match match1
1094 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
1095
1096 args_in_match :: LMatch GhcRn body -> Int
1097 args_in_match (L _ (Match { m_pats = pats })) = length pats
1098 args_in_match (L _ (XMatch nec)) = noExtCon nec
1099 checkArgs _ (XMatchGroup nec) = noExtCon nec