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