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