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