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