TcMatches.hs 48.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5 6

TcMatches: Typecheck some @Matches@
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

quchen's avatar
quchen committed
9 10 11
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiWayIf #-}
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
12
{-# LANGUAGE TupleSections #-}
13
{-# LANGUAGE FlexibleContexts #-}
14
{-# LANGUAGE TypeFamilies #-}
Ian Lynagh's avatar
Ian Lynagh committed
15

16
module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
17 18 19
                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
                   tcDoStmt, tcGuardStmt
20
       ) where
21

22 23
import GhcPrelude

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
24 25
import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
sof's avatar
sof committed
26

Ben Gamari's avatar
Ben Gamari committed
27
import BasicTypes (LexicalFixity(..))
28
import HsSyn
29
import TcRnMonad
30 31 32 33 34 35 36 37 38 39
import TcEnv
import TcPat
import TcMType
import TcType
import TcBinds
import TcUnify
import Name
import TysWiredIn
import Id
import TyCon
40
import TysPrim
41
import TcEvidence
sof's avatar
sof committed
42
import Outputable
43
import Util
44
import SrcLoc
quchen's avatar
quchen committed
45 46
import DynFlags
import PrelNames (monadFailClassName)
47
import qualified GHC.LanguageExtensions as LangExt
48

49 50 51
-- Create chunkified tuple tybes for monad comprehensions
import MkCore

52
import Control.Monad
53
import Control.Arrow ( second )
54 55

#include "HsVersions.h"
56

Austin Seipp's avatar
Austin Seipp committed
57 58 59
{-
************************************************************************
*                                                                      *
60
\subsection{tcMatchesFun, tcMatchesCase}
Austin Seipp's avatar
Austin Seipp committed
61 62
*                                                                      *
************************************************************************
63

64 65 66 67 68
@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
@FunMonoBind@.  The second argument is the name of the function, which
is used in error messages.  It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.

69 70 71
Note [Polymorphic expected type for tcMatchesFun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcMatchesFun may be given a *sigma* (polymorphic) type
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
72
so it must be prepared to use tcSkolemise to skolemise it.
73
See Note [sig_tau may be polymorphic] in TcPat.
Austin Seipp's avatar
Austin Seipp committed
74
-}
75

76
tcMatchesFun :: Located Name
77
             -> MatchGroup GhcRn (LHsExpr GhcRn)
78
             -> ExpRhoType     -- Expected type of function
79
             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
80
                                -- Returns type of body
81
tcMatchesFun fn@(L _ fun_name) matches exp_ty
82 83 84 85 86 87
  = do  {  -- Check that they all have the same no of arguments
           -- Location is in the monad, set the caller so that
           -- any inter-equation error messages get some vaguely
           -- sensible location.        Note: we have to do this odd
           -- ann-grabbing, because we don't always have annotations in
           -- hand when we call tcMatchesFun...
88
          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
89
        ; checkArgs fun_name matches
90

91
        ; (wrap_gen, (wrap_fun, group))
92
            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
93
                  -- Note [Polymorphic expected type for tcMatchesFun]
94 95 96
               do { (matches', wrap_fun)
                       <- matchExpectedFunTys herald arity exp_rho $
                          \ pat_tys rhs_ty ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
97
                          tcMatches match_ctxt pat_tys rhs_ty matches
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
98
                  ; return (wrap_fun, matches') }
99
        ; return (wrap_gen <.> wrap_fun, group) }
ross's avatar
ross committed
100
  where
101
    arity = matchGroupArity matches
102 103
    herald = text "The equation(s) for"
             <+> quotes (ppr fun_name) <+> text "have"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
104 105
    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
    match_ctxt = MC { mc_what = what, mc_body = tcBody }
Ben Gamari's avatar
Ben Gamari committed
106 107
    strictness
      | [L _ match] <- unLoc $ mg_alts matches
Simon Peyton Jones's avatar
Simon Peyton Jones committed
108
      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
Ben Gamari's avatar
Ben Gamari committed
109 110 111
      = SrcStrict
      | otherwise
      = NoSrcStrict
112

Austin Seipp's avatar
Austin Seipp committed
113
{-
114 115
@tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
Austin Seipp's avatar
Austin Seipp committed
116
-}
117

118 119 120 121 122 123 124 125
tcMatchesCase :: (Outputable (body GhcRn)) =>
                TcMatchCtxt body                        -- Case context
             -> TcSigmaType                             -- Type of scrutinee
             -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives
             -> ExpRhoType                    -- Type of whole case expressions
             -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
                -- Translated alternatives
                -- wrapper goes from MatchGroup's ty to expected ty
126

127
tcMatchesCase ctxt scrut_ty matches res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
128
  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
129 130 131

tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
              -> TcMatchCtxt HsExpr
132
              -> MatchGroup GhcRn (LHsExpr GhcRn)
133
              -> ExpRhoType   -- deeply skolemised
134
              -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
135
tcMatchLambda herald match_ctxt match res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
136 137
  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
    tcMatches match_ctxt pat_tys rhs_ty match
ross's avatar
ross committed
138
  where
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
139 140
    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
           | otherwise               = matchGroupArity match
141

Austin Seipp's avatar
Austin Seipp committed
142
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
ross's avatar
ross committed
143

144 145
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
146
-- Used for pattern bindings
147
tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
ross's avatar
ross committed
148 149
  where
    match_ctxt = MC { mc_what = PatBindRhs,
150
                      mc_body = tcBody }
151

Austin Seipp's avatar
Austin Seipp committed
152 153 154
{-
************************************************************************
*                                                                      *
155
\subsection{tcMatch}
Austin Seipp's avatar
Austin Seipp committed
156 157
*                                                                      *
************************************************************************
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
158

159 160
Note [Case branches must never infer a non-tau type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
161 162 163 164 165 166 167 168 169 170
Consider

  case ... of
    ... -> \(x :: forall a. a -> a) -> x
    ... -> \y -> y

Should that type-check? The problem is that, if we check the second branch
first, then we'll get a type (b -> b) for the branches, which won't unify
with the polytype in the first branch. If we check the first branch first,
then everything is OK. This order-dependency is terrible. So we want only
171 172 173
proper tau-types in branches (unless a sigma-type is pushed down).
This is what expTypeToType ensures: it replaces an Infer with a fresh
tau-type.
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
174 175 176 177 178 179

An even trickier case looks like

  f x True  = x undefined
  f x False = x ()

180 181
Here, we see that the arguments must also be non-Infer. Thus, we must
use expTypeToType on the output of matchExpectedFunTys, not the input.
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
182 183 184 185 186 187

But we make a special case for a one-branch case. This is so that

  f = \(x :: forall a. a -> a) -> x

still gets assigned a polytype.
Austin Seipp's avatar
Austin Seipp committed
188
-}
189

190
-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
191
-- expected type into TauTvs.
192
-- See Note [Case branches must never infer a non-tau type]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
193
tauifyMultipleMatches :: [LMatch id body]
194 195 196 197 198
                      -> [ExpType] -> TcM [ExpType]
tauifyMultipleMatches group exp_tys
  | isSingletonMatchGroup group = return exp_tys
  | otherwise                   = mapM tauifyExpType exp_tys
  -- NB: In the empty-match case, this ensures we fill in the ExpType
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
199

Simon Peyton Jones's avatar
Simon Peyton Jones committed
200
-- | Type-check a MatchGroup.
201
tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
202 203
          -> [ExpSigmaType]      -- Expected pattern types
          -> ExpRhoType          -- Expected result-type of the Match.
204 205
          -> MatchGroup GhcRn (Located (body GhcRn))
          -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
206 207

data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
208 209
  = MC { mc_what :: HsMatchContext Name,  -- What kind of thing this is
         mc_body :: Located (body GhcRn)         -- Type checker for a body of
210
                                                -- an alternative
211
                 -> ExpRhoType
212
                 -> TcM (Located (body GhcTcId)) }
213

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
214 215
tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
                                  , mg_origin = origin })
Simon Peyton Jones's avatar
Simon Peyton Jones committed
216
  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
217 218
            -- See Note [Case branches must never infer a non-tau type]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
219
       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
220 221
       ; pat_tys  <- mapM readExpType pat_tys
       ; rhs_ty   <- readExpType rhs_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
222
       ; return (MG { mg_alts = L l matches'
223
                    , mg_ext = MatchGroupTc pat_tys rhs_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
224
                    , mg_origin = origin }) }
225
tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"
226 227

-------------
228
tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
229 230
        -> [ExpSigmaType]        -- Expected pattern types
        -> ExpRhoType            -- Expected result-type of the Match.
231 232
        -> LMatch GhcRn (Located (body GhcRn))
        -> TcM (LMatch GhcTcId (Located (body GhcTcId)))
233

234
tcMatch ctxt pat_tys rhs_ty match
235
  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
236
  where
237
    tc_match ctxt pat_tys rhs_ty
238
             match@(Match { m_pats = pats, m_grhss = grhss })
239
      = add_match_ctxt match $
240
        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
241
                                tcGRHSs ctxt grhss rhs_ty
242 243
           ; return (Match { m_ext = noExt
                           , m_ctxt = mc_what ctxt, m_pats = pats'
244
                           , m_grhss = grhss' }) }
245
    tc_match  _ _ _ (XMatch _) = panic "tcMatch"
246

247
        -- For (\x -> e), tcExpr has already said "In the expression \x->e"
248
        -- so we don't want to add "In the lambda abstraction \x->e"
249
    add_match_ctxt match thing_inside
250 251
        = case mc_what ctxt of
            LambdaExpr -> thing_inside
252
            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
253

254
-------------
255 256
tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
        -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
257

258 259
-- Notice that we pass in the full res_ty, so that we get
-- good inference from simple things like
260
--      f = \(x::forall a.a->a) -> <stuff>
261 262
-- We used to force it to be a monotype when there was more than one guard
-- but we don't need to do that any more
ross's avatar
ross committed
263

264
tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
265 266 267
  = do  { (binds', grhss')
            <- tcLocalBinds binds $
               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
268

269 270
        ; return (GRHSs noExt grhss' (L l binds')) }
tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"
271 272

-------------
273 274
tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
       -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
275

276
tcGRHS ctxt res_ty (GRHS _ guards rhs)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
277 278 279
  = do  { (guards', rhs')
            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
               mc_body ctxt rhs
280
        ; return (GRHS noExt guards' rhs') }
281
  where
282
    stmt_ctxt  = PatGuard (mc_what ctxt)
283
tcGRHS _ _ (XGRHS _) = panic "tcGRHS"
284

Austin Seipp's avatar
Austin Seipp committed
285 286 287
{-
************************************************************************
*                                                                      *
288
\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
Austin Seipp's avatar
Austin Seipp committed
289 290 291
*                                                                      *
************************************************************************
-}
292

293
tcDoStmts :: HsStmtContext Name
294
          -> Located [LStmt GhcRn (LHsExpr GhcRn)]
295
          -> ExpRhoType
296
          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo
297
tcDoStmts ListComp (L l stmts) res_ty
298 299
  = do  { res_ty <- expTypeToType res_ty
        ; (co, elt_ty) <- matchExpectedListTy res_ty
300
        ; let list_ty = mkListTy elt_ty
301 302
        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
                            (mkCheckExpType elt_ty)
303
        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
304

305
tcDoStmts DoExpr (L l stmts) res_ty
306
  = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
307
        ; res_ty <- readExpType res_ty
308
        ; return (HsDo res_ty DoExpr (L l stmts')) }
309

310
tcDoStmts MDoExpr (L l stmts) res_ty
311
  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
312
        ; res_ty <- readExpType res_ty
313
        ; return (HsDo res_ty MDoExpr (L l stmts')) }
314

315
tcDoStmts MonadComp (L l stmts) res_ty
316
  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
317
        ; res_ty <- readExpType res_ty
318
        ; return (HsDo res_ty MonadComp (L l stmts')) }
319

320
tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
321

322
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
323
tcBody body res_ty
324
  = do  { traceTc "tcBody" (ppr res_ty)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
325
        ; tcMonoExpr body res_ty
326
        }
327

Austin Seipp's avatar
Austin Seipp committed
328 329 330
{-
************************************************************************
*                                                                      *
331
\subsection{tcStmts}
Austin Seipp's avatar
Austin Seipp committed
332 333 334
*                                                                      *
************************************************************************
-}
335

336 337
type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
338

339
type TcStmtChecker body rho_type
340
  =  forall thing. HsStmtContext Name
341
                -> Stmt GhcRn (Located (body GhcRn))
342 343
                -> rho_type                 -- Result type for comprehension
                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
344
                -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
345

346
tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
347
        -> TcStmtChecker body rho_type   -- NB: higher-rank type
348
        -> [LStmt GhcRn (Located (body GhcRn))]
349
        -> rho_type
350
        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
351
tcStmts ctxt stmt_chk stmts res_ty
352
  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
353 354 355
                        const (return ())
       ; return stmts' }

356
tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
357
               -> TcStmtChecker body rho_type    -- NB: higher-rank type
358
               -> [LStmt GhcRn (Located (body GhcRn))]
359 360
               -> rho_type
               -> (rho_type -> TcM thing)
361
               -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
362

363 364
-- Note the higher-rank type.  stmt_chk is applied at different
-- types in the equations for tcStmts
365

366
tcStmtsAndThen _ _ [] res_ty thing_inside
367 368
  = do  { thing <- thing_inside res_ty
        ; return ([], thing) }
369

370
-- LetStmts are handled uniformly, regardless of context
371
tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
372
                                                             res_ty thing_inside
373
  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
Simon Marlow's avatar
Simon Marlow committed
374
              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
375
        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
376

Simon Marlow's avatar
Simon Marlow committed
377 378 379
-- Don't set the error context for an ApplicativeStmt.  It ought to be
-- possible to do this with a popErrCtxt in the tcStmt case for
-- ApplicativeStmt, but it did someting strange and broke a test (ado002).
380
tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
Simon Marlow's avatar
Simon Marlow committed
381 382 383 384 385 386 387 388 389
  | ApplicativeStmt{} <- stmt
  = do  { (stmt', (stmts', thing)) <-
             stmt_chk ctxt stmt res_ty $ \ res_ty' ->
               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
                 thing_inside
        ; return (L loc stmt' : stmts', thing) }

  -- For the vanilla case, handle the location-setting part
  | otherwise
390 391
  = do  { (stmt', (stmts', thing)) <-
                setSrcSpan loc                              $
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
392
                addErrCtxt (pprStmtInCtxt ctxt stmt)        $
393
                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
394
                popErrCtxt                                  $
395 396 397
                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
                thing_inside
        ; return (L loc stmt' : stmts', thing) }
398

399
---------------------------------------------------
400
--              Pattern guards
401 402
---------------------------------------------------

403
tcGuardStmt :: TcExprStmtChecker
404
tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
405
  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
406
        ; thing  <- thing_inside res_ty
407
        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
408

409
tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
410 411
  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs
                                   -- Stmt has a context already
412
        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
413
                                    pat (mkCheckExpType rhs_ty) $
414
                            thing_inside res_ty
415
        ; return (mkTcBindStmt pat' rhs', thing) }
416

Ian Lynagh's avatar
Ian Lynagh committed
417
tcGuardStmt _ stmt _ _
418 419 420
  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)


421
---------------------------------------------------
422
--           List comprehensions
423
--               (no rebindable syntax)
424 425 426
---------------------------------------------------

-- Dealt with separately, rather than by tcMcStmt, because
427
--   a) We have special desugaring rules for list comprehensions,
428
--      which avoid creating intermediate lists.  They in turn
429 430 431 432
--      assume that the bind/return operations are the regular
--      polymorphic ones, and in particular don't have any
--      coercion matching stuff in them.  It's hard to avoid the
--      potential for non-trivial coercions in tcMcStmt
433

434
tcLcStmt :: TyCon       -- The list type constructor ([])
435
         -> TcExprStmtChecker
436

437
tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
438
  = do { body' <- tcMonoExprNC body elt_ty
439
       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
440
       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
441

442
-- A generator, pat <- rhs
443
tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
444
 = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
445 446
        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
447
                            thing_inside elt_ty
448
        ; return (mkTcBindStmt pat' rhs', thing) }
449 450

-- A boolean guard
451
tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
452
  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)
453
        ; thing <- thing_inside elt_ty
454
        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
455

456
-- ParStmt: See notes with tcMcStmt
457
tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
458
  = do  { (pairs', thing) <- loop bndr_stmts_s
459
        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
460
  where
461 462
    -- loop :: [([LStmt GhcRn], [GhcRn])]
    --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
463
    loop [] = do { thing <- thing_inside elt_ty
464
                 ; return ([], thing) }         -- matching in the branches
465

466
    loop (ParStmtBlock x stmts names _ : pairs)
467
      = do { (stmts', (ids, pairs', thing))
468 469 470 471
                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
                   do { ids <- tcLookupLocalIds names
                      ; (pairs', thing) <- loop pairs
                      ; return (ids, pairs', thing) }
472 473
           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
    loop (XParStmtBlock{}:_) = panic "tcLcStmt"
474

475 476 477 478 479
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                              , trS_bndrs =  bindersMap
                              , trS_by = by, trS_using = using }) elt_ty thing_inside
  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
480 481
             -- The inner 'stmts' lack a LastStmt, so the element type
             --  passed in to tcStmtsAndThen is never looked at
482
       ; (stmts', (bndr_ids, by'))
483
            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
484
               { by' <- traverse tcInferSigma by
485 486 487 488 489 490 491 492 493 494 495 496
               ; bndr_ids <- tcLookupLocalIds bndr_names
               ; return (bndr_ids, by') }

       ; let m_app ty = mkTyConApp m_tc [ty]

       --------------- Typecheck the 'using' function -------------
       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)

         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
       ; let n_app = case form of
                       ThenForm -> (\ty -> ty)
497
                       _        -> m_app
498 499 500 501

             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
             by_arrow = case by' of
                          Nothing       -> \ty -> ty
502
                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
503 504 505

             tup_ty        = mkBigCoreVarTupTy bndr_ids
             poly_arg_ty   = m_app alphaTy
506
             poly_res_ty   = m_app (n_app alphaTy)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
507
             using_poly_ty = mkInvForAllTy alphaTyVar $
508
                             by_arrow $
509 510 511
                             poly_arg_ty `mkFunTy` poly_res_ty

       ; using' <- tcPolyExpr using using_poly_ty
512
       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
513

514 515 516
             -- 'stmts' returns a result of type (m1_ty tuple_ty),
             -- typically something like [(Int,Bool,Int)]
             -- We don't know what tuple_ty is yet, so we use a variable
517
       ; let mk_n_bndr :: Name -> TcId -> TcId
518
             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
519 520 521

             -- Ensure that every old binder of type `b` is linked up with its
             -- new binder which should have type `n b`
522
             -- See Note [GroupStmt binder map] in HsExpr
523 524 525
             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
             bindersMap' = bndr_ids `zip` n_bndr_ids

526
       -- Type check the thing in the environment with
527 528 529
       -- these new binders and return the result
       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)

530 531 532 533 534
       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
                           , trS_by = fmap fst by', trS_using = final_using
                           , trS_ret = noSyntaxExpr
                           , trS_bind = noSyntaxExpr
                           , trS_fmap = noExpr
535
                           , trS_ext = unitTy
536
                           , trS_form = form }, thing) }
537

Ian Lynagh's avatar
Ian Lynagh committed
538
tcLcStmt _ _ stmt _ _
539
  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
540

541 542

---------------------------------------------------
543 544
--           Monad comprehensions
--        (supports rebindable syntax)
545
---------------------------------------------------
546

547
tcMcStmt :: TcExprStmtChecker
548

549
tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
550 551 552 553
  = do  { (body', return_op')
            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
               \ [a_ty] ->
               tcMonoExprNC body (mkCheckExpType a_ty)
554
        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
555
        ; return (LastStmt x body' noret return_op', thing) }
556

557 558 559 560 561
-- Generators for monad comprehensions ( pat <- rhs )
--
--   [ body | q <- gen ]  ->  gen :: m a
--                            q   ::   a
--
562

563
tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
564
           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
565 566 567 568 569 570 571 572 573
  = do  { ((rhs', pat', thing, new_res_ty), bind_op')
            <- tcSyntaxOp MCompOrigin bind_op
                          [SynRho, SynFun SynAny SynRho] res_ty $
               \ [rhs_ty, pat_ty, new_res_ty] ->
               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
                                           (mkCheckExpType pat_ty) $
                                     thing_inside (mkCheckExpType new_res_ty)
                  ; return (rhs', pat', thing, new_res_ty) }
574

575 576
        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
quchen's avatar
quchen committed
577

578
        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
579 580 581 582 583

-- Boolean expressions.
--
--   [ body | stmts, expr ]  ->  expr :: m Bool
--
584
tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
585
  = do  { -- Deal with rebindable syntax:
586 587 588
          --    guard_op :: test_ty -> rhs_ty
          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
          -- Where test_ty is, for example, Bool
589 590 591 592 593 594 595 596 597 598
        ; ((thing, rhs', rhs_ty, guard_op'), then_op')
            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
               \ [rhs_ty, new_res_ty] ->
               do { (rhs', guard_op')
                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]
                                    (mkCheckExpType rhs_ty) $
                         \ [test_ty] ->
                         tcMonoExpr rhs (mkCheckExpType test_ty)
                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
                  ; return (thing, rhs', rhs_ty, guard_op') }
599
        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
600 601 602 603 604 605 606 607

-- Grouping statements
--
--   [ body | stmts, then group by e using f ]
--     ->  e :: t
--         f :: forall a. (a -> t) -> m a -> m (m a)
--   [ body | stmts, then group using f ]
--     ->  f :: forall a. m a -> m (m a)
608 609 610

-- We type [ body | (stmts, group by e using f), ... ]
--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
611
--
612
-- We type the functions as follows:
613 614 615 616 617
--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
--
618 619
tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
                         , trS_by = by, trS_using = using, trS_form = form
620
                         , trS_ret = return_op, trS_bind = bind_op
621
                         , trS_fmap = fmap_op }) res_ty thing_inside
622
  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
623 624 625
       ; m1_ty   <- newFlexiTyVarTy star_star_kind
       ; m2_ty   <- newFlexiTyVarTy star_star_kind
       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
626
       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
627 628 629 630

         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
       ; n_app <- case form of
                    ThenForm -> return (\ty -> ty)
631 632 633
                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind
                                   ; return (n_ty `mkAppTy`) }
       ; let by_arrow :: Type -> Type
634
             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
635
             --                          or res                    ('by' absent)
636
             by_arrow = case by of
637 638
                          Nothing -> \res -> res
                          Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
639 640 641

             poly_arg_ty  = m1_ty `mkAppTy` alphaTy
             using_arg_ty = m1_ty `mkAppTy` tup_ty
642 643
             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
             using_res_ty = m2_ty `mkAppTy` n_app tup_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
644
             using_poly_ty = mkInvForAllTy alphaTyVar $
645
                             by_arrow $
646 647
                             poly_arg_ty `mkFunTy` poly_res_ty

648 649 650
             -- 'stmts' returns a result of type (m1_ty tuple_ty),
             -- typically something like [(Int,Bool,Int)]
             -- We don't know what tuple_ty is yet, so we use a variable
651 652
       ; let (bndr_names, n_bndr_names) = unzip bindersMap
       ; (stmts', (bndr_ids, by', return_op')) <-
653 654
            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do
655
                { by' <- case by of
656
                           Nothing -> return Nothing
657 658 659
                           Just e  -> do { e' <- tcMonoExpr e
                                                   (mkCheckExpType by_e_ty)
                                         ; return (Just e') }
660 661 662 663 664 665

                -- Find the Ids (and hence types) of all old binders
                ; bndr_ids <- tcLookupLocalIds bndr_names

                -- 'return' is only used for the binders, so we know its type.
                --   return :: (a,b,c,..) -> m (a,b,c,..)
666 667 668
                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]
                                       res_ty' $ \ _ -> return ()
669

670
                ; return (bndr_ids, by', return_op') }
671

672 673 674
       --------------- Typecheck the 'bind' function -------------
       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
675 676 677 678
       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
                             [ synKnownType using_res_ty
                             , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]
                             res_ty $ \ _ -> return ()
679 680 681

       --------------- Typecheck the 'fmap' function -------------
       ; fmap_op' <- case form of
682
                       ThenForm -> return noExpr
683
                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
684 685
                            mkInvForAllTy alphaTyVar $
                            mkInvForAllTy betaTyVar  $
686 687 688 689 690 691 692 693
                            (alphaTy `mkFunTy` betaTy)
                            `mkFunTy` (n_app alphaTy)
                            `mkFunTy` (n_app betaTy)

       --------------- Typecheck the 'using' function -------------
       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))

       ; using' <- tcPolyExpr using using_poly_ty
694
       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
695 696

       --------------- Bulding the bindersMap ----------------
697
       ; let mk_n_bndr :: Name -> TcId -> TcId
698
             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
699 700 701

             -- Ensure that every old binder of type `b` is linked up with its
             -- new binder which should have type `n b`
702
             -- See Note [GroupStmt binder map] in HsExpr
703 704 705
             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
             bindersMap' = bndr_ids `zip` n_bndr_ids

706
       -- Type check the thing in the environment with
707
       -- these new binders and return the result
708 709
       ; thing <- tcExtendIdEnv n_bndr_ids $
                  thing_inside (mkCheckExpType new_res_ty)
710

711 712
       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
                           , trS_by = by', trS_using = final_using
713
                           , trS_ret = return_op', trS_bind = bind_op'
714
                           , trS_ext = n_app tup_ty
715
                           , trS_fmap = fmap_op', trS_form = form }, thing) }
716 717

-- A parallel set of comprehensions
718 719
--      [ (g x, h x) | ... ; let g v = ...
--                   | ... ; let h v = ... ]
720 721
--
-- It's possible that g,h are overloaded, so we need to feed the LIE from the
722
-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
723 724
-- Similarly if we had an existential pattern match:
--
725
--      data T = forall a. Show a => C a
726
--
727 728
--      [ (show x, show y) | ... ; C x <- ...
--                         | ... ; C y <- ... ]
729 730
--
-- Then we need the LIE from (show x, show y) to be simplified against
731 732 733
-- the bindings for x and y.
--
-- It's difficult to do this in parallel, so we rely on the renamer to
734 735 736
-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
-- So the binders of the first parallel group will be in scope in the second
-- group.  But that's fine; there's no shadowing to worry about.
737 738 739 740
--
-- Note: The `mzip` function will get typechecked via:
--
--   ParStmt [st1::t1, st2::t2, st3::t3]
741
--
742 743 744 745
--   mzip :: m st1
--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
--        -> m (st1, (st2, st3))
--
746
tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
747
  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
748
       ; m_ty   <- newFlexiTyVarTy star_star_kind
749

750
       ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $
751 752 753 754 755 756
                        (m_ty `mkAppTy` alphaTy)
                        `mkFunTy`
                        (m_ty `mkAppTy` betaTy)
                        `mkFunTy`
                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
757

758 759
        -- type dummies since we don't know all binder types yet
       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
760
                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
761

762
       -- Typecheck bind:
763 764
       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
             tuple_ty = mk_tuple_ty tup_tys
765