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