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         ( isReflCo, mkSymCo )
  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 (coToHsWrapper (mkSymCo 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 $ mkHsWrapCo 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 $ mkHsWrapCo 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 (isReflCo 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