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