Substantial improvements in RtClosureInspect
[ghc.git] / compiler / typecheck / TcMatches.lhs
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 \begin{code}
9 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
10                    TcMatchCtxt(..), 
11                    tcStmts, tcDoStmts, tcBody,
12                    tcDoStmt, tcMDoStmt, tcGuardStmt
13        ) where
14
15 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
16                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
17
18 import HsSyn
19 import TcRnMonad
20 import TcEnv
21 import TcPat
22 import TcMType
23 import TcType
24 import TcBinds
25 import TcUnify
26 import Name
27 import TysWiredIn
28 import Id
29 import TyCon
30 import TysPrim
31 import Coercion         ( mkSymCo )
32 import Outputable
33 import BasicTypes       ( Arity )
34 import Util
35 import SrcLoc
36 import FastString
37
38 import Control.Monad
39
40 #include "HsVersions.h"
41 \end{code}
42
43 %************************************************************************
44 %*                                                                      *
45 \subsection{tcMatchesFun, tcMatchesCase}
46 %*                                                                      *
47 %************************************************************************
48
49 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
50 @FunMonoBind@.  The second argument is the name of the function, which
51 is used in error messages.  It checks that all the equations have the
52 same number of arguments before using @tcMatches@ to do the work.
53
54 Note [Polymorphic expected type for tcMatchesFun]
55 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56 tcMatchesFun may be given a *sigma* (polymorphic) type
57 so it must be prepared to use tcGen to skolemise it.
58 See Note [sig_tau may be polymorphic] in TcPat.
59
60 \begin{code}
61 tcMatchesFun :: Name -> Bool
62              -> MatchGroup Name
63              -> TcSigmaType                        -- Expected type of function
64              -> TcM (HsWrapper, MatchGroup TcId)   -- Returns type of body
65 tcMatchesFun fun_name inf matches exp_ty
66   = do  {  -- Check that they all have the same no of arguments
67            -- Location is in the monad, set the caller so that 
68            -- any inter-equation error messages get some vaguely
69            -- sensible location.        Note: we have to do this odd
70            -- ann-grabbing, because we don't always have annotations in
71            -- hand when we call tcMatchesFun...
72           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
73         ; checkArgs fun_name matches
74
75         ; (wrap_gen, (wrap_fun, group)) 
76             <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
77                   -- Note [Polymorphic expected type for tcMatchesFun]
78                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> 
79                tcMatches match_ctxt pat_tys rhs_ty matches 
80         ; return (wrap_gen <.> wrap_fun, group) }
81   where
82     arity = matchGroupArity matches
83     herald = ptext (sLit "The equation(s) for")
84              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
85     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
86 \end{code}
87
88 @tcMatchesCase@ doesn't do the argument-count check because the
89 parser guarantees that each equation has exactly one argument.
90
91 \begin{code}
92 tcMatchesCase :: TcMatchCtxt            -- Case context
93               -> TcRhoType              -- Type of scrutinee
94               -> MatchGroup Name        -- The case alternatives
95               -> TcRhoType              -- Type of whole case expressions
96               -> TcM (MatchGroup TcId)  -- Translated alternatives
97
98 tcMatchesCase ctxt scrut_ty matches res_ty
99   | isEmptyMatchGroup matches   -- Allow empty case expressions
100   = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty)) 
101
102   | otherwise
103   = tcMatches ctxt [scrut_ty] res_ty matches
104
105 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
106 tcMatchLambda match res_ty 
107   = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
108     tcMatches match_ctxt pat_tys rhs_ty match
109   where
110     n_pats = matchGroupArity match
111     herald = sep [ ptext (sLit "The lambda expression")
112                          <+> quotes (pprSetDepth (PartWay 1) $ 
113                              pprMatches (LambdaExpr :: HsMatchContext Name) match),
114                         -- The pprSetDepth makes the abstraction print briefly
115                 ptext (sLit "has")]
116     match_ctxt = MC { mc_what = LambdaExpr,
117                       mc_body = tcBody }
118 \end{code}
119
120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
121
122 \begin{code}
123 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
124 -- Used for pattern bindings
125 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
126   where
127     match_ctxt = MC { mc_what = PatBindRhs,
128                       mc_body = tcBody }
129 \end{code}
130
131
132 \begin{code}
133 matchFunTys
134   :: SDoc       -- See Note [Herald for matchExpecteFunTys] in TcUnify
135   -> Arity
136   -> TcRhoType
137   -> ([TcSigmaType] -> TcRhoType -> TcM a)
138   -> TcM (HsWrapper, a)
139
140 -- Written in CPS style for historical reasons; 
141 -- could probably be un-CPSd, like matchExpectedTyConApp
142
143 matchFunTys herald arity res_ty thing_inside
144   = do  { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
145         ; res <- thing_inside pat_tys res_ty
146         ; return (coToHsWrapper (mkSymCo coi), res) }
147 \end{code}
148
149 %************************************************************************
150 %*                                                                      *
151 \subsection{tcMatch}
152 %*                                                                      *
153 %************************************************************************
154
155 \begin{code}
156 tcMatches :: TcMatchCtxt
157           -> [TcSigmaType]      -- Expected pattern types
158           -> TcRhoType          -- Expected result-type of the Match.
159           -> MatchGroup Name
160           -> TcM (MatchGroup TcId)
161
162 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
163   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
164          mc_body :: LHsExpr Name                -- Type checker for a body of
165                                                 -- an alternative
166                  -> TcRhoType
167                  -> TcM (LHsExpr TcId) }        
168
169 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
170   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
171     do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
172         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
173
174 -------------
175 tcMatch :: TcMatchCtxt
176         -> [TcSigmaType]        -- Expected pattern types
177         -> TcRhoType            -- Expected result-type of the Match.
178         -> LMatch Name
179         -> TcM (LMatch TcId)
180
181 tcMatch ctxt pat_tys rhs_ty match 
182   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
183   where
184     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
185       = add_match_ctxt match $
186         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
187                                 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
188            ; return (Match pats' Nothing grhss') }
189
190     tc_grhss ctxt Nothing grhss rhs_ty 
191       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
192
193         -- Result type sigs are no longer supported
194     tc_grhss _ (Just {}) _ _
195       = panic "tc_ghrss"        -- Rejected by renamer
196
197         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
198         -- so we don't want to add "In the lambda abstraction \x->e"
199     add_match_ctxt match thing_inside
200         = case mc_what ctxt of
201             LambdaExpr -> thing_inside
202             m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
203
204 -------------
205 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
206         -> TcM (GRHSs TcId)
207
208 -- Notice that we pass in the full res_ty, so that we get
209 -- good inference from simple things like
210 --      f = \(x::forall a.a->a) -> <stuff>
211 -- We used to force it to be a monotype when there was more than one guard
212 -- but we don't need to do that any more
213
214 tcGRHSs ctxt (GRHSs grhss binds) res_ty
215   = do  { (binds', grhss') <- tcLocalBinds binds $
216                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
217
218         ; return (GRHSs grhss' binds') }
219
220 -------------
221 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
222
223 tcGRHS ctxt res_ty (GRHS guards rhs)
224   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
225                              mc_body ctxt rhs
226         ; return (GRHS guards' rhs') }
227   where
228     stmt_ctxt  = PatGuard (mc_what ctxt)
229 \end{code}
230
231
232 %************************************************************************
233 %*                                                                      *
234 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
235 %*                                                                      *
236 %************************************************************************
237
238 \begin{code}
239 tcDoStmts :: HsStmtContext Name 
240           -> [LStmt Name]
241           -> LHsExpr Name
242           -> TcRhoType
243           -> TcM (HsExpr TcId)          -- Returns a HsDo
244 tcDoStmts ListComp stmts body res_ty
245   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
246         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts 
247                                      elt_ty $
248                              tcBody body
249         ; return $ mkHsWrapCo coi 
250                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
251
252 tcDoStmts PArrComp stmts body res_ty
253   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
254         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts 
255                                      elt_ty $
256                              tcBody body
257         ; return $ mkHsWrapCo coi 
258                      (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
259
260 tcDoStmts DoExpr stmts body res_ty
261   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
262                              tcBody body
263         ; return (HsDo DoExpr stmts' body' res_ty) }
264
265 tcDoStmts MDoExpr stmts body res_ty
266   = do  { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
267                              tcBody body
268         ; return (HsDo MDoExpr stmts' body' res_ty) }
269
270 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
271
272 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
273 tcBody body res_ty
274   = do  { traceTc "tcBody" (ppr res_ty)
275         ; body' <- tcMonoExpr body res_ty
276         ; return body' 
277         } 
278 \end{code}
279
280
281 %************************************************************************
282 %*                                                                      *
283 \subsection{tcStmts}
284 %*                                                                      *
285 %************************************************************************
286
287 \begin{code}
288 type TcStmtChecker
289   =  forall thing. HsStmtContext Name
290                 -> Stmt Name
291                 -> TcRhoType                    -- Result type for comprehension
292                 -> (TcRhoType -> TcM thing)     -- Checker for what follows the stmt
293                 -> TcM (Stmt TcId, thing)
294
295 tcStmts :: HsStmtContext Name
296         -> TcStmtChecker        -- NB: higher-rank type
297         -> [LStmt Name]
298         -> TcRhoType
299         -> (TcRhoType -> TcM thing)
300         -> TcM ([LStmt TcId], thing)
301
302 -- Note the higher-rank type.  stmt_chk is applied at different
303 -- types in the equations for tcStmts
304
305 tcStmts _ _ [] res_ty thing_inside
306   = do  { thing <- thing_inside res_ty
307         ; return ([], thing) }
308
309 -- LetStmts are handled uniformly, regardless of context
310 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
311   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
312                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
313         ; return (L loc (LetStmt binds') : stmts', thing) }
314
315 -- For the vanilla case, handle the location-setting part
316 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
317   = do  { (stmt', (stmts', thing)) <- 
318                 setSrcSpan loc                          $
319                 addErrCtxt (pprStmtInCtxt ctxt stmt)    $
320                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
321                 popErrCtxt                              $
322                 tcStmts ctxt stmt_chk stmts res_ty'     $
323                 thing_inside
324         ; return (L loc stmt' : stmts', thing) }
325
326 --------------------------------
327 --      Pattern guards
328 tcGuardStmt :: TcStmtChecker
329 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
330   = do  { guard' <- tcMonoExpr guard boolTy
331         ; thing  <- thing_inside res_ty
332         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
333
334 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
335   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
336         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
337                             thing_inside res_ty
338         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
339
340 tcGuardStmt _ stmt _ _
341   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
342
343
344 --------------------------------
345 --      List comprehensions and PArrays
346
347 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
348          -> TcStmtChecker
349
350 -- A generator, pat <- rhs
351 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
352  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
353         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
354         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
355                             thing_inside res_ty
356         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
357
358 -- A boolean guard
359 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
360   = do  { rhs'  <- tcMonoExpr rhs boolTy
361         ; thing <- thing_inside res_ty
362         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
363
364 -- A parallel set of comprehensions
365 --      [ (g x, h x) | ... ; let g v = ...
366 --                   | ... ; let h v = ... ]
367 --
368 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
369 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
370 -- Similarly if we had an existential pattern match:
371 --
372 --      data T = forall a. Show a => C a
373 --
374 --      [ (show x, show y) | ... ; C x <- ...
375 --                         | ... ; C y <- ... ]
376 --
377 -- Then we need the LIE from (show x, show y) to be simplified against
378 -- the bindings for x and y.  
379 -- 
380 -- It's difficult to do this in parallel, so we rely on the renamer to 
381 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
382 -- So the binders of the first parallel group will be in scope in the second
383 -- group.  But that's fine; there's no shadowing to worry about.
384
385 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
386   = do  { (pairs', thing) <- loop bndr_stmts_s
387         ; return (ParStmt pairs', thing) }
388   where
389     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
390     loop [] = do { thing <- thing_inside elt_ty
391                  ; return ([], thing) }         -- matching in the branches
392
393     loop ((stmts, names) : pairs)
394       = do { (stmts', (ids, pairs', thing))
395                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
396                    do { ids <- tcLookupLocalIds names
397                       ; (pairs', thing) <- loop pairs
398                       ; return (ids, pairs', thing) }
399            ; return ( (stmts', ids) : pairs', thing ) }
400
401 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
402     (stmts', (binders', usingExpr', maybeByExpr', thing)) <- 
403         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
404             let alphaListTy = mkTyConApp m_tc [alphaTy]
405                     
406             (usingExpr', maybeByExpr') <- 
407                 case maybeByExpr of
408                     Nothing -> do
409                         -- We must validate that usingExpr :: forall a. [a] -> [a]
410                         let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
411                         usingExpr' <- tcPolyExpr usingExpr using_ty
412                         return (usingExpr', Nothing)
413                     Just byExpr -> do
414                         -- We must infer a type such that e :: t and then check that 
415                         -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
416                         (byExpr', tTy) <- tcInferRhoNC byExpr
417                         let using_ty = mkForAllTy alphaTyVar $ 
418                                        (alphaTy `mkFunTy` tTy)
419                                        `mkFunTy` alphaListTy `mkFunTy` alphaListTy
420                         usingExpr' <- tcPolyExpr usingExpr using_ty
421                         return (usingExpr', Just byExpr')
422             
423             binders' <- tcLookupLocalIds binders
424             thing <- thing_inside elt_ty'
425             
426             return (binders', usingExpr', maybeByExpr', thing)
427
428     return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
429
430 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
431   = do { let (bndr_names, list_bndr_names) = unzip bindersMap
432
433        ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
434             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
435                 (by', using_ty) <- 
436                    case by of
437                      Nothing   -> -- check that using :: forall a. [a] -> [[a]]
438                                   return (Nothing, mkForAllTy alphaTyVar $
439                                                    alphaListTy `mkFunTy` alphaListListTy)
440                                         
441                      Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
442                                   -- where by :: t
443                                   do { (by_e', t_ty) <- tcInferRhoNC by_e
444                                      ; return (Just by_e', mkForAllTy alphaTyVar $
445                                                            (alphaTy `mkFunTy` t_ty) 
446                                                            `mkFunTy` alphaListTy 
447                                                            `mkFunTy` alphaListListTy) }
448                 -- Find the Ids (and hence types) of all old binders
449                 bndr_ids <- tcLookupLocalIds bndr_names
450                 
451                 return (bndr_ids, by', using_ty, elt_ty')
452         
453                 -- Ensure that every old binder of type b is linked up with
454                 -- its new binder which should have type [b]
455        ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
456              bindersMap' = bndr_ids `zip` list_bndr_ids
457              -- See Note [GroupStmt binder map] in HsExpr
458             
459        ; using' <- case using of
460                      Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
461                      Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
462
463              -- Type check the thing in the environment with 
464              -- these new binders and return the result
465        ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
466        ; return (GroupStmt stmts' bindersMap' by' using', thing) }
467   where
468     alphaListTy = mkTyConApp m_tc [alphaTy]
469     alphaListListTy = mkTyConApp m_tc [alphaListTy]
470             
471     mk_list_bndr :: Name -> TcId -> TcId
472     mk_list_bndr list_bndr_name bndr_id 
473       = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
474     
475 tcLcStmt _ _ stmt _ _
476   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
477         
478 --------------------------------
479 --      Do-notation
480 -- The main excitement here is dealing with rebindable syntax
481
482 tcDoStmt :: TcStmtChecker
483
484 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
485   = do  {       -- Deal with rebindable syntax:
486                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
487                 -- This level of generality is needed for using do-notation
488                 -- in full generality; see Trac #1537
489
490                 -- I'd like to put this *after* the tcSyntaxOp 
491                 -- (see Note [Treat rebindable syntax first], but that breaks 
492                 -- the rigidity info for GADTs.  When we move to the new story
493                 -- for GADTs, we can move this after tcSyntaxOp
494           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
495         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
496         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
497         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op 
498                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
499
500                 -- If (but only if) the pattern can fail, 
501                 -- typecheck the 'fail' operator
502         ; fail_op' <- if isIrrefutableHsPat pat 
503                       then return noSyntaxExpr
504                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
505
506         ; rhs' <- tcMonoExprNC rhs rhs_ty
507         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
508                            thing_inside new_res_ty
509
510         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
511
512
513 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
514   = do  {       -- Deal with rebindable syntax; 
515                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
516                 -- See also Note [Treat rebindable syntax first]
517           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
518         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
519         ; then_op' <- tcSyntaxOp DoOrigin then_op 
520                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
521
522         ; rhs' <- tcMonoExprNC rhs rhs_ty
523         ; thing <- thing_inside new_res_ty
524         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
525
526 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
527                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
528                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) 
529          res_ty thing_inside
530   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
531         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
532         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
533               tup_ty  = mkBoxedTupleTy tup_elt_tys
534
535         ; tcExtendIdEnv tup_ids $ do
536         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
537         ; (stmts', (ret_op', tup_rets))
538                 <- tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
539                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
540                              -- Unify the types of the "final" Ids (which may 
541                              -- be polymorphic) with those of "knot-tied" Ids
542                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
543                       ; return (ret_op', tup_rets) }
544
545         ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
546         ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
547                                  (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
548
549         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
550         ; bind_op' <- tcSyntaxOp DoOrigin bind_op 
551                                  (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
552
553         ; thing <- thing_inside new_res_ty
554 --         ; lie_binds <- bindLocalMethods lie tup_ids
555   
556         ; let rec_ids = takeList rec_names tup_ids
557         ; later_ids <- tcLookupLocalIds later_names
558         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
559                                  ppr later_ids <+> ppr (map idType later_ids)]
560         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
561                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' 
562                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
563                           , recS_rec_rets = tup_rets }, thing)
564         }}
565
566 tcDoStmt _ stmt _ _
567   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
568 \end{code}
569
570 Note [Treat rebindable syntax first]
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572 When typechecking
573         do { bar; ... } :: IO ()
574 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
575 pushing info from the context into the RHS.  To do this, we check the
576 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
577 Otherwise the error shows up when cheking the rebindable syntax, and
578 the expected/inferred stuff is back to front (see Trac #3613).
579
580 \begin{code}
581 --------------------------------
582 --      Mdo-notation
583 -- The distinctive features here are
584 --      (a) RecStmts, and
585 --      (b) no rebindable syntax
586
587 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
588           -> TcStmtChecker
589 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
590   = do  { (rhs', pat_ty) <- tc_rhs rhs
591         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
592                             thing_inside res_ty
593         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
594
595 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
596   = do  { (rhs', elt_ty) <- tc_rhs rhs
597         ; thing          <- thing_inside res_ty
598         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
599
600 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
601                                , recS_rec_ids = recNames }) res_ty thing_inside
602   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
603         ; let rec_ids = zipWith mkLocalId recNames rec_tys
604         ; tcExtendIdEnv rec_ids                 $ do
605         { (stmts', (later_ids, rec_rets))
606                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
607                         -- ToDo: res_ty not really right
608                    do { rec_rets <- zipWithM tcCheckId recNames rec_tys
609                       ; later_ids <- tcLookupLocalIds laterNames
610                       ; return (later_ids, rec_rets) }
611
612         ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
613                 -- NB:  The rec_ids for the recursive things 
614                 --      already scope over this part. This binding may shadow
615                 --      some of them with polymorphic things with the same Name
616                 --      (see note [RecStmt] in HsExpr)
617
618         ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
619         }}
620
621 tcMDoStmt _ _ stmt _ _
622   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
623 \end{code}
624
625
626 %************************************************************************
627 %*                                                                      *
628 \subsection{Errors and contexts}
629 %*                                                                      *
630 %************************************************************************
631
632 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
633 number of args are used in each equation.
634
635 \begin{code}
636 checkArgs :: Name -> MatchGroup Name -> TcM ()
637 checkArgs fun (MatchGroup (match1:matches) _)
638     | null bad_matches = return ()
639     | otherwise
640     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> 
641                           ptext (sLit "have different numbers of arguments"),
642                         nest 2 (ppr (getLoc match1)),
643                         nest 2 (ppr (getLoc (head bad_matches)))])
644   where
645     n_args1 = args_in_match match1
646     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
647
648     args_in_match :: LMatch Name -> Int
649     args_in_match (L _ (Match pats _ _)) = length pats
650 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
651 \end{code}
652