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