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 -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
  17                    matchCtxt, TcMatchCtxt(..),
  18                    tcStmts, tcDoStmts, tcBody,
  19                    tcDoStmt, tcMDoStmt, tcGuardStmt
  20        ) where
  21
  22 #include "HsVersions.h"
  23
  24 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
  25
  26 import HsSyn
  27 import TcRnMonad
  28 import TcGadt
  29 import Inst
  30 import TcEnv
  31 import TcPat
  32 import TcMType
  33 import TcType
  34 import TcBinds
  35 import TcUnify
  36 import TcSimplify
  37 import Name
  38 import TysWiredIn
  39 import PrelNames
  40 import Id
  41 import TyCon
  42 import TysPrim
  43 import Outputable
  44 import Util
  45 import SrcLoc
  46
  47 import Control.Monad
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{tcMatchesFun, tcMatchesCase}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  57 @FunMonoBind@.  The second argument is the name of the function, which
  58 is used in error messages.  It checks that all the equations have the
  59 same number of arguments before using @tcMatches@ to do the work.
  60
  61 \begin{code}
  62 tcMatchesFun :: Name -> Bool
  63              -> MatchGroup Name
  64              -> BoxyRhoType             -- Expected type of function
  65              -> TcM (HsWrapper, MatchGroup TcId)        -- Returns type of body
  66
  67 tcMatchesFun fun_name inf matches exp_ty
  68   = do  {  -- Check that they all have the same no of arguments
  69            -- Location is in the monad, set the caller so that
  70            -- any inter-equation error messages get some vaguely
  71            -- sensible location.        Note: we have to do this odd
  72            -- ann-grabbing, because we don't always have annotations in
  73            -- hand when we call tcMatchesFun...
  74           checkArgs fun_name matches
  75
  76         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  77         -- because inconsistency between branches
  78         -- may show up as something wrong with the (non-existent) type signature
  79
  80                 -- This is one of two places places we call subFunTys
  81                 -- The point is that if expected_y is a "hole", we want
  82                 -- to make pat_tys and rhs_ty as "holes" too.
  83         ; subFunTys doc n_pats exp_ty     $ \ pat_tys rhs_ty ->
  84           tcMatches match_ctxt pat_tys rhs_ty matches
  85         }
  86   where
  87     doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
  88           <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
  89     n_pats = matchGroupArity matches
  90     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
  91 \end{code}
  92
  93 @tcMatchesCase@ doesn't do the argument-count check because the
  94 parser guarantees that each equation has exactly one argument.
  95
  96 \begin{code}
  97 tcMatchesCase :: TcMatchCtxt            -- Case context
  98               -> TcRhoType              -- Type of scrutinee
  99               -> MatchGroup Name        -- The case alternatives
 100               -> BoxyRhoType            -- Type of whole case expressions
 101               -> TcM (MatchGroup TcId)  -- Translated alternatives
 102
 103 tcMatchesCase ctxt scrut_ty matches res_ty
 104   = tcMatches ctxt [scrut_ty] res_ty matches
 105
 106 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
 107 tcMatchLambda match res_ty
 108   = subFunTys doc n_pats res_ty         $ \ pat_tys rhs_ty ->
 109     tcMatches match_ctxt pat_tys rhs_ty match
 110   where
 111     n_pats = matchGroupArity match
 112     doc = sep [ ptext SLIT("The lambda expression")
 113                  <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
 114                         -- The pprSetDepth makes the abstraction print briefly
 115                 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
 116     match_ctxt = MC { mc_what = LambdaExpr,
 117                       mc_body = tcBody }
 118 \end{code}
 119
 120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 121
 122 \begin{code}
 123 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
 124 -- Used for pattern bindings
 125 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty)
 126                         -- emptyRefinement: no refinement in a pattern binding
 127   where
 128     match_ctxt = MC { mc_what = PatBindRhs,
 129                       mc_body = tcBody }
 130 \end{code}
 131
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{tcMatch}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 \begin{code}
 140 tcMatches :: TcMatchCtxt
 141           -> [BoxySigmaType]            -- Expected pattern types
 142           -> BoxyRhoType                -- Expected result-type of the Match.
 143           -> MatchGroup Name
 144           -> TcM (MatchGroup TcId)
 145
 146 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 147   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 148          mc_body :: LHsExpr Name                -- Type checker for a body of an alternative
 149                  -> (Refinement, BoxyRhoType)
 150                  -> TcM (LHsExpr TcId) }
 151
 152 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 153   = do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 154         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 155
 156 -------------
 157 tcMatch :: TcMatchCtxt
 158         -> [BoxySigmaType]      -- Expected pattern types
 159         -> BoxyRhoType          -- Expected result-type of the Match.
 160         -> LMatch Name
 161         -> TcM (LMatch TcId)
 162
 163 tcMatch ctxt pat_tys rhs_ty match
 164   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 165   where
 166     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 167       = add_match_ctxt match $
 168         do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
 169                                 tc_grhss ctxt maybe_rhs_sig grhss
 170            ; return (Match pats' Nothing grhss') }
 171
 172     tc_grhss ctxt Nothing grhss rhs_ty
 173       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 174
 175         -- Result type sigs are no longer supported
 176     tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
 177       = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
 178                         <+> ppr res_sig)
 179            ; tcGRHSs ctxt grhss (co, rhs_ty) }
 180
 181         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 182         -- so we don't want to add "In the lambda abstraction \x->e"
 183     add_match_ctxt match thing_inside
 184         = case mc_what ctxt of
 185             LambdaExpr -> thing_inside
 186             m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
 187
 188 -------------
 189 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
 190         -> TcM (GRHSs TcId)
 191
 192 -- Notice that we pass in the full res_ty, so that we get
 193 -- good inference from simple things like
 194 --      f = \(x::forall a.a->a) -> <stuff>
 195 -- We used to force it to be a monotype when there was more than one guard
 196 -- but we don't need to do that any more
 197
 198 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 199   = do  { (binds', grhss') <- tcLocalBinds binds $
 200                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 201
 202         ; return (GRHSs grhss' binds') }
 203
 204 -------------
 205 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
 206
 207 tcGRHS ctxt res_ty (GRHS guards rhs)
 208   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 209                              mc_body ctxt rhs
 210         ; return (GRHS guards' rhs') }
 211   where
 212     stmt_ctxt  = PatGuard (mc_what ctxt)
 213 \end{code}
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 tcDoStmts :: HsStmtContext Name
 224           -> [LStmt Name]
 225           -> LHsExpr Name
 226           -> BoxyRhoType
 227           -> TcM (HsExpr TcId)          -- Returns a HsDo
 228 tcDoStmts ListComp stmts body res_ty
 229   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 230         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
 231                                      (emptyRefinement,elt_ty) $
 232                              tcBody body
 233         ; return $ mkHsWrapCoI coi
 234                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 235
 236 tcDoStmts PArrComp stmts body res_ty
 237   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 238         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
 239                                      (emptyRefinement, elt_ty) $
 240                              tcBody body
 241         ; return $ mkHsWrapCoI coi
 242                      (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 243
 244 tcDoStmts DoExpr stmts body res_ty
 245   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
 246                                      (emptyRefinement, res_ty) $
 247                              tcBody body
 248         ; return (HsDo DoExpr stmts' body' res_ty) }
 249
 250 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
 251   = do  { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
 252         ; let res_ty' = mkAppTy m_ty elt_ty     -- The boxySplit consumes res_ty
 253               tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
 254                            tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 255
 256         ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
 257                                      (emptyRefinement, res_ty') $
 258                              tcBody body
 259
 260         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 261         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 262         ; return $
 263             mkHsWrapCoI coi
 264               (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 265
 266 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 267
 268 tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId)
 269 tcBody body (reft, res_ty)
 270   = do  { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
 271         ; let (co, res_ty') = refineResType reft res_ty
 272         ; body' <- tcPolyExpr body res_ty'
 273         ; return (mkLHsWrap co body') }
 274 \end{code}
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection{tcStmts}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 type TcStmtChecker
 285   =  forall thing. HsStmtContext Name
 286                 -> Stmt Name
 287                 -> (Refinement, BoxyRhoType)                    -- Result type for comprehension
 288                 -> ((Refinement,BoxyRhoType) -> TcM thing)      -- Checker for what follows the stmt
 289                 -> TcM (Stmt TcId, thing)
 290
 291   -- The incoming BoxyRhoType may be refined by type refinements
 292   -- before being passed to the thing_inside
 293
 294 tcStmts :: HsStmtContext Name
 295         -> TcStmtChecker        -- NB: higher-rank type
 296         -> [LStmt Name]
 297         -> (Refinement, BoxyRhoType)
 298         -> ((Refinement, BoxyRhoType) -> TcM thing)
 299         -> TcM ([LStmt TcId], thing)
 300
 301 -- Note the higher-rank type.  stmt_chk is applied at different
 302 -- types in the equations for tcStmts
 303
 304 tcStmts ctxt stmt_chk [] res_ty thing_inside
 305   = do  { thing <- thing_inside res_ty
 306         ; return ([], thing) }
 307
 308 -- LetStmts are handled uniformly, regardless of context
 309 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 310   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 311                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 312         ; return (L loc (LetStmt binds') : stmts', thing) }
 313
 314 -- For the vanilla case, handle the location-setting part
 315 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 316   = do  { (stmt', (stmts', thing)) <-
 317                 setSrcSpan loc                          $
 318                 addErrCtxt (stmtCtxt ctxt stmt)         $
 319                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 320                 popErrCtxt                              $
 321                 tcStmts ctxt stmt_chk stmts res_ty'     $
 322                 thing_inside
 323         ; return (L loc stmt' : stmts', thing) }
 324
 325 --------------------------------
 326 --      Pattern guards
 327 tcGuardStmt :: TcStmtChecker
 328 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
 329   = do  { guard' <- tcMonoExpr guard boolTy
 330         ; thing  <- thing_inside res_ty
 331         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 332
 333 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 334   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 335         ; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
 336         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 337
 338 tcGuardStmt ctxt stmt res_ty thing_inside
 339   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 340
 341
 342 --------------------------------
 343 --      List comprehensions and PArrays
 344
 345 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 346          -> TcStmtChecker
 347
 348 -- A generator, pat <- rhs
 349 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 350  = do   { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
 351                             tcMonoExpr rhs (mkTyConApp m_tc [ty])
 352         ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 353         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 354
 355 -- A boolean guard
 356 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
 357   = do  { rhs'  <- tcMonoExpr rhs boolTy
 358         ; thing <- thing_inside res_ty
 359         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 360
 361 -- A parallel set of comprehensions
 362 --      [ (g x, h x) | ... ; let g v = ...
 363 --                   | ... ; let h v = ... ]
 364 --
 365 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 366 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 367 -- Similarly if we had an existential pattern match:
 368 --
 369 --      data T = forall a. Show a => C a
 370 --
 371 --      [ (show x, show y) | ... ; C x <- ...
 372 --                         | ... ; C y <- ... ]
 373 --
 374 -- Then we need the LIE from (show x, show y) to be simplified against
 375 -- the bindings for x and y.
 376 --
 377 -- It's difficult to do this in parallel, so we rely on the renamer to
 378 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 379 -- So the binders of the first parallel group will be in scope in the second
 380 -- group.  But that's fine; there's no shadowing to worry about.
 381
 382 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 383   = do  { (pairs', thing) <- loop bndr_stmts_s
 384         ; return (ParStmt pairs', thing) }
 385   where
 386     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 387     loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
 388                  ; return ([], thing) }         -- matching in the branches
 389
 390     loop ((stmts, names) : pairs)
 391       = do { (stmts', (ids, pairs', thing))
 392                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
 393                    do { ids <- tcLookupLocalIds names
 394                       ; (pairs', thing) <- loop pairs
 395                       ; return (ids, pairs', thing) }
 396            ; return ( (stmts', ids) : pairs', thing ) }
 397
 398 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
 399     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 400         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 401             let alphaListTy = mkTyConApp m_tc [alphaTy]
 402
 403             (usingExpr', maybeByExpr') <-
 404                 case maybeByExpr of
 405                     Nothing -> do
 406                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 407                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
 408                         return (usingExpr', Nothing)
 409                     Just byExpr -> do
 410                         -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
 411                         (byExpr', tTy) <- tcInferRho byExpr
 412                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
 413                         return (usingExpr', Just byExpr')
 414
 415             binders' <- tcLookupLocalIds binders
 416             thing <- thing_inside elt_ty'
 417
 418             return (binders', usingExpr', maybeByExpr', thing)
 419
 420     return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
 421
 422 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
 423         (stmts', (bindersMap', groupByClause', thing)) <-
 424             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 425                 let alphaListTy = mkTyConApp m_tc [alphaTy]
 426                     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 427
 428                 groupByClause' <-
 429                     case groupByClause of
 430                         GroupByNothing usingExpr ->
 431                             -- We must validate that usingExpr :: forall a. [a] -> [[a]]
 432                             tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
 433                         GroupBySomething eitherUsingExpr byExpr -> do
 434                             -- We must infer a type such that byExpr :: t
 435                             (byExpr', tTy) <- tcInferRho byExpr
 436
 437                             -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
 438                             let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
 439                             eitherUsingExpr' <-
 440                                 case eitherUsingExpr of
 441                                     Left usingExpr  -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
 442                                     Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
 443                             return $ GroupBySomething eitherUsingExpr' byExpr'
 444
 445                 -- Find the IDs and types of all old binders
 446                 let (oldBinders, newBinders) = unzip bindersMap
 447                 oldBinders' <- tcLookupLocalIds oldBinders
 448
 449                 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
 450                 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
 451
 452                 -- Type check the thing in the environment with these new binders and return the result
 453                 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
 454                 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
 455
 456         return (GroupStmt (stmts', bindersMap') groupByClause', thing)
 457     where
 458         associateNewBinder :: TcId -> Name -> TcId
 459         associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
 460
 461 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 462   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 463
 464 --------------------------------
 465 --      Do-notation
 466 -- The main excitement here is dealing with rebindable syntax
 467
 468 tcDoStmt :: TcStmtChecker
 469
 470 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) (reft,res_ty) thing_inside
 471   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 472                 -- We should use type *inference* for the RHS computations, becuase of GADTs.
 473                 --      do { pat <- rhs; <rest> }
 474                 -- is rather like
 475                 --      case rhs of { pat -> <rest> }
 476                 -- We do inference on rhs, so that information about its type can be refined
 477                 -- when type-checking the pattern.
 478
 479         -- Deal with rebindable syntax:
 480         --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 481         -- This level of generality is needed for using do-notation
 482         -- in full generality; see Trac #1537
 483         ; ((bind_op', new_res_ty), pat_ty) <-
 484              withBox liftedTypeKind $ \ pat_ty ->
 485              withBox liftedTypeKind $ \ new_res_ty ->
 486              tcSyntaxOp DoOrigin bind_op
 487                         (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 488
 489                 -- If (but only if) the pattern can fail,
 490                 -- typecheck the 'fail' operator
 491         ; fail_op' <- if isIrrefutableHsPat pat
 492                       then return noSyntaxExpr
 493                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 494
 495         ; (pat', thing) <- tcLamPat pat pat_ty (reft, new_res_ty) thing_inside
 496
 497         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 498
 499
 500 tcDoStmt ctxt (ExprStmt rhs then_op _) (reft,res_ty) thing_inside
 501   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 502
 503         -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
 504         ; (then_op', new_res_ty) <-
 505                 withBox liftedTypeKind $ \ new_res_ty ->
 506                 tcSyntaxOp DoOrigin then_op
 507                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 508
 509         ; thing <- thing_inside (reft, new_res_ty)
 510         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 511
 512 tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
 513   = failWithTc (ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
 514         -- This case can't be caught in the renamer
 515         -- see RnExpr.checkRecStmt
 516
 517 tcDoStmt ctxt stmt res_ty thing_inside
 518   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 519
 520 --------------------------------
 521 --      Mdo-notation
 522 -- The distinctive features here are
 523 --      (a) RecStmts, and
 524 --      (b) no rebindable syntax
 525
 526 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 527           -> TcStmtChecker
 528 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 529   = do  { (rhs', pat_ty) <- tc_rhs rhs
 530         ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 531         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 532
 533 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 534   = do  { (rhs', elt_ty) <- tc_rhs rhs
 535         ; thing          <- thing_inside res_ty
 536         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 537
 538 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
 539   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 540         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 541         ; tcExtendIdEnv rec_ids                 $ do
 542         { (stmts', (later_ids, rec_rets))
 543                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
 544                         -- ToDo: res_ty not really right
 545                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 546                       ; later_ids <- tcLookupLocalIds laterNames
 547                       ; return (later_ids, rec_rets) }
 548
 549         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
 550                 -- NB:  The rec_ids for the recursive things
 551                 --      already scope over this part. This binding may shadow
 552                 --      some of them with polymorphic things with the same Name
 553                 --      (see note [RecStmt] in HsExpr)
 554         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 555
 556         ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
 557         }}
 558   where
 559     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 560     tc_ret rec_name mono_ty
 561         = do { poly_id <- tcLookupId rec_name
 562                 -- poly_id may have a polymorphic type
 563                 -- but mono_ty is just a monomorphic type variable
 564              ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
 565              ; return (mkHsWrap co_fn (HsVar poly_id)) }
 566
 567 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
 568   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 569
 570 \end{code}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection{Errors and contexts}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 580 number of args are used in each equation.
 581
 582 \begin{code}
 583 checkArgs :: Name -> MatchGroup Name -> TcM ()
 584 checkArgs fun (MatchGroup (match1:matches) _)
 585     | null bad_matches = return ()
 586     | otherwise
 587     = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
 588                           ptext SLIT("have different numbers of arguments"),
 589                         nest 2 (ppr (getLoc match1)),
 590                         nest 2 (ppr (getLoc (head bad_matches)))])
 591   where
 592     n_args1 = args_in_match match1
 593     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 594
 595     args_in_match :: LMatch Name -> Int
 596     args_in_match (L _ (Match pats _ _)) = length pats
 597 checkArgs fun other = panic "TcPat.checkArgs"   -- Matches always non-empty
 598 \end{code}
 599
 600 \begin{code}
 601 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 602                            4 (pprMatch ctxt match)
 603
 604 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
 605                         4 (ppr stmt)
 606 \end{code}