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