TTG3 Combined Step 1 and 3 for Trees That Grow
[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_arg_tys = pat_tys
224 , mg_res_ty = rhs_ty
225 , mg_origin = origin }) }
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_ctxt = mc_what ctxt, m_pats = pats'
243 , m_grhss = grhss' }) }
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 grhss' (L l binds')) }
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 guards' rhs') }
278 where
279 stmt_ctxt = PatGuard (mc_what ctxt)
280
281 {-
282 ************************************************************************
283 * *
284 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
285 * *
286 ************************************************************************
287 -}
288
289 tcDoStmts :: HsStmtContext Name
290 -> Located [LStmt GhcRn (LHsExpr GhcRn)]
291 -> ExpRhoType
292 -> TcM (HsExpr GhcTcId) -- Returns a HsDo
293 tcDoStmts ListComp (L l stmts) res_ty
294 = do { res_ty <- expTypeToType res_ty
295 ; (co, elt_ty) <- matchExpectedListTy res_ty
296 ; let list_ty = mkListTy elt_ty
297 ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
298 (mkCheckExpType elt_ty)
299 ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
300
301 tcDoStmts PArrComp (L l stmts) res_ty
302 = do { res_ty <- expTypeToType res_ty
303 ; (co, elt_ty) <- matchExpectedPArrTy res_ty
304 ; let parr_ty = mkPArrTy elt_ty
305 ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
306 (mkCheckExpType elt_ty)
307 ; return $ mkHsWrapCo co (HsDo parr_ty PArrComp (L l stmts')) }
308
309 tcDoStmts DoExpr (L l stmts) res_ty
310 = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
311 ; res_ty <- readExpType res_ty
312 ; return (HsDo res_ty DoExpr (L l stmts')) }
313
314 tcDoStmts MDoExpr (L l stmts) res_ty
315 = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
316 ; res_ty <- readExpType res_ty
317 ; return (HsDo res_ty MDoExpr (L l stmts')) }
318
319 tcDoStmts MonadComp (L l stmts) res_ty
320 = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
321 ; res_ty <- readExpType res_ty
322 ; return (HsDo res_ty MonadComp (L l stmts')) }
323
324 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
325
326 tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
327 tcBody body res_ty
328 = do { traceTc "tcBody" (ppr res_ty)
329 ; tcMonoExpr body res_ty
330 }
331
332 {-
333 ************************************************************************
334 * *
335 \subsection{tcStmts}
336 * *
337 ************************************************************************
338 -}
339
340 type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
341 type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
342
343 type TcStmtChecker body rho_type
344 = forall thing. HsStmtContext Name
345 -> Stmt GhcRn (Located (body GhcRn))
346 -> rho_type -- Result type for comprehension
347 -> (rho_type -> TcM thing) -- Checker for what follows the stmt
348 -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
349
350 tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
351 -> TcStmtChecker body rho_type -- NB: higher-rank type
352 -> [LStmt GhcRn (Located (body GhcRn))]
353 -> rho_type
354 -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
355 tcStmts ctxt stmt_chk stmts res_ty
356 = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
357 const (return ())
358 ; return stmts' }
359
360 tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
361 -> TcStmtChecker body rho_type -- NB: higher-rank type
362 -> [LStmt GhcRn (Located (body GhcRn))]
363 -> rho_type
364 -> (rho_type -> TcM thing)
365 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
366
367 -- Note the higher-rank type. stmt_chk is applied at different
368 -- types in the equations for tcStmts
369
370 tcStmtsAndThen _ _ [] res_ty thing_inside
371 = do { thing <- thing_inside res_ty
372 ; return ([], thing) }
373
374 -- LetStmts are handled uniformly, regardless of context
375 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts)
376 res_ty thing_inside
377 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
378 tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
379 ; return (L loc (LetStmt (L l binds')) : stmts', thing) }
380
381 -- Don't set the error context for an ApplicativeStmt. It ought to be
382 -- possible to do this with a popErrCtxt in the tcStmt case for
383 -- ApplicativeStmt, but it did someting strange and broke a test (ado002).
384 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
385 | ApplicativeStmt{} <- stmt
386 = do { (stmt', (stmts', thing)) <-
387 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
388 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
389 thing_inside
390 ; return (L loc stmt' : stmts', thing) }
391
392 -- For the vanilla case, handle the location-setting part
393 | otherwise
394 = do { (stmt', (stmts', thing)) <-
395 setSrcSpan loc $
396 addErrCtxt (pprStmtInCtxt ctxt stmt) $
397 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
398 popErrCtxt $
399 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
400 thing_inside
401 ; return (L loc stmt' : stmts', thing) }
402
403 ---------------------------------------------------
404 -- Pattern guards
405 ---------------------------------------------------
406
407 tcGuardStmt :: TcExprStmtChecker
408 tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside
409 = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
410 ; thing <- thing_inside res_ty
411 ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
412
413 tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
414 = do { (rhs', rhs_ty) <- tcInferSigmaNC rhs
415 -- Stmt has a context already
416 ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
417 pat (mkCheckExpType rhs_ty) $
418 thing_inside res_ty
419 ; return (mkTcBindStmt pat' rhs', thing) }
420
421 tcGuardStmt _ stmt _ _
422 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
423
424
425 ---------------------------------------------------
426 -- List comprehensions and PArrays
427 -- (no rebindable syntax)
428 ---------------------------------------------------
429
430 -- Dealt with separately, rather than by tcMcStmt, because
431 -- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
432 -- b) We have special desugaring rules for list comprehensions,
433 -- which avoid creating intermediate lists. They in turn
434 -- assume that the bind/return operations are the regular
435 -- polymorphic ones, and in particular don't have any
436 -- coercion matching stuff in them. It's hard to avoid the
437 -- potential for non-trivial coercions in tcMcStmt
438
439 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
440 -> TcExprStmtChecker
441
442 tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside
443 = do { body' <- tcMonoExprNC body elt_ty
444 ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
445 ; return (LastStmt body' noret noSyntaxExpr, thing) }
446
447 -- A generator, pat <- rhs
448 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside
449 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
450 ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
451 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
452 thing_inside elt_ty
453 ; return (mkTcBindStmt pat' rhs', thing) }
454
455 -- A boolean guard
456 tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside
457 = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy)
458 ; thing <- thing_inside elt_ty
459 ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
460
461 -- ParStmt: See notes with tcMcStmt
462 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
463 = do { (pairs', thing) <- loop bndr_stmts_s
464 ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) }
465 where
466 -- loop :: [([LStmt GhcRn], [GhcRn])]
467 -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
468 loop [] = do { thing <- thing_inside elt_ty
469 ; return ([], thing) } -- matching in the branches
470
471 loop (ParStmtBlock x stmts names _ : pairs)
472 = do { (stmts', (ids, pairs', thing))
473 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
474 do { ids <- tcLookupLocalIds names
475 ; (pairs', thing) <- loop pairs
476 ; return (ids, pairs', thing) }
477 ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
478 loop (XParStmtBlock{}:_) = panic "tcLcStmt"
479
480 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
481 , trS_bndrs = bindersMap
482 , trS_by = by, trS_using = using }) elt_ty thing_inside
483 = do { let (bndr_names, n_bndr_names) = unzip bindersMap
484 unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
485 -- The inner 'stmts' lack a LastStmt, so the element type
486 -- passed in to tcStmtsAndThen is never looked at
487 ; (stmts', (bndr_ids, by'))
488 <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
489 { by' <- traverse tcInferSigma by
490 ; bndr_ids <- tcLookupLocalIds bndr_names
491 ; return (bndr_ids, by') }
492
493 ; let m_app ty = mkTyConApp m_tc [ty]
494
495 --------------- Typecheck the 'using' function -------------
496 -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
497 -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
498
499 -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
500 ; let n_app = case form of
501 ThenForm -> (\ty -> ty)
502 _ -> m_app
503
504 by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
505 by_arrow = case by' of
506 Nothing -> \ty -> ty
507 Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
508
509 tup_ty = mkBigCoreVarTupTy bndr_ids
510 poly_arg_ty = m_app alphaTy
511 poly_res_ty = m_app (n_app alphaTy)
512 using_poly_ty = mkInvForAllTy alphaTyVar $
513 by_arrow $
514 poly_arg_ty `mkFunTy` poly_res_ty
515
516 ; using' <- tcPolyExpr using using_poly_ty
517 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
518
519 -- 'stmts' returns a result of type (m1_ty tuple_ty),
520 -- typically something like [(Int,Bool,Int)]
521 -- We don't know what tuple_ty is yet, so we use a variable
522 ; let mk_n_bndr :: Name -> TcId -> TcId
523 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
524
525 -- Ensure that every old binder of type `b` is linked up with its
526 -- new binder which should have type `n b`
527 -- See Note [GroupStmt binder map] in HsExpr
528 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
529 bindersMap' = bndr_ids `zip` n_bndr_ids
530
531 -- Type check the thing in the environment with
532 -- these new binders and return the result
533 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
534
535 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
536 , trS_by = fmap fst by', trS_using = final_using
537 , trS_ret = noSyntaxExpr
538 , trS_bind = noSyntaxExpr
539 , trS_fmap = noExpr
540 , trS_bind_arg_ty = unitTy
541 , trS_form = form }, thing) }
542
543 tcLcStmt _ _ stmt _ _
544 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
545
546
547 ---------------------------------------------------
548 -- Monad comprehensions
549 -- (supports rebindable syntax)
550 ---------------------------------------------------
551
552 tcMcStmt :: TcExprStmtChecker
553
554 tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
555 = do { (body', return_op')
556 <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
557 \ [a_ty] ->
558 tcMonoExprNC body (mkCheckExpType a_ty)
559 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
560 ; return (LastStmt body' noret return_op', thing) }
561
562 -- Generators for monad comprehensions ( pat <- rhs )
563 --
564 -- [ body | q <- gen ] -> gen :: m a
565 -- q :: a
566 --
567
568 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
569 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
570 = do { ((rhs', pat', thing, new_res_ty), bind_op')
571 <- tcSyntaxOp MCompOrigin bind_op
572 [SynRho, SynFun SynAny SynRho] res_ty $
573 \ [rhs_ty, pat_ty, new_res_ty] ->
574 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
575 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
576 (mkCheckExpType pat_ty) $
577 thing_inside (mkCheckExpType new_res_ty)
578 ; return (rhs', pat', thing, new_res_ty) }
579
580 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
581 ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
582
583 ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
584
585 -- Boolean expressions.
586 --
587 -- [ body | stmts, expr ] -> expr :: m Bool
588 --
589 tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
590 = do { -- Deal with rebindable syntax:
591 -- guard_op :: test_ty -> rhs_ty
592 -- then_op :: rhs_ty -> new_res_ty -> res_ty
593 -- Where test_ty is, for example, Bool
594 ; ((thing, rhs', rhs_ty, guard_op'), then_op')
595 <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
596 \ [rhs_ty, new_res_ty] ->
597 do { (rhs', guard_op')
598 <- tcSyntaxOp MCompOrigin guard_op [SynAny]
599 (mkCheckExpType rhs_ty) $
600 \ [test_ty] ->
601 tcMonoExpr rhs (mkCheckExpType test_ty)
602 ; thing <- thing_inside (mkCheckExpType new_res_ty)
603 ; return (thing, rhs', rhs_ty, guard_op') }
604 ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) }
605
606 -- Grouping statements
607 --
608 -- [ body | stmts, then group by e using f ]
609 -- -> e :: t
610 -- f :: forall a. (a -> t) -> m a -> m (m a)
611 -- [ body | stmts, then group using f ]
612 -- -> f :: forall a. m a -> m (m a)
613
614 -- We type [ body | (stmts, group by e using f), ... ]
615 -- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
616 --
617 -- We type the functions as follows:
618 -- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
619 -- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
620 -- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
621 -- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
622 --
623 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
624 , trS_by = by, trS_using = using, trS_form = form
625 , trS_ret = return_op, trS_bind = bind_op
626 , trS_fmap = fmap_op }) res_ty thing_inside
627 = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
628 ; m1_ty <- newFlexiTyVarTy star_star_kind
629 ; m2_ty <- newFlexiTyVarTy star_star_kind
630 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
631 ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
632
633 -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
634 ; n_app <- case form of
635 ThenForm -> return (\ty -> ty)
636 _ -> do { n_ty <- newFlexiTyVarTy star_star_kind
637 ; return (n_ty `mkAppTy`) }
638 ; let by_arrow :: Type -> Type
639 -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
640 -- or res ('by' absent)
641 by_arrow = case by of
642 Nothing -> \res -> res
643 Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
644
645 poly_arg_ty = m1_ty `mkAppTy` alphaTy
646 using_arg_ty = m1_ty `mkAppTy` tup_ty
647 poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
648 using_res_ty = m2_ty `mkAppTy` n_app tup_ty
649 using_poly_ty = mkInvForAllTy alphaTyVar $
650 by_arrow $
651 poly_arg_ty `mkFunTy` poly_res_ty
652
653 -- 'stmts' returns a result of type (m1_ty tuple_ty),
654 -- typically something like [(Int,Bool,Int)]
655 -- We don't know what tuple_ty is yet, so we use a variable
656 ; let (bndr_names, n_bndr_names) = unzip bindersMap
657 ; (stmts', (bndr_ids, by', return_op')) <-
658 tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
659 (mkCheckExpType using_arg_ty) $ \res_ty' -> do
660 { by' <- case by of
661 Nothing -> return Nothing
662 Just e -> do { e' <- tcMonoExpr e
663 (mkCheckExpType by_e_ty)
664 ; return (Just e') }
665
666 -- Find the Ids (and hence types) of all old binders
667 ; bndr_ids <- tcLookupLocalIds bndr_names
668
669 -- 'return' is only used for the binders, so we know its type.
670 -- return :: (a,b,c,..) -> m (a,b,c,..)
671 ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
672 [synKnownType (mkBigCoreVarTupTy bndr_ids)]
673 res_ty' $ \ _ -> return ()
674
675 ; return (bndr_ids, by', return_op') }
676
677 --------------- Typecheck the 'bind' function -------------
678 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
679 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
680 ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
681 [ synKnownType using_res_ty
682 , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]
683 res_ty $ \ _ -> return ()
684
685 --------------- Typecheck the 'fmap' function -------------
686 ; fmap_op' <- case form of
687 ThenForm -> return noExpr
688 _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
689 mkInvForAllTy alphaTyVar $
690 mkInvForAllTy betaTyVar $
691 (alphaTy `mkFunTy` betaTy)
692 `mkFunTy` (n_app alphaTy)
693 `mkFunTy` (n_app betaTy)
694
695 --------------- Typecheck the 'using' function -------------
696 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
697
698 ; using' <- tcPolyExpr using using_poly_ty
699 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
700
701 --------------- Bulding the bindersMap ----------------
702 ; let mk_n_bndr :: Name -> TcId -> TcId
703 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
704
705 -- Ensure that every old binder of type `b` is linked up with its
706 -- new binder which should have type `n b`
707 -- See Note [GroupStmt binder map] in HsExpr
708 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
709 bindersMap' = bndr_ids `zip` n_bndr_ids
710
711 -- Type check the thing in the environment with
712 -- these new binders and return the result
713 ; thing <- tcExtendIdEnv n_bndr_ids $
714 thing_inside (mkCheckExpType new_res_ty)
715
716 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
717 , trS_by = by', trS_using = final_using
718 , trS_ret = return_op', trS_bind = bind_op'
719 , trS_bind_arg_ty = n_app tup_ty
720 , trS_fmap = fmap_op', trS_form = form }, thing) }
721
722 -- A parallel set of comprehensions
723 -- [ (g x, h x) | ... ; let g v = ...
724 -- | ... ; let h v = ... ]
725 --
726 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
727 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
728 -- Similarly if we had an existential pattern match:
729 --
730 -- data T = forall a. Show a => C a
731 --
732 -- [ (show x, show y) | ... ; C x <- ...
733 -- | ... ; C y <- ... ]
734 --
735 -- Then we need the LIE from (show x, show y) to be simplified against
736 -- the bindings for x and y.
737 --
738 -- It's difficult to do this in parallel, so we rely on the renamer to
739 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
740 -- So the binders of the first parallel group will be in scope in the second
741 -- group. But that's fine; there's no shadowing to worry about.
742 --
743 -- Note: The `mzip` function will get typechecked via:
744 --
745 -- ParStmt [st1::t1, st2::t2, st3::t3]
746 --
747 -- mzip :: m st1
748 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
749 -- -> m (st1, (st2, st3))
750 --
751 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
752 = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
753 ; m_ty <- newFlexiTyVarTy star_star_kind
754
755 ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
756 (m_ty `mkAppTy` alphaTy)
757 `mkFunTy`
758 (m_ty `mkAppTy` betaTy)
759 `mkFunTy`
760 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
761 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
762
763 -- type dummies since we don't know all binder types yet
764 ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
765 [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
766
767 -- Typecheck bind:
768 ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
769 tuple_ty = mk_tuple_ty tup_tys
770
771 ; (((blocks', thing), inner_res_ty), bind_op')
772 <- tcSyntaxOp MCompOrigin bind_op
773 [ synKnownType (m_ty `mkAppTy` tuple_ty)
774 , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
775 \ [inner_res_ty] ->
776 do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
777 tup_tys bndr_stmts_s
778 ; return (stuff, inner_res_ty) }
779
780 ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) }
781
782 where
783 mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
784
785 -- loop :: Type -- m_ty
786 -- -> ExpRhoType -- inner_res_ty
787 -- -> [TcType] -- tup_tys
788 -- -> [ParStmtBlock Name]
789 -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
790 loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
791 ; return ([], thing) }
792 -- matching in the branches
793
794 loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
795 (ParStmtBlock x stmts names return_op : pairs)
796 = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
797 ; (stmts', (ids, return_op', pairs', thing))
798 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
799 \m_tup_ty' ->
800 do { ids <- tcLookupLocalIds names
801 ; let tup_ty = mkBigCoreVarTupTy ids
802 ; (_, return_op') <-
803 tcSyntaxOp MCompOrigin return_op
804 [synKnownType tup_ty] m_tup_ty' $
805 \ _ -> return ()
806 ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
807 ; return (ids, return_op', pairs', thing) }
808 ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
809 loop _ _ _ _ = panic "tcMcStmt.loop"
810
811 tcMcStmt _ stmt _ _
812 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
813
814
815 ---------------------------------------------------
816 -- Do-notation
817 -- (supports rebindable syntax)
818 ---------------------------------------------------
819
820 tcDoStmt :: TcExprStmtChecker
821
822 tcDoStmt _ (LastStmt body noret _) res_ty thing_inside
823 = do { body' <- tcMonoExprNC body res_ty
824 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
825 ; return (LastStmt body' noret noSyntaxExpr, thing) }
826
827 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
828 = do { -- Deal with rebindable syntax:
829 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
830 -- This level of generality is needed for using do-notation
831 -- in full generality; see Trac #1537
832
833 ((rhs', pat', new_res_ty, thing), bind_op')
834 <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
835 \ [rhs_ty, pat_ty, new_res_ty] ->
836 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
837 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
838 (mkCheckExpType pat_ty) $
839 thing_inside (mkCheckExpType new_res_ty)
840 ; return (rhs', pat', new_res_ty, thing) }
841
842 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
843 ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
844
845 ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
846
847 tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
848 = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
849 thing_inside . mkCheckExpType
850 ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
851 Nothing -> (, Nothing) <$> tc_app_stmts res_ty
852 Just join_op ->
853 second Just <$>
854 (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
855 \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
856
857 ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }
858
859 tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
860 = do { -- Deal with rebindable syntax;
861 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
862 ; ((rhs', rhs_ty, thing), then_op')
863 <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
864 \ [rhs_ty, new_res_ty] ->
865 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
866 ; thing <- thing_inside (mkCheckExpType new_res_ty)
867 ; return (rhs', rhs_ty, thing) }
868 ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
869
870 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
871 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
872 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
873 res_ty thing_inside
874 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
875 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
876 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
877 tup_ty = mkBigCoreTupTy tup_elt_tys
878
879 ; tcExtendIdEnv tup_ids $ do
880 { ((stmts', (ret_op', tup_rets)), stmts_ty)
881 <- tcInferInst $ \ exp_ty ->
882 tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
883 do { tup_rets <- zipWithM tcCheckId tup_names
884 (map mkCheckExpType tup_elt_tys)
885 -- Unify the types of the "final" Ids (which may
886 -- be polymorphic) with those of "knot-tied" Ids
887 ; (_, ret_op')
888 <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
889 inner_res_ty $ \_ -> return ()
890 ; return (ret_op', tup_rets) }
891
892 ; ((_, mfix_op'), mfix_res_ty)
893 <- tcInferInst $ \ exp_ty ->
894 tcSyntaxOp DoOrigin mfix_op
895 [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $
896 \ _ -> return ()
897
898 ; ((thing, new_res_ty), bind_op')
899 <- tcSyntaxOp DoOrigin bind_op
900 [ synKnownType mfix_res_ty
901 , synKnownType tup_ty `SynFun` SynRho ]
902 res_ty $
903 \ [new_res_ty] ->
904 do { thing <- thing_inside (mkCheckExpType new_res_ty)
905 ; return (thing, new_res_ty) }
906
907 ; let rec_ids = takeList rec_names tup_ids
908 ; later_ids <- tcLookupLocalIds later_names
909 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
910 ppr later_ids <+> ppr (map idType later_ids)]
911 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
912 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
913 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
914 , recS_bind_ty = new_res_ty
915 , recS_later_rets = [], recS_rec_rets = tup_rets
916 , recS_ret_ty = stmts_ty }, thing)
917 }}
918
919 tcDoStmt _ stmt _ _
920 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
921
922
923
924 ---------------------------------------------------
925 -- MonadFail Proposal warnings
926 ---------------------------------------------------
927
928 -- The idea behind issuing MonadFail warnings is that we add them whenever a
929 -- failable pattern is encountered. However, instead of throwing a type error
930 -- when the constraint cannot be satisfied, we only issue a warning in
931 -- TcErrors.hs.
932
933 tcMonadFailOp :: CtOrigin
934 -> LPat GhcTcId
935 -> SyntaxExpr GhcRn -- The fail op
936 -> TcType -- Type of the whole do-expression
937 -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op
938 -- Get a 'fail' operator expression, to use if the pattern
939 -- match fails. If the pattern is irrefutatable, just return
940 -- noSyntaxExpr; it won't be used
941 tcMonadFailOp orig pat fail_op res_ty
942 | isIrrefutableHsPat pat
943 = return noSyntaxExpr
944
945 | otherwise
946 = do { -- Issue MonadFail warnings
947 rebindableSyntax <- xoptM LangExt.RebindableSyntax
948 ; desugarFlag <- xoptM LangExt.MonadFailDesugaring
949 ; missingWarning <- woptM Opt_WarnMissingMonadFailInstances
950 ; if | rebindableSyntax && (desugarFlag || missingWarning)
951 -> warnRebindableClash pat
952 | not desugarFlag && missingWarning
953 -> emitMonadFailConstraint pat res_ty
954 | otherwise
955 -> return ()
956
957 -- Get the fail op itself
958 ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
959 (mkCheckExpType res_ty) $ \_ -> return ()) }
960
961 emitMonadFailConstraint :: LPat GhcTcId -> TcType -> TcRn ()
962 emitMonadFailConstraint pat res_ty
963 = do { -- We expect res_ty to be of form (monad_ty arg_ty)
964 (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty
965
966 -- Emit (MonadFail m), but ignore the evidence; it's
967 -- just there to generate a warning
968 ; monadFailClass <- tcLookupClass monadFailClassName
969 ; _ <- emitWanted (FailablePattern pat)
970 (mkClassPred monadFailClass [monad_ty])
971 ; return () }
972
973 warnRebindableClash :: LPat GhcTcId -> TcRn ()
974 warnRebindableClash pattern = addWarnAt
975 (Reason Opt_WarnMissingMonadFailInstances)
976 (getLoc pattern)
977 (text "The failable pattern" <+> quotes (ppr pattern)
978 $$
979 nest 2 (text "is used together with -XRebindableSyntax."
980 <+> text "If this is intentional,"
981 $$
982 text "compile with -Wno-missing-monadfail-instances."))
983
984 {-
985 Note [Treat rebindable syntax first]
986 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
987 When typechecking
988 do { bar; ... } :: IO ()
989 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
990 pushing info from the context into the RHS. To do this, we check the
991 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
992 Otherwise the error shows up when cheking the rebindable syntax, and
993 the expected/inferred stuff is back to front (see Trac #3613).
994
995 Note [typechecking ApplicativeStmt]
996
997 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
998
999 fresh type variables:
1000 pat_ty_1..pat_ty_n
1001 exp_ty_1..exp_ty_n
1002 t_1..t_(n-1)
1003
1004 body :: body_ty
1005 (\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
1006 pat_i :: pat_ty_i
1007 e_i :: exp_ty_i
1008 <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
1009 <*>_i :: t_(i-1) -> exp_ty_i -> t_i
1010 join :: tn -> res_ty
1011 -}
1012
1013 tcApplicativeStmts
1014 :: HsStmtContext Name
1015 -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
1016 -> ExpRhoType -- rhs_ty
1017 -> (TcRhoType -> TcM t) -- thing_inside
1018 -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
1019
1020 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
1021 = do { body_ty <- newFlexiTyVarTy liftedTypeKind
1022 ; let arity = length pairs
1023 ; ts <- replicateM (arity-1) $ newInferExpTypeInst
1024 ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1025 ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1026 ; let fun_ty = mkFunTys pat_tys body_ty
1027
1028 -- NB. do the <$>,<*> operators first, we don't want type errors here
1029 -- i.e. goOps before goArgs
1030 -- See Note [Treat rebindable syntax first]
1031 ; let (ops, args) = unzip pairs
1032 ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
1033
1034 -- Typecheck each ApplicativeArg separately
1035 -- See Note [ApplicativeDo and constraints]
1036 ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
1037
1038 -- Bring into scope all the things bound by the args,
1039 -- and typecheck the thing_inside
1040 -- See Note [ApplicativeDo and constraints]
1041 ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
1042 thing_inside body_ty
1043
1044 ; return (zip ops' args', body_ty, res) }
1045 where
1046 goOps _ [] = return []
1047 goOps t_left ((op,t_i,exp_ty) : ops)
1048 = do { (_, op')
1049 <- tcSyntaxOp DoOrigin op
1050 [synKnownType t_left, synKnownType exp_ty] t_i $
1051 \ _ -> return ()
1052 ; t_i <- readExpType t_i
1053 ; ops' <- goOps t_i ops
1054 ; return (op' : ops') }
1055
1056 goArg :: (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId)
1057
1058 goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty)
1059 = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
1060 addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $
1061 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
1062 ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
1063 return ()
1064 ; return (ApplicativeArgOne pat' rhs' isBody) }
1065
1066 goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty)
1067 = do { (stmts', (ret',pat')) <-
1068 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
1069 \res_ty -> do
1070 { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
1071 ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
1072 return ()
1073 ; return (ret', pat')
1074 }
1075 ; return (ApplicativeArgMany stmts' ret' pat') }
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
1081
1082 {- Note [ApplicativeDo and constraints]
1083 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1084 An applicative-do is supposed to take place in parallel, so
1085 constraints bound in one arm can't possibly be available in another
1086 (Trac #13242). Our current rule is this (more details and discussion
1087 on the ticket). Consider
1088
1089 ...stmts...
1090 ApplicativeStmts [arg1, arg2, ... argN]
1091 ...more stmts...
1092
1093 where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
1094 Now, we say that:
1095
1096 * Constraints required by the argi can be solved from
1097 constraint bound by ...stmts...
1098
1099 * Constraints and existentials bound by the argi are not available
1100 to solve constraints required either by argj (where i /= j),
1101 or by ...more stmts....
1102
1103 * Within the stmts of each 'argi' individually, however, constraints bound
1104 by earlier stmts can be used to solve later ones.
1105
1106 To achieve this, we just typecheck each 'argi' separately, bring all
1107 the variables they bind into scope, and typecheck the thing_inside.
1108
1109 ************************************************************************
1110 * *
1111 \subsection{Errors and contexts}
1112 * *
1113 ************************************************************************
1114
1115 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
1116 number of args are used in each equation.
1117 -}
1118
1119 checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
1120 checkArgs _ (MG { mg_alts = L _ [] })
1121 = return ()
1122 checkArgs fun (MG { mg_alts = L _ (match1:matches) })
1123 | null bad_matches
1124 = return ()
1125 | otherwise
1126 = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
1127 text "have different numbers of arguments"
1128 , nest 2 (ppr (getLoc match1))
1129 , nest 2 (ppr (getLoc (head bad_matches)))])
1130 where
1131 n_args1 = args_in_match match1
1132 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
1133
1134 args_in_match :: LMatch GhcRn body -> Int
1135 args_in_match (L _ (Match { m_pats = pats })) = length pats