Improve dead block calculation, per Simon Marlow's advice.
[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_GHC -w #-}   -- debugging
10 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
11                    TcMatchCtxt(..), TcStmtChecker,
12                    tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
13                    tcDoStmt, tcGuardStmt
14        ) where
15
16 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
17                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
18
19 import HsSyn
20 import BasicTypes
21 import TcRnMonad
22 import TcEnv
23 import TcPat
24 import TcMType
25 import TcType
26 import TcBinds
27 import TcUnify
28 import Name
29 import TysWiredIn
30 import Id
31 import TyCon
32 import TysPrim
33 import Coercion         ( isIdentityCoI, mkSymCoI )
34 import Outputable
35 import Util
36 import SrcLoc
37 import FastString
38
39 -- Create chunkified tuple tybes for monad comprehensions
40 import MkCore
41
42 import Control.Monad
43
44 #include "HsVersions.h"
45 \end{code}
46
47 %************************************************************************
48 %*                                                                      *
49 \subsection{tcMatchesFun, tcMatchesCase}
50 %*                                                                      *
51 %************************************************************************
52
53 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
54 @FunMonoBind@.  The second argument is the name of the function, which
55 is used in error messages.  It checks that all the equations have the
56 same number of arguments before using @tcMatches@ to do the work.
57
58 Note [Polymorphic expected type for tcMatchesFun]
59 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60 tcMatchesFun may be given a *sigma* (polymorphic) type
61 so it must be prepared to use tcGen to skolemise it.
62 See Note [sig_tau may be polymorphic] in TcPat.
63
64 \begin{code}
65 tcMatchesFun :: Name -> Bool
66              -> MatchGroup Name
67              -> TcSigmaType                        -- Expected type of function
68              -> TcM (HsWrapper, MatchGroup TcId)   -- Returns type of body
69 tcMatchesFun fun_name inf matches exp_ty
70   = do  {  -- Check that they all have the same no of arguments
71            -- Location is in the monad, set the caller so that 
72            -- any inter-equation error messages get some vaguely
73            -- sensible location.        Note: we have to do this odd
74            -- ann-grabbing, because we don't always have annotations in
75            -- hand when we call tcMatchesFun...
76           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
77         ; checkArgs fun_name matches
78
79         ; (wrap_gen, (wrap_fun, group)) 
80             <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
81                   -- Note [Polymorphic expected type for tcMatchesFun]
82                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> 
83                tcMatches match_ctxt pat_tys rhs_ty matches 
84         ; return (wrap_gen <.> wrap_fun, group) }
85   where
86     arity = matchGroupArity matches
87     herald = ptext (sLit "The equation(s) for")
88              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
89     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
90 \end{code}
91
92 @tcMatchesCase@ doesn't do the argument-count check because the
93 parser guarantees that each equation has exactly one argument.
94
95 \begin{code}
96 tcMatchesCase :: TcMatchCtxt            -- Case context
97               -> TcRhoType              -- Type of scrutinee
98               -> MatchGroup Name        -- The case alternatives
99               -> TcRhoType              -- Type of whole case expressions
100               -> TcM (MatchGroup TcId)  -- Translated alternatives
101
102 tcMatchesCase ctxt scrut_ty matches res_ty
103   | isEmptyMatchGroup matches   -- Allow empty case expressions
104   = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty)) 
105
106   | otherwise
107   = tcMatches ctxt [scrut_ty] res_ty matches
108
109 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
110 tcMatchLambda match res_ty 
111   = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
112     tcMatches match_ctxt pat_tys rhs_ty match
113   where
114     n_pats = matchGroupArity match
115     herald = sep [ ptext (sLit "The lambda expression")
116                          <+> quotes (pprSetDepth (PartWay 1) $ 
117                              pprMatches (LambdaExpr :: HsMatchContext Name) match),
118                         -- The pprSetDepth makes the abstraction print briefly
119                 ptext (sLit "has")]
120     match_ctxt = MC { mc_what = LambdaExpr,
121                       mc_body = tcBody }
122 \end{code}
123
124 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
125
126 \begin{code}
127 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
128 -- Used for pattern bindings
129 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
130   where
131     match_ctxt = MC { mc_what = PatBindRhs,
132                       mc_body = tcBody }
133 \end{code}
134
135
136 \begin{code}
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  { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
149         ; res <- thing_inside pat_tys res_ty
150         ; return (coiToHsWrapper (mkSymCoI coi), res) }
151 \end{code}
152
153 %************************************************************************
154 %*                                                                      *
155 \subsection{tcMatch}
156 %*                                                                      *
157 %************************************************************************
158
159 \begin{code}
160 tcMatches :: TcMatchCtxt
161           -> [TcSigmaType]      -- Expected pattern types
162           -> TcRhoType          -- Expected result-type of the Match.
163           -> MatchGroup Name
164           -> TcM (MatchGroup TcId)
165
166 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
167   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
168          mc_body :: LHsExpr Name                -- Type checker for a body of
169                                                 -- an alternative
170                  -> TcRhoType
171                  -> TcM (LHsExpr TcId) }        
172
173 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
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 (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
177
178 -------------
179 tcMatch :: TcMatchCtxt
180         -> [TcSigmaType]        -- Expected pattern types
181         -> TcRhoType            -- Expected result-type of the Match.
182         -> LMatch Name
183         -> TcM (LMatch 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 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 -> GRHSs Name -> TcRhoType
210         -> TcM (GRHSs 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 -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
226
227 tcGRHS ctxt res_ty (GRHS guards rhs)
228   = do  { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
229                              mc_body ctxt rhs
230         ; return (GRHS guards' rhs') }
231   where
232     stmt_ctxt  = PatGuard (mc_what ctxt)
233 \end{code}
234
235
236 %************************************************************************
237 %*                                                                      *
238 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
239 %*                                                                      *
240 %************************************************************************
241
242 \begin{code}
243 tcDoStmts :: HsStmtContext Name 
244           -> [LStmt Name]
245           -> TcRhoType
246           -> TcM (HsExpr TcId)          -- Returns a HsDo
247 tcDoStmts ListComp stmts res_ty
248   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
249         ; let list_ty = mkListTy elt_ty
250         ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
251         ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) }
252
253 tcDoStmts PArrComp stmts res_ty
254   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
255         ; let parr_ty = mkPArrTy elt_ty
256         ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
257         ; return $ mkHsWrapCoI coi (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 \end{code}
280
281
282 %************************************************************************
283 %*                                                                      *
284 \subsection{tcStmts}
285 %*                                                                      *
286 %************************************************************************
287
288 \begin{code}
289 type TcStmtChecker
290   =  forall thing. HsStmtContext Name
291                 -> Stmt Name
292                 -> TcRhoType                    -- Result type for comprehension
293                 -> (TcRhoType -> TcM thing)     -- Checker for what follows the stmt
294                 -> TcM (Stmt TcId, thing)
295
296 tcStmts :: HsStmtContext Name
297         -> TcStmtChecker        -- NB: higher-rank type
298         -> [LStmt Name]
299         -> TcRhoType
300         -> TcM [LStmt TcId]
301 tcStmts ctxt stmt_chk stmts res_ty
302   = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
303                         const (return ())
304        ; return stmts' }
305
306 tcStmtsAndThen :: HsStmtContext Name
307                -> TcStmtChecker -- NB: higher-rank type
308                -> [LStmt Name]
309                -> TcRhoType
310                -> (TcRhoType -> TcM thing)
311                -> TcM ([LStmt TcId], thing)
312
313 -- Note the higher-rank type.  stmt_chk is applied at different
314 -- types in the equations for tcStmts
315
316 tcStmtsAndThen _ _ [] res_ty thing_inside
317   = do  { thing <- thing_inside res_ty
318         ; return ([], thing) }
319
320 -- LetStmts are handled uniformly, regardless of context
321 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
322   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
323                                       tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
324         ; return (L loc (LetStmt binds') : stmts', thing) }
325
326 -- For the vanilla case, handle the location-setting part
327 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
328   = do  { (stmt', (stmts', thing)) <- 
329                 setSrcSpan loc                              $
330                 addErrCtxt (pprStmtInCtxt ctxt stmt)        $
331                 stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
332                 popErrCtxt                                  $
333                 tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
334                 thing_inside
335         ; return (L loc stmt' : stmts', thing) }
336
337 ---------------------------------------------------
338 --              Pattern guards
339 ---------------------------------------------------
340
341 tcGuardStmt :: TcStmtChecker
342 tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
343   = do  { guard' <- tcMonoExpr guard boolTy
344         ; thing  <- thing_inside res_ty
345         ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
346
347 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
348   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
349         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
350                             thing_inside res_ty
351         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
352
353 tcGuardStmt _ stmt _ _
354   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
355
356
357 ---------------------------------------------------
358 --           List comprehensions and PArrays
359 --               (no rebindable syntax)
360 ---------------------------------------------------
361
362 -- Dealt with separately, rather than by tcMcStmt, because
363 --   a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
364 --   b) We have special desugaring rules for list comprehensions,
365 --      which avoid creating intermediate lists.  They in turn 
366 --      assume that the bind/return operations are the regular
367 --      polymorphic ones, and in particular don't have any
368 --      coercion matching stuff in them.  It's hard to avoid the
369 --      potential for non-trivial coercions in tcMcStmt
370
371 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
372          -> TcStmtChecker
373
374 tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
375   = do { body' <- tcMonoExprNC body elt_ty
376        ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
377        ; return (LastStmt body' noSyntaxExpr, thing) }
378
379 -- A generator, pat <- rhs
380 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
381  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
382         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
383         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
384                             thing_inside elt_ty
385         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
386
387 -- A boolean guard
388 tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
389   = do  { rhs'  <- tcMonoExpr rhs boolTy
390         ; thing <- thing_inside elt_ty
391         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
392
393 -- ParStmt: See notes with tcMcStmt
394 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
395   = do  { (pairs', thing) <- loop bndr_stmts_s
396         ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
397   where
398     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
399     loop [] = do { thing <- thing_inside elt_ty
400                  ; return ([], thing) }         -- matching in the branches
401
402     loop ((stmts, names) : pairs)
403       = do { (stmts', (ids, pairs', thing))
404                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
405                    do { ids <- tcLookupLocalIds names
406                       ; (pairs', thing) <- loop pairs
407                       ; return (ids, pairs', thing) }
408            ; return ( (stmts', ids) : pairs', thing ) }
409
410 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
411                               , trS_bndrs =  bindersMap
412                               , trS_by = by, trS_using = using }) elt_ty thing_inside
413   = do { let (bndr_names, n_bndr_names) = unzip bindersMap
414              unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
415              -- The inner 'stmts' lack a LastStmt, so the element type
416              --  passed in to tcStmtsAndThen is never looked at
417        ; (stmts', (bndr_ids, by'))
418             <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
419                { by' <- case by of
420                            Nothing -> return Nothing
421                            Just e  -> do { e_ty <- tcInferRho e; return (Just e_ty) }
422                ; bndr_ids <- tcLookupLocalIds bndr_names
423                ; return (bndr_ids, by') }
424
425        ; let m_app ty = mkTyConApp m_tc [ty]
426
427        --------------- Typecheck the 'using' function -------------
428        -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
429        --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
430
431          -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
432        ; let n_app = case form of
433                        ThenForm -> (\ty -> ty)
434                        _        -> m_app
435
436              by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
437              by_arrow = case by' of
438                           Nothing       -> \ty -> ty
439                           Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
440
441              tup_ty        = mkBigCoreVarTupTy bndr_ids
442              poly_arg_ty   = m_app alphaTy
443              poly_res_ty   = m_app (n_app alphaTy)
444              using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ 
445                              poly_arg_ty `mkFunTy` poly_res_ty
446
447        ; using' <- tcPolyExpr using using_poly_ty
448        ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' 
449
450              -- 'stmts' returns a result of type (m1_ty tuple_ty),
451              -- typically something like [(Int,Bool,Int)]
452              -- We don't know what tuple_ty is yet, so we use a variable
453        ; let mk_n_bndr :: Name -> TcId -> TcId
454              mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
455
456              -- Ensure that every old binder of type `b` is linked up with its
457              -- new binder which should have type `n b`
458              -- See Note [GroupStmt binder map] in HsExpr
459              n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
460              bindersMap' = bndr_ids `zip` n_bndr_ids
461
462        -- Type check the thing in the environment with 
463        -- these new binders and return the result
464        ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
465
466        ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' 
467                                 , trS_by = fmap fst by', trS_using = final_using 
468                                 , trS_form = form }, thing) }
469     
470 tcLcStmt _ _ stmt _ _
471   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
472
473
474 ---------------------------------------------------
475 --           Monad comprehensions 
476 --        (supports rebindable syntax)
477 ---------------------------------------------------
478
479 tcMcStmt :: TcStmtChecker
480
481 tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
482   = do  { a_ty       <- newFlexiTyVarTy liftedTypeKind
483         ; return_op' <- tcSyntaxOp MCompOrigin return_op
484                                    (a_ty `mkFunTy` res_ty)
485         ; body'      <- tcMonoExprNC body a_ty
486         ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
487         ; return (LastStmt body' return_op', thing) } 
488
489 -- Generators for monad comprehensions ( pat <- rhs )
490 --
491 --   [ body | q <- gen ]  ->  gen :: m a
492 --                            q   ::   a
493 --
494
495 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
496  = do   { rhs_ty     <- newFlexiTyVarTy liftedTypeKind
497         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
498         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
499
500            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
501         ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op 
502                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
503
504            -- If (but only if) the pattern can fail, typecheck the 'fail' operator
505         ; fail_op' <- if isIrrefutableHsPat pat 
506                       then return noSyntaxExpr
507                       else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
508
509         ; rhs' <- tcMonoExprNC rhs rhs_ty
510         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
511                            thing_inside new_res_ty
512
513         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
514
515 -- Boolean expressions.
516 --
517 --   [ body | stmts, expr ]  ->  expr :: m Bool
518 --
519 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
520   = do  { -- Deal with rebindable syntax:
521           --    guard_op :: test_ty -> rhs_ty
522           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
523           -- Where test_ty is, for example, Bool
524           test_ty    <- newFlexiTyVarTy liftedTypeKind
525         ; rhs_ty     <- newFlexiTyVarTy liftedTypeKind
526         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
527         ; rhs'       <- tcMonoExpr rhs test_ty
528         ; guard_op'  <- tcSyntaxOp MCompOrigin guard_op
529                                    (mkFunTy test_ty rhs_ty)
530         ; then_op'   <- tcSyntaxOp MCompOrigin then_op
531                                    (mkFunTys [rhs_ty, new_res_ty] res_ty)
532         ; thing      <- thing_inside new_res_ty
533         ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
534
535 -- Grouping statements
536 --
537 --   [ body | stmts, then group by e ]
538 --     ->  e :: t
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 return_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        ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
686                        mkForAllTy alphaTyVar $
687                        alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
688
689        ; (pairs', thing) <- loop m_ty bndr_stmts_s
690
691        -- Typecheck bind:
692        ; let tys      = map (mkBigCoreVarTupTy . snd) pairs'
693              tuple_ty = mk_tuple_ty tys
694
695        ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
696                         (m_ty `mkAppTy` tuple_ty)
697                         `mkFunTy` (tuple_ty `mkFunTy` res_ty)
698                         `mkFunTy` res_ty
699
700        ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
701
702   where 
703     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
704
705        -- loop :: Type                                  -- m_ty
706        --      -> [([LStmt Name], [Name])]
707        --      -> TcM ([([LStmt TcId], [TcId])], thing)
708     loop _ [] = do { thing <- thing_inside res_ty
709                    ; return ([], thing) }           -- matching in the branches
710
711     loop m_ty ((stmts, names) : pairs)
712       = do { -- type dummy since we don't know all binder types yet
713              ty_dummy <- newFlexiTyVarTy liftedTypeKind
714            ; (stmts', (ids, pairs', thing))
715                 <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
716                    do { ids <- tcLookupLocalIds names
717                       ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
718
719                       ; check_same m_tup_ty res_ty'
720                       ; check_same m_tup_ty ty_dummy
721                                                          
722                       ; (pairs', thing) <- loop m_ty pairs
723                       ; return (ids, pairs', thing) }
724            ; return ( (stmts', ids) : pairs', thing ) }
725
726         -- Check that the types match up.
727         -- This is a grevious hack.  They always *will* match 
728         -- If (>>=) and (>>) are polymorpic in the return type,
729         -- but we don't have any good way to incorporate the coercion
730         -- so for now we just check that it's the identity
731     check_same actual expected
732       = do { coi <- unifyType actual expected
733            ; unless (isIdentityCoI coi) $
734              failWithMisMatch [UnifyOrigin { uo_expected = expected
735                                            , uo_actual = actual }] }
736
737 tcMcStmt _ stmt _ _
738   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
739
740
741 ---------------------------------------------------
742 --           Do-notation
743 --        (supports rebindable syntax)
744 ---------------------------------------------------
745
746 tcDoStmt :: TcStmtChecker
747
748 tcDoStmt _ (LastStmt body _) res_ty thing_inside
749   = do { body' <- tcMonoExprNC body res_ty
750        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
751        ; return (LastStmt body' noSyntaxExpr, thing) }
752
753 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
754   = do  {       -- Deal with rebindable syntax:
755                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
756                 -- This level of generality is needed for using do-notation
757                 -- in full generality; see Trac #1537
758
759                 -- I'd like to put this *after* the tcSyntaxOp 
760                 -- (see Note [Treat rebindable syntax first], but that breaks 
761                 -- the rigidity info for GADTs.  When we move to the new story
762                 -- for GADTs, we can move this after tcSyntaxOp
763           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
764         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
765         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
766         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op 
767                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
768
769                 -- If (but only if) the pattern can fail, 
770                 -- typecheck the 'fail' operator
771         ; fail_op' <- if isIrrefutableHsPat pat 
772                       then return noSyntaxExpr
773                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
774
775         ; rhs' <- tcMonoExprNC rhs rhs_ty
776         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
777                            thing_inside new_res_ty
778
779         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
780
781
782 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
783   = do  {       -- Deal with rebindable syntax; 
784                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
785                 -- See also Note [Treat rebindable syntax first]
786           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
787         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
788         ; then_op' <- tcSyntaxOp DoOrigin then_op 
789                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
790
791         ; rhs' <- tcMonoExprNC rhs rhs_ty
792         ; thing <- thing_inside new_res_ty
793         ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
794
795 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
796                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
797                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) 
798          res_ty thing_inside
799   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
800         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
801         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
802               tup_ty  = mkBoxedTupleTy tup_elt_tys
803
804         ; tcExtendIdEnv tup_ids $ do
805         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
806         ; (stmts', (ret_op', tup_rets))
807                 <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
808                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
809                              -- Unify the types of the "final" Ids (which may 
810                              -- be polymorphic) with those of "knot-tied" Ids
811                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
812                       ; return (ret_op', tup_rets) }
813
814         ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
815         ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
816                                  (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
817
818         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
819         ; bind_op' <- tcSyntaxOp DoOrigin bind_op 
820                                  (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
821
822         ; thing <- thing_inside new_res_ty
823   
824         ; let rec_ids = takeList rec_names tup_ids
825         ; later_ids <- tcLookupLocalIds later_names
826         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
827                                  ppr later_ids <+> ppr (map idType later_ids)]
828         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
829                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' 
830                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
831                           , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
832         }}
833
834 tcDoStmt _ stmt _ _
835   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
836 \end{code}
837
838 Note [Treat rebindable syntax first]
839 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
840 When typechecking
841         do { bar; ... } :: IO ()
842 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
843 pushing info from the context into the RHS.  To do this, we check the
844 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
845 Otherwise the error shows up when cheking the rebindable syntax, and
846 the expected/inferred stuff is back to front (see Trac #3613).
847
848
849 %************************************************************************
850 %*                                                                      *
851 \subsection{Errors and contexts}
852 %*                                                                      *
853 %************************************************************************
854
855 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
856 number of args are used in each equation.
857
858 \begin{code}
859 checkArgs :: Name -> MatchGroup Name -> TcM ()
860 checkArgs fun (MatchGroup (match1:matches) _)
861     | null bad_matches = return ()
862     | otherwise
863     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> 
864                           ptext (sLit "have different numbers of arguments"),
865                         nest 2 (ppr (getLoc match1)),
866                         nest 2 (ppr (getLoc (head bad_matches)))])
867   where
868     n_args1 = args_in_match match1
869     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
870
871     args_in_match :: LMatch Name -> Int
872     args_in_match (L _ (Match pats _ _)) = length pats
873 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
874 \end{code}
875