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