Merge commit '5229c43ccf77bcbffeced01dccb27398d017fa34'
[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 ListComp (L l stmts') list_ty) }
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 PArrComp (L l stmts') parr_ty) }
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 DoExpr (L l stmts') res_ty) }
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 MDoExpr (L l stmts') res_ty) }
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 MonadComp (L l stmts') res_ty) }
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 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 stmts' ids noSyntaxExpr : pairs', thing ) }
478
479 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
480 , trS_bndrs = bindersMap
481 , trS_by = by, trS_using = using }) elt_ty thing_inside
482 = do { let (bndr_names, n_bndr_names) = unzip bindersMap
483 unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
484 -- The inner 'stmts' lack a LastStmt, so the element type
485 -- passed in to tcStmtsAndThen is never looked at
486 ; (stmts', (bndr_ids, by'))
487 <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
488 { by' <- traverse tcInferSigma by
489 ; bndr_ids <- tcLookupLocalIds bndr_names
490 ; return (bndr_ids, by') }
491
492 ; let m_app ty = mkTyConApp m_tc [ty]
493
494 --------------- Typecheck the 'using' function -------------
495 -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
496 -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
497
498 -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
499 ; let n_app = case form of
500 ThenForm -> (\ty -> ty)
501 _ -> m_app
502
503 by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
504 by_arrow = case by' of
505 Nothing -> \ty -> ty
506 Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
507
508 tup_ty = mkBigCoreVarTupTy bndr_ids
509 poly_arg_ty = m_app alphaTy
510 poly_res_ty = m_app (n_app alphaTy)
511 using_poly_ty = mkInvForAllTy alphaTyVar $
512 by_arrow $
513 poly_arg_ty `mkFunTy` poly_res_ty
514
515 ; using' <- tcPolyExpr using using_poly_ty
516 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
517
518 -- 'stmts' returns a result of type (m1_ty tuple_ty),
519 -- typically something like [(Int,Bool,Int)]
520 -- We don't know what tuple_ty is yet, so we use a variable
521 ; let mk_n_bndr :: Name -> TcId -> TcId
522 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
523
524 -- Ensure that every old binder of type `b` is linked up with its
525 -- new binder which should have type `n b`
526 -- See Note [GroupStmt binder map] in HsExpr
527 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
528 bindersMap' = bndr_ids `zip` n_bndr_ids
529
530 -- Type check the thing in the environment with
531 -- these new binders and return the result
532 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
533
534 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
535 , trS_by = fmap fst by', trS_using = final_using
536 , trS_ret = noSyntaxExpr
537 , trS_bind = noSyntaxExpr
538 , trS_fmap = noExpr
539 , trS_bind_arg_ty = unitTy
540 , trS_form = form }, thing) }
541
542 tcLcStmt _ _ stmt _ _
543 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
544
545
546 ---------------------------------------------------
547 -- Monad comprehensions
548 -- (supports rebindable syntax)
549 ---------------------------------------------------
550
551 tcMcStmt :: TcExprStmtChecker
552
553 tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
554 = do { (body', return_op')
555 <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
556 \ [a_ty] ->
557 tcMonoExprNC body (mkCheckExpType a_ty)
558 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
559 ; return (LastStmt body' noret return_op', thing) }
560
561 -- Generators for monad comprehensions ( pat <- rhs )
562 --
563 -- [ body | q <- gen ] -> gen :: m a
564 -- q :: a
565 --
566
567 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
568 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
569 = do { ((rhs', pat', thing, new_res_ty), bind_op')
570 <- tcSyntaxOp MCompOrigin bind_op
571 [SynRho, SynFun SynAny SynRho] res_ty $
572 \ [rhs_ty, pat_ty, new_res_ty] ->
573 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
574 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
575 (mkCheckExpType pat_ty) $
576 thing_inside (mkCheckExpType new_res_ty)
577 ; return (rhs', pat', thing, new_res_ty) }
578
579 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
580 ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
581
582 ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
583
584 -- Boolean expressions.
585 --
586 -- [ body | stmts, expr ] -> expr :: m Bool
587 --
588 tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
589 = do { -- Deal with rebindable syntax:
590 -- guard_op :: test_ty -> rhs_ty
591 -- then_op :: rhs_ty -> new_res_ty -> res_ty
592 -- Where test_ty is, for example, Bool
593 ; ((thing, rhs', rhs_ty, guard_op'), then_op')
594 <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
595 \ [rhs_ty, new_res_ty] ->
596 do { (rhs', guard_op')
597 <- tcSyntaxOp MCompOrigin guard_op [SynAny]
598 (mkCheckExpType rhs_ty) $
599 \ [test_ty] ->
600 tcMonoExpr rhs (mkCheckExpType test_ty)
601 ; thing <- thing_inside (mkCheckExpType new_res_ty)
602 ; return (thing, rhs', rhs_ty, guard_op') }
603 ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) }
604
605 -- Grouping statements
606 --
607 -- [ body | stmts, then group by e using f ]
608 -- -> e :: t
609 -- f :: forall a. (a -> t) -> m a -> m (m a)
610 -- [ body | stmts, then group using f ]
611 -- -> f :: forall a. m a -> m (m a)
612
613 -- We type [ body | (stmts, group by e using f), ... ]
614 -- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
615 --
616 -- We type the functions as follows:
617 -- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
618 -- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
619 -- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
620 -- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
621 --
622 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
623 , trS_by = by, trS_using = using, trS_form = form
624 , trS_ret = return_op, trS_bind = bind_op
625 , trS_fmap = fmap_op }) res_ty thing_inside
626 = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
627 ; m1_ty <- newFlexiTyVarTy star_star_kind
628 ; m2_ty <- newFlexiTyVarTy star_star_kind
629 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
630 ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
631
632 -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
633 ; n_app <- case form of
634 ThenForm -> return (\ty -> ty)
635 _ -> do { n_ty <- newFlexiTyVarTy star_star_kind
636 ; return (n_ty `mkAppTy`) }
637 ; let by_arrow :: Type -> Type
638 -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
639 -- or res ('by' absent)
640 by_arrow = case by of
641 Nothing -> \res -> res
642 Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
643
644 poly_arg_ty = m1_ty `mkAppTy` alphaTy
645 using_arg_ty = m1_ty `mkAppTy` tup_ty
646 poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
647 using_res_ty = m2_ty `mkAppTy` n_app tup_ty
648 using_poly_ty = mkInvForAllTy alphaTyVar $
649 by_arrow $
650 poly_arg_ty `mkFunTy` poly_res_ty
651
652 -- 'stmts' returns a result of type (m1_ty tuple_ty),
653 -- typically something like [(Int,Bool,Int)]
654 -- We don't know what tuple_ty is yet, so we use a variable
655 ; let (bndr_names, n_bndr_names) = unzip bindersMap
656 ; (stmts', (bndr_ids, by', return_op')) <-
657 tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
658 (mkCheckExpType using_arg_ty) $ \res_ty' -> do
659 { by' <- case by of
660 Nothing -> return Nothing
661 Just e -> do { e' <- tcMonoExpr e
662 (mkCheckExpType by_e_ty)
663 ; return (Just e') }
664
665 -- Find the Ids (and hence types) of all old binders
666 ; bndr_ids <- tcLookupLocalIds bndr_names
667
668 -- 'return' is only used for the binders, so we know its type.
669 -- return :: (a,b,c,..) -> m (a,b,c,..)
670 ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
671 [synKnownType (mkBigCoreVarTupTy bndr_ids)]
672 res_ty' $ \ _ -> return ()
673
674 ; return (bndr_ids, by', return_op') }
675
676 --------------- Typecheck the 'bind' function -------------
677 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
678 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
679 ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
680 [ synKnownType using_res_ty
681 , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]
682 res_ty $ \ _ -> return ()
683
684 --------------- Typecheck the 'fmap' function -------------
685 ; fmap_op' <- case form of
686 ThenForm -> return noExpr
687 _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
688 mkInvForAllTy alphaTyVar $
689 mkInvForAllTy betaTyVar $
690 (alphaTy `mkFunTy` betaTy)
691 `mkFunTy` (n_app alphaTy)
692 `mkFunTy` (n_app betaTy)
693
694 --------------- Typecheck the 'using' function -------------
695 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
696
697 ; using' <- tcPolyExpr using using_poly_ty
698 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
699
700 --------------- Bulding the bindersMap ----------------
701 ; let mk_n_bndr :: Name -> TcId -> TcId
702 mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
703
704 -- Ensure that every old binder of type `b` is linked up with its
705 -- new binder which should have type `n b`
706 -- See Note [GroupStmt binder map] in HsExpr
707 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
708 bindersMap' = bndr_ids `zip` n_bndr_ids
709
710 -- Type check the thing in the environment with
711 -- these new binders and return the result
712 ; thing <- tcExtendIdEnv n_bndr_ids $
713 thing_inside (mkCheckExpType new_res_ty)
714
715 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
716 , trS_by = by', trS_using = final_using
717 , trS_ret = return_op', trS_bind = bind_op'
718 , trS_bind_arg_ty = n_app tup_ty
719 , trS_fmap = fmap_op', trS_form = form }, thing) }
720
721 -- A parallel set of comprehensions
722 -- [ (g x, h x) | ... ; let g v = ...
723 -- | ... ; let h v = ... ]
724 --
725 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
726 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
727 -- Similarly if we had an existential pattern match:
728 --
729 -- data T = forall a. Show a => C a
730 --
731 -- [ (show x, show y) | ... ; C x <- ...
732 -- | ... ; C y <- ... ]
733 --
734 -- Then we need the LIE from (show x, show y) to be simplified against
735 -- the bindings for x and y.
736 --
737 -- It's difficult to do this in parallel, so we rely on the renamer to
738 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
739 -- So the binders of the first parallel group will be in scope in the second
740 -- group. But that's fine; there's no shadowing to worry about.
741 --
742 -- Note: The `mzip` function will get typechecked via:
743 --
744 -- ParStmt [st1::t1, st2::t2, st3::t3]
745 --
746 -- mzip :: m st1
747 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
748 -- -> m (st1, (st2, st3))
749 --
750 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
751 = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
752 ; m_ty <- newFlexiTyVarTy star_star_kind
753
754 ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
755 (m_ty `mkAppTy` alphaTy)
756 `mkFunTy`
757 (m_ty `mkAppTy` betaTy)
758 `mkFunTy`
759 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
760 ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
761
762 -- type dummies since we don't know all binder types yet
763 ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
764 [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
765
766 -- Typecheck bind:
767 ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
768 tuple_ty = mk_tuple_ty tup_tys
769
770 ; (((blocks', thing), inner_res_ty), bind_op')
771 <- tcSyntaxOp MCompOrigin bind_op
772 [ synKnownType (m_ty `mkAppTy` tuple_ty)
773 , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
774 \ [inner_res_ty] ->
775 do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
776 tup_tys bndr_stmts_s
777 ; return (stuff, inner_res_ty) }
778
779 ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) }
780
781 where
782 mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
783
784 -- loop :: Type -- m_ty
785 -- -> ExpRhoType -- inner_res_ty
786 -- -> [TcType] -- tup_tys
787 -- -> [ParStmtBlock Name]
788 -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
789 loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
790 ; return ([], thing) }
791 -- matching in the branches
792
793 loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
794 (ParStmtBlock stmts names return_op : pairs)
795 = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
796 ; (stmts', (ids, return_op', pairs', thing))
797 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
798 \m_tup_ty' ->
799 do { ids <- tcLookupLocalIds names
800 ; let tup_ty = mkBigCoreVarTupTy ids
801 ; (_, return_op') <-
802 tcSyntaxOp MCompOrigin return_op
803 [synKnownType tup_ty] m_tup_ty' $
804 \ _ -> return ()
805 ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
806 ; return (ids, return_op', pairs', thing) }
807 ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
808 loop _ _ _ _ = panic "tcMcStmt.loop"
809
810 tcMcStmt _ stmt _ _
811 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
812
813
814 ---------------------------------------------------
815 -- Do-notation
816 -- (supports rebindable syntax)
817 ---------------------------------------------------
818
819 tcDoStmt :: TcExprStmtChecker
820
821 tcDoStmt _ (LastStmt body noret _) res_ty thing_inside
822 = do { body' <- tcMonoExprNC body res_ty
823 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
824 ; return (LastStmt body' noret noSyntaxExpr, thing) }
825
826 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
827 = do { -- Deal with rebindable syntax:
828 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
829 -- This level of generality is needed for using do-notation
830 -- in full generality; see Trac #1537
831
832 ((rhs', pat', new_res_ty, thing), bind_op')
833 <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
834 \ [rhs_ty, pat_ty, new_res_ty] ->
835 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
836 ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
837 (mkCheckExpType pat_ty) $
838 thing_inside (mkCheckExpType new_res_ty)
839 ; return (rhs', pat', new_res_ty, thing) }
840
841 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
842 ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
843
844 ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
845
846 tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
847 = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
848 thing_inside . mkCheckExpType
849 ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
850 Nothing -> (, Nothing) <$> tc_app_stmts res_ty
851 Just join_op ->
852 second Just <$>
853 (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
854 \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
855
856 ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }
857
858 tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
859 = do { -- Deal with rebindable syntax;
860 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
861 ; ((rhs', rhs_ty, thing), then_op')
862 <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
863 \ [rhs_ty, new_res_ty] ->
864 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
865 ; thing <- thing_inside (mkCheckExpType new_res_ty)
866 ; return (rhs', rhs_ty, thing) }
867 ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
868
869 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
870 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
871 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
872 res_ty thing_inside
873 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
874 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
875 ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
876 tup_ty = mkBigCoreTupTy tup_elt_tys
877
878 ; tcExtendIdEnv tup_ids $ do
879 { ((stmts', (ret_op', tup_rets)), stmts_ty)
880 <- tcInferInst $ \ exp_ty ->
881 tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
882 do { tup_rets <- zipWithM tcCheckId tup_names
883 (map mkCheckExpType tup_elt_tys)
884 -- Unify the types of the "final" Ids (which may
885 -- be polymorphic) with those of "knot-tied" Ids
886 ; (_, ret_op')
887 <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
888 inner_res_ty $ \_ -> return ()
889 ; return (ret_op', tup_rets) }
890
891 ; ((_, mfix_op'), mfix_res_ty)
892 <- tcInferInst $ \ exp_ty ->
893 tcSyntaxOp DoOrigin mfix_op
894 [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $
895 \ _ -> return ()
896
897 ; ((thing, new_res_ty), bind_op')
898 <- tcSyntaxOp DoOrigin bind_op
899 [ synKnownType mfix_res_ty
900 , synKnownType tup_ty `SynFun` SynRho ]
901 res_ty $
902 \ [new_res_ty] ->
903 do { thing <- thing_inside (mkCheckExpType new_res_ty)
904 ; return (thing, new_res_ty) }
905
906 ; let rec_ids = takeList rec_names tup_ids
907 ; later_ids <- tcLookupLocalIds later_names
908 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
909 ppr later_ids <+> ppr (map idType later_ids)]
910 ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
911 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
912 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
913 , recS_bind_ty = new_res_ty
914 , recS_later_rets = [], recS_rec_rets = tup_rets
915 , recS_ret_ty = stmts_ty }, thing)
916 }}
917
918 tcDoStmt _ stmt _ _
919 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
920
921
922
923 ---------------------------------------------------
924 -- MonadFail Proposal warnings
925 ---------------------------------------------------
926
927 -- The idea behind issuing MonadFail warnings is that we add them whenever a
928 -- failable pattern is encountered. However, instead of throwing a type error
929 -- when the constraint cannot be satisfied, we only issue a warning in
930 -- TcErrors.hs.
931
932 tcMonadFailOp :: CtOrigin
933 -> LPat GhcTcId
934 -> SyntaxExpr GhcRn -- The fail op
935 -> TcType -- Type of the whole do-expression
936 -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op
937 -- Get a 'fail' operator expression, to use if the pattern
938 -- match fails. If the pattern is irrefutatable, just return
939 -- noSyntaxExpr; it won't be used
940 tcMonadFailOp orig pat fail_op res_ty
941 | isIrrefutableHsPat pat
942 = return noSyntaxExpr
943
944 | otherwise
945 = do { -- Issue MonadFail warnings
946 rebindableSyntax <- xoptM LangExt.RebindableSyntax
947 ; desugarFlag <- xoptM LangExt.MonadFailDesugaring
948 ; missingWarning <- woptM Opt_WarnMissingMonadFailInstances
949 ; if | rebindableSyntax && (desugarFlag || missingWarning)
950 -> warnRebindableClash pat
951 | not desugarFlag && missingWarning
952 -> emitMonadFailConstraint pat res_ty
953 | otherwise
954 -> return ()
955
956 -- Get the fail op itself
957 ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
958 (mkCheckExpType res_ty) $ \_ -> return ()) }
959
960 emitMonadFailConstraint :: LPat GhcTcId -> TcType -> TcRn ()
961 emitMonadFailConstraint pat res_ty
962 = do { -- We expect res_ty to be of form (monad_ty arg_ty)
963 (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty
964
965 -- Emit (MonadFail m), but ignore the evidence; it's
966 -- just there to generate a warning
967 ; monadFailClass <- tcLookupClass monadFailClassName
968 ; _ <- emitWanted (FailablePattern pat)
969 (mkClassPred monadFailClass [monad_ty])
970 ; return () }
971
972 warnRebindableClash :: LPat GhcTcId -> TcRn ()
973 warnRebindableClash pattern = addWarnAt
974 (Reason Opt_WarnMissingMonadFailInstances)
975 (getLoc pattern)
976 (text "The failable pattern" <+> quotes (ppr pattern)
977 $$
978 nest 2 (text "is used together with -XRebindableSyntax."
979 <+> text "If this is intentional,"
980 $$
981 text "compile with -Wno-missing-monadfail-instances."))
982
983 {-
984 Note [Treat rebindable syntax first]
985 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
986 When typechecking
987 do { bar; ... } :: IO ()
988 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
989 pushing info from the context into the RHS. To do this, we check the
990 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
991 Otherwise the error shows up when cheking the rebindable syntax, and
992 the expected/inferred stuff is back to front (see Trac #3613).
993
994 Note [typechecking ApplicativeStmt]
995
996 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
997
998 fresh type variables:
999 pat_ty_1..pat_ty_n
1000 exp_ty_1..exp_ty_n
1001 t_1..t_(n-1)
1002
1003 body :: body_ty
1004 (\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
1005 pat_i :: pat_ty_i
1006 e_i :: exp_ty_i
1007 <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
1008 <*>_i :: t_(i-1) -> exp_ty_i -> t_i
1009 join :: tn -> res_ty
1010 -}
1011
1012 tcApplicativeStmts
1013 :: HsStmtContext Name
1014 -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)]
1015 -> ExpRhoType -- rhs_ty
1016 -> (TcRhoType -> TcM t) -- thing_inside
1017 -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t)
1018
1019 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
1020 = do { body_ty <- newFlexiTyVarTy liftedTypeKind
1021 ; let arity = length pairs
1022 ; ts <- replicateM (arity-1) $ newInferExpTypeInst
1023 ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1024 ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1025 ; let fun_ty = mkFunTys pat_tys body_ty
1026
1027 -- NB. do the <$>,<*> operators first, we don't want type errors here
1028 -- i.e. goOps before goArgs
1029 -- See Note [Treat rebindable syntax first]
1030 ; let (ops, args) = unzip pairs
1031 ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
1032
1033 -- Typecheck each ApplicativeArg separately
1034 -- See Note [ApplicativeDo and constraints]
1035 ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
1036
1037 -- Bring into scope all the things bound by the args,
1038 -- and typecheck the thing_inside
1039 -- See Note [ApplicativeDo and constraints]
1040 ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
1041 thing_inside body_ty
1042
1043 ; return (zip ops' args', body_ty, res) }
1044 where
1045 goOps _ [] = return []
1046 goOps t_left ((op,t_i,exp_ty) : ops)
1047 = do { (_, op')
1048 <- tcSyntaxOp DoOrigin op
1049 [synKnownType t_left, synKnownType exp_ty] t_i $
1050 \ _ -> return ()
1051 ; t_i <- readExpType t_i
1052 ; ops' <- goOps t_i ops
1053 ; return (op' : ops') }
1054
1055 goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type)
1056 -> TcM (ApplicativeArg GhcTcId 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 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