{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


TcMatches: Typecheck some @Matches@
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}

module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
                   tcDoStmt, tcGuardStmt
       ) where

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho
                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )

import BasicTypes (LexicalFixity(..))
import GHC.Hs
import TcRnMonad
import TcEnv
import TcPat
import TcMType
import TcType
import TcBinds
import TcUnify
import TcOrigin
import Name
import TysWiredIn
import Id
import TyCon
import TysPrim
import TcEvidence
import Outputable
import Util
import SrcLoc

-- Create chunkified tuple tybes for monad comprehensions
import MkCore

import Control.Monad
import Control.Arrow ( second )

#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
\subsection{tcMatchesFun, tcMatchesCase}
*                                                                      *
************************************************************************

@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.

Note [Polymorphic expected type for tcMatchesFun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcMatchesFun may be given a *sigma* (polymorphic) type
so it must be prepared to use tcSkolemise to skolemise it.
See Note [sig_tau may be polymorphic] in TcPat.
-}

tcMatchesFun :: Located Name
             -> MatchGroup GhcRn (LHsExpr GhcRn)
             -> ExpSigmaType    -- Expected type of function
             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
                                -- Returns type of body
tcMatchesFun :: Located Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
tcMatchesFun fn :: Located Name
fn@(L SrcSpan
_ Name
fun_name) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
exp_ty
  = 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...
          String -> SDoc -> TcRn ()
traceTc String
"tcMatchesFun" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun_name SDoc -> SDoc -> SDoc
$$ ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
exp_ty)
        ; Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcRn ()
forall body. Name -> MatchGroup GhcRn body -> TcRn ()
checkArgs Name
fun_name MatchGroup GhcRn (LHsExpr GhcRn)
matches

        ; (HsWrapper
wrap_gen, (HsWrapper
wrap_fun, MatchGroup GhcTcId (LHsExpr GhcTcId)
group))
            <- UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType
    -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM
     (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
forall result.
UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseET (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
fun_name Bool
True) ExpSigmaType
exp_ty ((ExpSigmaType
  -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM
      (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))))
-> (ExpSigmaType
    -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM
     (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_rho ->
                  -- Note [Polymorphic expected type for tcMatchesFun]
               do { (MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', HsWrapper
wrap_fun)
                       <- SDoc
-> Arity
-> ExpSigmaType
-> ([ExpSigmaType]
    -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a.
SDoc
-> Arity
-> ExpSigmaType
-> ([ExpSigmaType] -> ExpSigmaType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald Arity
arity ExpSigmaType
exp_rho (([ExpSigmaType]
  -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper))
-> ([ExpSigmaType]
    -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a b. (a -> b) -> a -> b
$
                          \ [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty ->
                          TcMatchCtxt HsExpr
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
matches
                  ; (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
-> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap_fun, MatchGroup GhcTcId (LHsExpr GhcTcId)
matches') }
        ; (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
-> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap_gen HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_fun, MatchGroup GhcTcId (LHsExpr GhcTcId)
group) }
  where
    arity :: Arity
arity = MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
matches
    herald :: SDoc
herald = String -> SDoc
text String
"The equation(s) for"
             SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"have"
    what :: HsMatchContext Name
what = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs { mc_fun :: Located Name
mc_fun = Located Name
fn, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
what, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }
    strictness :: SrcStrictness
strictness
      | [L _ match] <- Located [LMatch GhcRn (LHsExpr GhcRn)]
-> SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located [LMatch GhcRn (LHsExpr GhcRn)]
 -> SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)]))
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
-> SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)])
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcRn (LHsExpr GhcRn)
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts MatchGroup GhcRn (LHsExpr GhcRn)
matches
      , FunRhs{ mc_strictness :: forall id. HsMatchContext id -> SrcStrictness
mc_strictness = SrcStrictness
SrcStrict } <- Match GhcRn (LHsExpr GhcRn)
-> HsMatchContext (NameOrRdrName (IdP GhcRn))
forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt Match GhcRn (LHsExpr GhcRn)
match
      = SrcStrictness
SrcStrict
      | Bool
otherwise
      = SrcStrictness
NoSrcStrict

{-
@tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
-}

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

tcMatchesCase :: TcMatchCtxt body
-> TcSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatchesCase TcMatchCtxt body
ctxt TcSigmaType
scrut_ty MatchGroup GhcRn (Located (body GhcRn))
matches ExpSigmaType
res_ty
  = TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt body
ctxt [TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
scrut_ty] ExpSigmaType
res_ty MatchGroup GhcRn (Located (body GhcRn))
matches

tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
              -> TcMatchCtxt HsExpr
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpRhoType   -- deeply skolemised
              -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda :: SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpSigmaType
res_ty
  = SDoc
-> Arity
-> ExpSigmaType
-> ([ExpSigmaType]
    -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a.
SDoc
-> Arity
-> ExpSigmaType
-> ([ExpSigmaType] -> ExpSigmaType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald Arity
n_pats ExpSigmaType
res_ty (([ExpSigmaType]
  -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper))
-> ([ExpSigmaType]
    -> ExpSigmaType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty ->
    TcMatchCtxt HsExpr
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
match
  where
    n_pats :: Arity
n_pats | MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
forall id body. MatchGroup id body -> Bool
isEmptyMatchGroup MatchGroup GhcRn (LHsExpr GhcRn)
match = Arity
1   -- must be lambda-case
           | Bool
otherwise               = MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
match

-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.

tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
-- Used for pattern bindings
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> TcSigmaType -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss TcSigmaType
res_ty = TcMatchCtxt HsExpr
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs TcMatchCtxt HsExpr
match_ctxt GRHSs GhcRn (LHsExpr GhcRn)
grhss (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
PatBindRhs,
                      mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }

{-
************************************************************************
*                                                                      *
\subsection{tcMatch}
*                                                                      *
************************************************************************

Note [Case branches must never infer a non-tau type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
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.

An even trickier case looks like

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

Here, we see that the arguments must also be non-Infer. Thus, we must
use expTypeToType on the output of matchExpectedFunTys, not the input.

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.
-}

-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
-- expected type into TauTvs.
-- See Note [Case branches must never infer a non-tau type]
tauifyMultipleMatches :: [LMatch id body]
                      -> [ExpType] -> TcM [ExpType]
tauifyMultipleMatches :: [LMatch id body] -> [ExpSigmaType] -> TcM [ExpSigmaType]
tauifyMultipleMatches [LMatch id body]
group [ExpSigmaType]
exp_tys
  | [LMatch id body] -> Bool
forall id body. [LMatch id body] -> Bool
isSingletonMatchGroup [LMatch id body]
group = [ExpSigmaType] -> TcM [ExpSigmaType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ExpSigmaType]
exp_tys
  | Bool
otherwise                   = (ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType)
-> [ExpSigmaType] -> TcM [ExpSigmaType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType
tauifyExpType [ExpSigmaType]
exp_tys
  -- NB: In the empty-match case, this ensures we fill in the ExpType

-- | Type-check a MatchGroup.
tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
          -> [ExpSigmaType]      -- Expected pattern types
          -> ExpRhoType          -- Expected result-type of the Match.
          -> MatchGroup GhcRn (Located (body GhcRn))
          -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))

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

tcMatches :: TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt body
ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
l [LMatch GhcRn (Located (body GhcRn))]
matches
                                  , mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
  = do { ExpSigmaType
rhs_ty:[ExpSigmaType]
pat_tys <- [LMatch GhcRn (Located (body GhcRn))]
-> [ExpSigmaType] -> TcM [ExpSigmaType]
forall id body.
[LMatch id body] -> [ExpSigmaType] -> TcM [ExpSigmaType]
tauifyMultipleMatches [LMatch GhcRn (Located (body GhcRn))]
matches (ExpSigmaType
rhs_tyExpSigmaType -> [ExpSigmaType] -> [ExpSigmaType]
forall a. a -> [a] -> [a]
:[ExpSigmaType]
pat_tys)
            -- See Note [Case branches must never infer a non-tau type]

       ; [LMatch GhcTcId (Located (body GhcTcId))]
matches' <- (LMatch GhcRn (Located (body GhcRn))
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (LMatch GhcTcId (Located (body GhcTcId))))
-> [LMatch GhcRn (Located (body GhcRn))]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [LMatch GhcTcId (Located (body GhcTcId))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> LMatch GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (LMatch GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
tcMatch TcMatchCtxt body
ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty) [LMatch GhcRn (Located (body GhcRn))]
matches
       ; [TcSigmaType]
pat_tys  <- (ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType)
-> [ExpSigmaType] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType [ExpSigmaType]
pat_tys
       ; TcSigmaType
rhs_ty   <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpSigmaType
rhs_ty
       ; MatchGroup GhcTcId (Located (body GhcTcId))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [LMatch GhcTcId (Located (body GhcTcId))]
mg_alts = SrcSpan
-> [LMatch GhcTcId (Located (body GhcTcId))]
-> Located [LMatch GhcTcId (Located (body GhcTcId))]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LMatch GhcTcId (Located (body GhcTcId))]
matches'
                    , mg_ext :: XMG GhcTcId (Located (body GhcTcId))
mg_ext = [TcSigmaType] -> TcSigmaType -> MatchGroupTc
MatchGroupTc [TcSigmaType]
pat_tys TcSigmaType
rhs_ty
                    , mg_origin :: Origin
mg_origin = Origin
origin }) }
tcMatches TcMatchCtxt body
_ [ExpSigmaType]
_ ExpSigmaType
_ (XMatchGroup XXMatchGroup GhcRn (Located (body GhcRn))
nec) = NoExtCon -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcRn (Located (body GhcRn))
NoExtCon
nec

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

tcMatch :: TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
tcMatch TcMatchCtxt body
ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty LMatch GhcRn (Located (body GhcRn))
match
  = (SrcSpanLess (LMatch GhcRn (Located (body GhcRn)))
 -> TcM (SrcSpanLess (LMatch GhcTcId (Located (body GhcTcId)))))
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM (TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
tc_match TcMatchCtxt body
ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty) LMatch GhcRn (Located (body GhcRn))
match
  where
    tc_match :: TcMatchCtxt body
-> [ExpSigmaType]
-> ExpSigmaType
-> Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
tc_match TcMatchCtxt body
ctxt [ExpSigmaType]
pat_tys ExpSigmaType
rhs_ty
             match :: Match GhcRn (Located (body GhcRn))
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (Located (body GhcRn))
grhss })
      = Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
add_match_ctxt Match GhcRn (Located (body GhcRn))
match (IOEnv
   (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId))))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
forall a b. (a -> b) -> a -> b
$
        do { ([Located (Pat GhcTcId)]
pats', GRHSs GhcTcId (Located (body GhcTcId))
grhss') <- HsMatchContext Name
-> [LPat GhcRn]
-> [ExpSigmaType]
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
-> TcM ([LPat GhcTcId], GRHSs GhcTcId (Located (body GhcTcId)))
forall a.
HsMatchContext Name
-> [LPat GhcRn]
-> [ExpSigmaType]
-> TcM a
-> TcM ([LPat GhcTcId], a)
tcPats (TcMatchCtxt body -> HsMatchContext Name
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext Name
mc_what TcMatchCtxt body
ctxt) [LPat GhcRn]
pats [ExpSigmaType]
pat_tys (TcM (GRHSs GhcTcId (Located (body GhcTcId)))
 -> TcM ([LPat GhcTcId], GRHSs GhcTcId (Located (body GhcTcId))))
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
-> TcM ([LPat GhcTcId], GRHSs GhcTcId (Located (body GhcTcId)))
forall a b. (a -> b) -> a -> b
$
                                TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs TcMatchCtxt body
ctxt GRHSs GhcRn (Located (body GhcRn))
grhss ExpSigmaType
rhs_ty
           ; Match GhcTcId (Located (body GhcTcId))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcTcId (Located (body GhcTcId))
m_ext = XCMatch GhcTcId (Located (body GhcTcId))
NoExtField
noExtField
                           , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcTcId))
m_ctxt = TcMatchCtxt body -> HsMatchContext Name
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext Name
mc_what TcMatchCtxt body
ctxt, m_pats :: [LPat GhcTcId]
m_pats = [Located (Pat GhcTcId)]
[LPat GhcTcId]
pats'
                           , m_grhss :: GRHSs GhcTcId (Located (body GhcTcId))
m_grhss = GRHSs GhcTcId (Located (body GhcTcId))
grhss' }) }
    tc_match  TcMatchCtxt body
_ [ExpSigmaType]
_ ExpSigmaType
_ (XMatch XXMatch GhcRn (Located (body GhcRn))
nec) = NoExtCon
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
forall a. NoExtCon -> a
noExtCon XXMatch GhcRn (Located (body GhcRn))
NoExtCon
nec

        -- For (\x -> e), tcExpr has already said "In the expression \x->e"
        -- so we don't want to add "In the lambda abstraction \x->e"
    add_match_ctxt :: Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
add_match_ctxt Match GhcRn (Located (body GhcRn))
match IOEnv
  (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
thing_inside
        = case TcMatchCtxt body -> HsMatchContext Name
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext Name
mc_what TcMatchCtxt body
ctxt of
            HsMatchContext Name
LambdaExpr -> IOEnv
  (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
thing_inside
            HsMatchContext Name
_          -> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (Located (body GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR,
 Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
 Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatchInCtxt Match GhcRn (Located (body GhcRn))
match) IOEnv
  (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
thing_inside

-------------
tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
        -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))

-- Notice that we pass in the full res_ty, so that we get
-- good inference from simple things like
--      f = \(x::forall a.a->a) -> <stuff>
-- 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

tcGRHSs :: TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs TcMatchCtxt body
ctxt (GRHSs XCGRHSs GhcRn (Located (body GhcRn))
_ [LGRHS GhcRn (Located (body GhcRn))]
grhss (L SrcSpan
l HsLocalBinds GhcRn
binds)) ExpSigmaType
res_ty
  = do  { (HsLocalBinds GhcTcId
binds', [LGRHS GhcTcId (Located (body GhcTcId))]
grhss')
            <- HsLocalBinds GhcRn
-> TcM [LGRHS GhcTcId (Located (body GhcTcId))]
-> TcM
     (HsLocalBinds GhcTcId, [LGRHS GhcTcId (Located (body GhcTcId))])
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [LGRHS GhcTcId (Located (body GhcTcId))]
 -> TcM
      (HsLocalBinds GhcTcId, [LGRHS GhcTcId (Located (body GhcTcId))]))
-> TcM [LGRHS GhcTcId (Located (body GhcTcId))]
-> TcM
     (HsLocalBinds GhcTcId, [LGRHS GhcTcId (Located (body GhcTcId))])
forall a b. (a -> b) -> a -> b
$
               (LGRHS GhcRn (Located (body GhcRn))
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (Located (body GhcTcId))))
-> [LGRHS GhcRn (Located (body GhcRn))]
-> TcM [LGRHS GhcTcId (Located (body GhcTcId))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcRn (Located (body GhcRn)))
 -> TcM (SrcSpanLess (LGRHS GhcTcId (Located (body GhcTcId)))))
-> LGRHS GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (Located (body GhcTcId)))
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM (TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS TcMatchCtxt body
ctxt ExpSigmaType
res_ty)) [LGRHS GhcRn (Located (body GhcRn))]
grhss

        ; GRHSs GhcTcId (Located (body GhcTcId))
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHSs GhcTcId (Located (body GhcTcId))
-> [LGRHS GhcTcId (Located (body GhcTcId))]
-> LHsLocalBinds GhcTcId
-> GRHSs GhcTcId (Located (body GhcTcId))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTcId (Located (body GhcTcId))
NoExtField
noExtField [LGRHS GhcTcId (Located (body GhcTcId))]
grhss' (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds')) }
tcGRHSs TcMatchCtxt body
_ (XGRHSs XXGRHSs GhcRn (Located (body GhcRn))
nec) ExpSigmaType
_ = NoExtCon -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
forall a. NoExtCon -> a
noExtCon XXGRHSs GhcRn (Located (body GhcRn))
NoExtCon
nec

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

tcGRHS :: TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS TcMatchCtxt body
ctxt ExpSigmaType
res_ty (GRHS XCGRHS GhcRn (Located (body GhcRn))
_ [GuardLStmt GhcRn]
guards Located (body GhcRn)
rhs)
  = do  { ([LStmt GhcTcId (LHsExpr GhcTcId)]
guards', Located (body GhcTcId)
rhs')
            <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], Located (body GhcTcId))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
stmt_ctxt TcStmtChecker HsExpr ExpSigmaType
tcGuardStmt [GuardLStmt GhcRn]
guards ExpSigmaType
res_ty ((ExpSigmaType -> TcM (Located (body GhcTcId)))
 -> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], Located (body GhcTcId)))
-> (ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], Located (body GhcTcId))
forall a b. (a -> b) -> a -> b
$
               TcMatchCtxt body
-> Located (body GhcRn)
-> ExpSigmaType
-> TcM (Located (body GhcTcId))
forall (body :: * -> *).
TcMatchCtxt body
-> Located (body GhcRn)
-> ExpSigmaType
-> TcM (Located (body GhcTcId))
mc_body TcMatchCtxt body
ctxt Located (body GhcRn)
rhs
        ; GRHS GhcTcId (Located (body GhcTcId))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHS GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located (body GhcTcId)
-> GRHS GhcTcId (Located (body GhcTcId))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTcId (Located (body GhcTcId))
NoExtField
noExtField [LStmt GhcTcId (LHsExpr GhcTcId)]
guards' Located (body GhcTcId)
rhs') }
  where
    stmt_ctxt :: HsStmtContext Name
stmt_ctxt  = HsMatchContext Name -> HsStmtContext Name
forall id. HsMatchContext id -> HsStmtContext id
PatGuard (TcMatchCtxt body -> HsMatchContext Name
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext Name
mc_what TcMatchCtxt body
ctxt)
tcGRHS TcMatchCtxt body
_ ExpSigmaType
_ (XGRHS XXGRHS GhcRn (Located (body GhcRn))
nec) = NoExtCon -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
forall a. NoExtCon -> a
noExtCon XXGRHS GhcRn (Located (body GhcRn))
NoExtCon
nec

{-
************************************************************************
*                                                                      *
\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
*                                                                      *
************************************************************************
-}

tcDoStmts :: HsStmtContext Name
          -> Located [LStmt GhcRn (LHsExpr GhcRn)]
          -> ExpRhoType
          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo
tcDoStmts :: HsStmtContext Name
-> Located [GuardLStmt GhcRn]
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcDoStmts HsStmtContext Name
ListComp (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpSigmaType
res_ty
  = do  { TcSigmaType
res_ty <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
expTypeToType ExpSigmaType
res_ty
        ; (TcCoercionN
co, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionN, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
        ; let list_ty :: TcSigmaType
list_ty = TcSigmaType -> TcSigmaType
mkListTy TcSigmaType
elt_ty
        ; [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
forall id. HsStmtContext id
ListComp (TyCon -> TcStmtChecker HsExpr ExpSigmaType
tcLcStmt TyCon
listTyCon) [GuardLStmt GhcRn]
stmts
                            (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
elt_ty)
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionN -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionN -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionN
co (XDo GhcTcId
-> HsStmtContext Name
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
list_ty HsStmtContext Name
forall id. HsStmtContext id
ListComp (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext Name
DoExpr (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpSigmaType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
forall id. HsStmtContext id
DoExpr TcStmtChecker HsExpr ExpSigmaType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpSigmaType
res_ty
        ; TcSigmaType
res_ty <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTcId
-> HsStmtContext Name
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext Name
forall id. HsStmtContext id
DoExpr (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext Name
MDoExpr (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpSigmaType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
forall id. HsStmtContext id
MDoExpr TcStmtChecker HsExpr ExpSigmaType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpSigmaType
res_ty
        ; TcSigmaType
res_ty <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTcId
-> HsStmtContext Name
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext Name
forall id. HsStmtContext id
MDoExpr (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext Name
MonadComp (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpSigmaType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
forall id. HsStmtContext id
MonadComp TcStmtChecker HsExpr ExpSigmaType
tcMcStmt [GuardLStmt GhcRn]
stmts ExpSigmaType
res_ty
        ; TcSigmaType
res_ty <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTcId
-> HsStmtContext Name
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext Name
forall id. HsStmtContext id
MonadComp (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext Name
ctxt Located [GuardLStmt GhcRn]
_ ExpSigmaType
_ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (HsStmtContext Name -> SDoc
forall id.
(Outputable id, Outputable (NameOrRdrName id)) =>
HsStmtContext id -> SDoc
pprStmtContext HsStmtContext Name
ctxt)

tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody LHsExpr GhcRn
body ExpSigmaType
res_ty
  = do  { String -> SDoc -> TcRn ()
traceTc String
"tcBody" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
        ; LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
body ExpSigmaType
res_ty
        }

{-
************************************************************************
*                                                                      *
\subsection{tcStmts}
*                                                                      *
************************************************************************
-}

type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType

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

tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
        -> TcStmtChecker body rho_type   -- NB: higher-rank type
        -> [LStmt GhcRn (Located (body GhcRn))]
        -> rho_type
        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts :: HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty
  = do { ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', ()
_) <- HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], ())
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty ((rho_type -> TcRn ())
 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], ()))
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], ())
forall a b. (a -> b) -> a -> b
$
                        TcRn () -> rho_type -> TcRn ()
forall a b. a -> b -> a
const (() -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; [LStmt GhcTcId (Located (body GhcTcId))]
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
forall (m :: * -> *) a. Monad m => a -> m a
return [LStmt GhcTcId (Located (body GhcTcId))]
stmts' }

tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
               -> TcStmtChecker body rho_type    -- NB: higher-rank type
               -> [LStmt GhcRn (Located (body GhcRn))]
               -> rho_type
               -> (rho_type -> TcM thing)
               -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)

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

tcStmtsAndThen :: HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
_ TcStmtChecker body rho_type
_ [] rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { thing
thing <- rho_type -> TcM thing
thing_inside rho_type
res_ty
        ; ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }

-- LetStmts are handled uniformly, regardless of context
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpan
loc (LetStmt XLetStmt GhcRn GhcRn (Located (body GhcRn))
x (L SrcSpan
l HsLocalBinds GhcRn
binds)) : [LStmt GhcRn (Located (body GhcRn))]
stmts)
                                                             rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { (HsLocalBinds GhcTcId
binds', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts',thing
thing)) <- HsLocalBinds GhcRn
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM
     (HsLocalBinds GhcTcId,
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
 -> TcM
      (HsLocalBinds GhcTcId,
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM
     (HsLocalBinds GhcTcId,
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$
              HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty rho_type -> TcM thing
thing_inside
        ; ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
-> LStmt GhcTcId (Located (body GhcTcId))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLetStmt GhcTcId GhcTcId (Located (body GhcTcId))
-> LHsLocalBinds GhcTcId
-> StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (Located (body GhcRn))
XLetStmt GhcTcId GhcTcId (Located (body GhcTcId))
x (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds')) LStmt GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (Located (body GhcTcId))]
-> [LStmt GhcTcId (Located (body GhcTcId))]
forall a. a -> [a] -> [a]
: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing) }

-- 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).
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpan
loc StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt : [LStmt GhcRn (Located (body GhcRn))]
stmts) rho_type
res_ty rho_type -> TcM thing
thing_inside
  | ApplicativeStmt{} <- StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt
  = do  { (StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing)) <-
             HsStmtContext Name
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> rho_type
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContext Name
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt rho_type
res_ty ((rho_type
  -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
               HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty'  ((rho_type -> TcM thing)
 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a b. (a -> b) -> a -> b
$
                 rho_type -> TcM thing
thing_inside
        ; ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
-> LStmt GhcTcId (Located (body GhcTcId))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt' LStmt GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (Located (body GhcTcId))]
-> [LStmt GhcTcId (Located (body GhcTcId))]
forall a. a -> [a] -> [a]
: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing) }

  -- For the vanilla case, handle the location-setting part
  | Bool
otherwise
  = do  { (StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing)) <-
                SrcSpan
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc                              (TcM
   (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
    ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$
                SDoc
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (IdP GhcRn)
-> StmtLR GhcRn GhcRn (Located (body GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body) =>
HsStmtContext (IdP (GhcPass idL))
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext Name
HsStmtContext (IdP GhcRn)
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt)        (TcM
   (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
    ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$
                HsStmtContext Name
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> rho_type
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContext Name
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt rho_type
res_ty                   ((rho_type
  -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
                TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a. TcM a -> TcM a
popErrCtxt                                  (TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a b. (a -> b) -> a -> b
$
                HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty'  ((rho_type -> TcM thing)
 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a b. (a -> b) -> a -> b
$
                rho_type -> TcM thing
thing_inside
        ; ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
-> LStmt GhcTcId (Located (body GhcTcId))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt' LStmt GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (Located (body GhcTcId))]
-> [LStmt GhcTcId (Located (body GhcTcId))]
forall a. a -> [a] -> [a]
: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing) }

---------------------------------------------------
--              Pattern guards
---------------------------------------------------

tcGuardStmt :: TcExprStmtChecker
tcGuardStmt :: HsStmtContext Name
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> (ExpSigmaType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcGuardStmt HsStmtContext Name
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
guard SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
guard' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
guard (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
boolTy)
        ; thing
thing  <- ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
res_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcSigmaType
XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
boolTy LHsExpr GhcTcId
guard' SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcGuardStmt HsStmtContext Name
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { (LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
rhs
                                   -- Stmt has a context already
        ; (Located (Pat GhcTcId)
pat', thing
thing)  <- HsMatchContext Name
-> CtOrigin
-> LPat GhcRn
-> ExpSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> CtOrigin
-> LPat GhcRn
-> ExpSigmaType
-> TcM a
-> TcM (LPat GhcTcId, a)
tcPat_O (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
rhs)
                                    LPat GhcRn
pat (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                            ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
res_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTcId -> LHsExpr GhcTcId -> Stmt GhcTcId (LHsExpr GhcTcId)
forall (bodyR :: * -> *).
LPat GhcTcId
-> Located (bodyR GhcTcId)
-> StmtLR GhcTcId GhcTcId (Located (bodyR GhcTcId))
mkTcBindStmt Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

tcGuardStmt HsStmtContext Name
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpSigmaType
_ ExpSigmaType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcGuardStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)


---------------------------------------------------
--           List comprehensions
--               (no rebindable syntax)
---------------------------------------------------

-- Dealt with separately, rather than by tcMcStmt, because
--   a) We have special desugaring rules for list comprehensions,
--      which avoid creating intermediate lists.  They in turn
--      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

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

tcLcStmt :: TyCon -> TcStmtChecker HsExpr ExpSigmaType
tcLcStmt TyCon
_ HsStmtContext Name
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Bool
noret SyntaxExpr GhcRn
_) ExpSigmaType
elt_ty ExpSigmaType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body ExpSigmaType
elt_ty
       ; thing
thing <- ExpSigmaType -> TcM thing
thing_inside (String -> ExpSigmaType
forall a. String -> a
panic String
"tcLcStmt: thing_inside")
       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Bool
noret SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

-- A generator, pat <- rhs
tcLcStmt TyCon
m_tc HsStmtContext Name
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpSigmaType
elt_ty ExpSigmaType -> TcM thing
thing_inside
 = do   { TcSigmaType
pat_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
        ; LHsExpr GhcTcId
rhs'   <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType (TcSigmaType -> ExpSigmaType) -> TcSigmaType -> ExpSigmaType
forall a b. (a -> b) -> a -> b
$ TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
m_tc [TcSigmaType
pat_ty])
        ; (Located (Pat GhcTcId)
pat', thing
thing)  <- HsMatchContext Name
-> LPat GhcRn
-> ExpSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcRn
pat (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                            ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
elt_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTcId -> LHsExpr GhcTcId -> Stmt GhcTcId (LHsExpr GhcTcId)
forall (bodyR :: * -> *).
LPat GhcTcId
-> Located (bodyR GhcTcId)
-> StmtLR GhcTcId GhcTcId (Located (bodyR GhcTcId))
mkTcBindStmt Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

-- A boolean guard
tcLcStmt TyCon
_ HsStmtContext Name
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpSigmaType
elt_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
rhs'  <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
boolTy)
        ; thing
thing <- ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
elt_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcSigmaType
XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
boolTy LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

-- ParStmt: See notes with tcMcStmt
tcLcStmt TyCon
m_tc HsStmtContext Name
ctxt (ParStmt XParStmt GhcRn GhcRn (LHsExpr GhcRn)
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpSigmaType
elt_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { ([ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) <- [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> [ParStmtBlock GhcTcId GhcTcId]
-> HsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt TcSigmaType
XParStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
unitTy [ParStmtBlock GhcTcId GhcTcId]
pairs' HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
  where
    -- loop :: [([LStmt GhcRn], [GhcRn])]
    --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
    loop :: [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop [] = do { thing
thing <- ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
elt_ty
                 ; ([ParStmtBlock GhcTcId GhcTcId], thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }         -- matching in the branches

    loop (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
_ : [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([TcId]
ids, [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing))
                <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType
    -> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt (TyCon -> TcStmtChecker HsExpr ExpSigmaType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpSigmaType
elt_ty ((ExpSigmaType
  -> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing)))
-> (ExpSigmaType
    -> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
_elt_ty' ->
                   do { [TcId]
ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
[IdP GhcRn]
names
                      ; ([ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) <- [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop [ParStmtBlock GhcRn GhcRn]
pairs
                      ; ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing)
-> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
ids, [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) }
           ; ([ParStmtBlock GhcTcId GhcTcId], thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XParStmtBlock GhcTcId GhcTcId
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> [IdP GhcTcId]
-> SyntaxExpr GhcTcId
-> ParStmtBlock GhcTcId GhcTcId
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTcId GhcTcId
x [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' [TcId]
[IdP GhcTcId]
ids SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr ParStmtBlock GhcTcId GhcTcId
-> [ParStmtBlock GhcTcId GhcTcId] -> [ParStmtBlock GhcTcId GhcTcId]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing ) }
    loop (XParStmtBlock XXParStmtBlock GhcRn GhcRn
nec:[ParStmtBlock GhcRn GhcRn]
_) = NoExtCon
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall a. NoExtCon -> a
noExtCon XXParStmtBlock GhcRn GhcRn
NoExtCon
nec

tcLcStmt TyCon
m_tc HsStmtContext Name
ctxt (TransStmt { trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form, trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts
                              , trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs =  [(IdP GhcRn, IdP GhcRn)]
bindersMap
                              , trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using }) ExpSigmaType
elt_ty ExpSigmaType -> TcM thing
thing_inside
  = do { let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap
             unused_ty :: ExpSigmaType
unused_ty = String -> SDoc -> ExpSigmaType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: inner ty" ([(Name, Name)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap)
             -- The inner 'stmts' lack a LastStmt, so the element type
             --  passed in to tcStmtsAndThen is never looked at
       ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([TcId]
bndr_ids, Maybe (LHsExpr GhcTcId, TcSigmaType)
by'))
            <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType
    -> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen (HsStmtContext Name -> HsStmtContext Name
forall id. HsStmtContext id -> HsStmtContext id
TransStmtCtxt HsStmtContext Name
ctxt) (TyCon -> TcStmtChecker HsExpr ExpSigmaType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpSigmaType
unused_ty ((ExpSigmaType
  -> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType))))
-> (ExpSigmaType
    -> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
forall a b. (a -> b) -> a -> b
$ \ExpSigmaType
_ -> do
               { Maybe (LHsExpr GhcTcId, TcSigmaType)
by' <- (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> Maybe (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe (LHsExpr GhcTcId, TcSigmaType))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho Maybe (LHsExpr GhcRn)
by
               ; [TcId]
bndr_ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
bndr_names
               ; ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType))
-> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType))
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
bndr_ids, Maybe (LHsExpr GhcTcId, TcSigmaType)
by') }

       ; let m_app :: TcSigmaType -> TcSigmaType
m_app TcSigmaType
ty = TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
m_tc [TcSigmaType
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 :: TcSigmaType -> TcSigmaType
n_app = case TransForm
form of
                       TransForm
ThenForm -> (\TcSigmaType
ty -> TcSigmaType
ty)
                       TransForm
_        -> TcSigmaType -> TcSigmaType
m_app

             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
             by_arrow :: TcSigmaType -> TcSigmaType
by_arrow = case Maybe (LHsExpr GhcTcId, TcSigmaType)
by' of
                          Maybe (LHsExpr GhcTcId, TcSigmaType)
Nothing       -> \TcSigmaType
ty -> TcSigmaType
ty
                          Just (LHsExpr GhcTcId
_,TcSigmaType
e_ty) -> \TcSigmaType
ty -> (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
e_ty) TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
ty

             tup_ty :: TcSigmaType
tup_ty        = [TcId] -> TcSigmaType
mkBigCoreVarTupTy [TcId]
bndr_ids
             poly_arg_ty :: TcSigmaType
poly_arg_ty   = TcSigmaType -> TcSigmaType
m_app TcSigmaType
alphaTy
             poly_res_ty :: TcSigmaType
poly_res_ty   = TcSigmaType -> TcSigmaType
m_app (TcSigmaType -> TcSigmaType
n_app TcSigmaType
alphaTy)
             using_poly_ty :: TcSigmaType
using_poly_ty = TcId -> TcSigmaType -> TcSigmaType
mkInvForAllTy TcId
alphaTyVar (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType -> TcSigmaType
by_arrow (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType
poly_arg_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
poly_res_ty

       ; LHsExpr GhcTcId
using' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
using TcSigmaType
using_poly_ty
       ; let final_using :: LHsExpr GhcTcId
final_using = (HsExpr GhcTcId -> HsExpr GhcTcId)
-> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
tup_ty)) LHsExpr GhcTcId
using'

             -- '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
       ; let mk_n_bndr :: Name -> TcId -> TcId
             mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr Name
n_bndr_name TcId
bndr_id = Name -> TcSigmaType -> TcId
mkLocalIdOrCoVar Name
n_bndr_name (TcSigmaType -> TcSigmaType
n_app (TcId -> TcSigmaType
idType TcId
bndr_id))

             -- Ensure that every old binder of type `b` is linked up with its
             -- new binder which should have type `n b`
             -- See Note [GroupStmt binder map] in GHC.Hs.Expr
             n_bndr_ids :: [TcId]
n_bndr_ids  = (Name -> TcId -> TcId) -> [Name] -> [TcId] -> [TcId]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> TcId -> TcId
mk_n_bndr [Name]
n_bndr_names [TcId]
bndr_ids
             bindersMap' :: [(TcId, TcId)]
bindersMap' = [TcId]
bndr_ids [TcId] -> [TcId] -> [(TcId, TcId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcId]
n_bndr_ids

       -- Type check the thing in the environment with
       -- these new binders and return the result
       ; thing
thing <- [TcId] -> TcM thing -> TcM thing
forall a. [TcId] -> TcM a -> TcM a
tcExtendIdEnv [TcId]
n_bndr_ids (ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
elt_ty)

       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt :: forall idL idR body.
XTransStmt idL idR body
-> TransForm
-> [ExprLStmt idL]
-> [(IdP idR, IdP idR)]
-> LHsExpr idR
-> Maybe (LHsExpr idR)
-> SyntaxExpr idR
-> SyntaxExpr idR
-> HsExpr idR
-> StmtLR idL idR body
TransStmt { trS_stmts :: [LStmt GhcTcId (LHsExpr GhcTcId)]
trS_stmts = [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', trS_bndrs :: [(IdP GhcTcId, IdP GhcTcId)]
trS_bndrs = [(TcId, TcId)]
[(IdP GhcTcId, IdP GhcTcId)]
bindersMap'
                           , trS_by :: Maybe (LHsExpr GhcTcId)
trS_by = ((LHsExpr GhcTcId, TcSigmaType) -> LHsExpr GhcTcId)
-> Maybe (LHsExpr GhcTcId, TcSigmaType) -> Maybe (LHsExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsExpr GhcTcId, TcSigmaType) -> LHsExpr GhcTcId
forall a b. (a, b) -> a
fst Maybe (LHsExpr GhcTcId, TcSigmaType)
by', trS_using :: LHsExpr GhcTcId
trS_using = LHsExpr GhcTcId
final_using
                           , trS_ret :: SyntaxExpr GhcTcId
trS_ret = SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
                           , trS_bind :: SyntaxExpr GhcTcId
trS_bind = SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
                           , trS_fmap :: HsExpr GhcTcId
trS_fmap = HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                           , trS_ext :: XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
trS_ext = TcSigmaType
XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
unitTy
                           , trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }

tcLcStmt TyCon
_ HsStmtContext Name
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpSigmaType
_ ExpSigmaType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)


---------------------------------------------------
--           Monad comprehensions
--        (supports rebindable syntax)
---------------------------------------------------

tcMcStmt :: TcExprStmtChecker

tcMcStmt :: HsStmtContext Name
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> (ExpSigmaType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcMcStmt HsStmtContext Name
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Bool
noret SyntaxExpr GhcRn
return_op) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { (LHsExpr GhcTcId
body', SyntaxExpr GhcTcId
return_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op [SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
a_ty] ->
               LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
a_ty)
        ; thing
thing      <- ExpSigmaType -> TcM thing
thing_inside (String -> ExpSigmaType
forall a. String -> a
panic String
"tcMcStmt: thing_inside")
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Bool
noret SyntaxExpr GhcTcId
return_op', thing
thing) }

-- Generators for monad comprehensions ( pat <- rhs )
--
--   [ body | q <- gen ]  ->  gen :: m a
--                            q   ::   a
--

tcMcStmt HsStmtContext Name
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs SyntaxExpr GhcRn
bind_op SyntaxExpr GhcRn
fail_op) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
  = do  { ((LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', thing
thing, TcSigmaType
new_res_ty), SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
bind_op
                          [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM
       (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
 -> TcM
      ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
pat_ty, TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty)
                  ; (Located (Pat GhcTcId)
pat', thing
thing) <- HsMatchContext Name
-> LPat GhcRn
-> ExpSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcRn
pat
                                           (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                                     ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)
                  ; (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType)
-> TcM (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', thing
thing, TcSigmaType
new_res_ty) }

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; SyntaxExpr GhcTcId
fail_op' <- CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (SyntaxExpr GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
MCompPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
fail_op TcSigmaType
new_res_ty

        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LPat GhcTcId
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt TcSigmaType
XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
new_res_ty Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
bind_op' SyntaxExpr GhcTcId
fail_op', thing
thing) }

-- Boolean expressions.
--
--   [ body | stmts, expr ]  ->  expr :: m Bool
--
tcMcStmt HsStmtContext Name
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
guard_op) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { -- Deal with rebindable syntax:
          --    guard_op :: test_ty -> rhs_ty
          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
          -- Where test_ty is, for example, Bool
        ; ((thing
thing, LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, SyntaxExpr GhcTcId
guard_op'), SyntaxExpr GhcTcId
then_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId))
-> TcM
     ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId))
 -> TcM
      ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId))
-> TcM
     ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
new_res_ty] ->
               do { (LHsExpr GhcTcId
rhs', SyntaxExpr GhcTcId
guard_op')
                      <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
guard_op [SyntaxOpType
SynAny]
                                    (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty) (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                         \ [TcSigmaType
test_ty] ->
                         LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
test_ty)
                  ; thing
thing <- ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)
                  ; (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId)
-> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, SyntaxExpr GhcTcId
guard_op') }
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcSigmaType
XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
rhs_ty LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
then_op' SyntaxExpr GhcTcId
guard_op', thing
thing) }

-- 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)

-- We type [ body | (stmts, group by e using f), ... ]
--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
--
-- We type the functions as follows:
--     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)
--
tcMcStmt HsStmtContext Name
ctxt (TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcRn, IdP GhcRn)]
bindersMap
                         , trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using, trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form
                         , trS_ret :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_ret = SyntaxExpr GhcRn
return_op, trS_bind :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_bind = SyntaxExpr GhcRn
bind_op
                         , trS_fmap :: forall idL idR body. StmtLR idL idR body -> HsExpr idR
trS_fmap = HsExpr GhcRn
fmap_op }) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do { TcSigmaType
m1_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind
       ; TcSigmaType
m2_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind
       ; TcSigmaType
tup_ty  <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
       ; TcSigmaType
by_e_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind  -- The type of the 'by' expression (if any)

         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
       ; TcSigmaType -> TcSigmaType
n_app <- case TransForm
form of
                    TransForm
ThenForm -> (TcSigmaType -> TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcSigmaType -> TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (\TcSigmaType
ty -> TcSigmaType
ty)
                    TransForm
_        -> do { TcSigmaType
n_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind
                                   ; (TcSigmaType -> TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcSigmaType -> TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcSigmaType
n_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy`) }
       ; let by_arrow :: Type -> Type
             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
             --                          or res                    ('by' absent)
             by_arrow :: TcSigmaType -> TcSigmaType
by_arrow = case Maybe (LHsExpr GhcRn)
by of
                          Maybe (LHsExpr GhcRn)
Nothing -> \TcSigmaType
res -> TcSigmaType
res
                          Just {} -> \TcSigmaType
res -> (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
by_e_ty) TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
res

             poly_arg_ty :: TcSigmaType
poly_arg_ty  = TcSigmaType
m1_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
alphaTy
             using_arg_ty :: TcSigmaType
using_arg_ty = TcSigmaType
m1_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
tup_ty
             poly_res_ty :: TcSigmaType
poly_res_ty  = TcSigmaType
m2_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType -> TcSigmaType
n_app TcSigmaType
alphaTy
             using_res_ty :: TcSigmaType
using_res_ty = TcSigmaType
m2_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType -> TcSigmaType
n_app TcSigmaType
tup_ty
             using_poly_ty :: TcSigmaType
using_poly_ty = TcId -> TcSigmaType -> TcSigmaType
mkInvForAllTy TcId
alphaTyVar (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType -> TcSigmaType
by_arrow (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType
poly_arg_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
poly_res_ty

             -- '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
       ; let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap
       ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([TcId]
bndr_ids, Maybe (LHsExpr GhcTcId)
by', SyntaxExpr GhcTcId
return_op')) <-
            HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType
    -> TcM ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen (HsStmtContext Name -> HsStmtContext Name
forall id. HsStmtContext id -> HsStmtContext id
TransStmtCtxt HsStmtContext Name
ctxt) TcStmtChecker HsExpr ExpSigmaType
tcMcStmt [GuardLStmt GhcRn]
stmts
                           (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
using_arg_ty) ((ExpSigmaType
  -> TcM ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId)))
-> (ExpSigmaType
    -> TcM ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
forall a b. (a -> b) -> a -> b
$ \ExpSigmaType
res_ty' -> do
                { Maybe (LHsExpr GhcTcId)
by' <- case Maybe (LHsExpr GhcRn)
by of
                           Maybe (LHsExpr GhcRn)
Nothing -> Maybe (LHsExpr GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsExpr GhcTcId)
forall a. Maybe a
Nothing
                           Just LHsExpr GhcRn
e  -> do { LHsExpr GhcTcId
e' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
e
                                                   (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
by_e_ty)
                                         ; Maybe (LHsExpr GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId -> Maybe (LHsExpr GhcTcId)
forall a. a -> Maybe a
Just LHsExpr GhcTcId
e') }

                -- Find the Ids (and hence types) of all old binders
                ; [TcId]
bndr_ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
bndr_names

                -- 'return' is only used for the binders, so we know its type.
                --   return :: (a,b,c,..) -> m (a,b,c,..)
                ; (()
_, SyntaxExpr GhcTcId
return_op') <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                       [TcSigmaType -> SyntaxOpType
synKnownType ([TcId] -> TcSigmaType
mkBigCoreVarTupTy [TcId]
bndr_ids)]
                                       ExpSigmaType
res_ty' (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                ; ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId)
-> TcM ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
bndr_ids, Maybe (LHsExpr GhcTcId)
by', SyntaxExpr GhcTcId
return_op') }

       --------------- Typecheck the 'bind' function -------------
       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
       ; TcSigmaType
new_res_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
       ; (()
_, SyntaxExpr GhcTcId
bind_op')  <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
bind_op
                             [ TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
using_res_ty
                             , TcSigmaType -> SyntaxOpType
synKnownType (TcSigmaType -> TcSigmaType
n_app TcSigmaType
tup_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
new_res_ty) ]
                             ExpSigmaType
res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

       --------------- Typecheck the 'fmap' function -------------
       ; HsExpr GhcTcId
fmap_op' <- case TransForm
form of
                       TransForm
ThenForm -> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                       TransForm
_ -> (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcTcId -> HsExpr GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (TcM (LHsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> (TcSigmaType -> TcM (LHsExpr GhcTcId))
-> TcSigmaType
-> TcM (HsExpr GhcTcId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
fmap_op) (TcSigmaType -> TcM (HsExpr GhcTcId))
-> TcSigmaType -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                            TcId -> TcSigmaType -> TcSigmaType
mkInvForAllTy TcId
alphaTyVar (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                            TcId -> TcSigmaType -> TcSigmaType
mkInvForAllTy TcId
betaTyVar  (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                            (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
betaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` (TcSigmaType -> TcSigmaType
n_app TcSigmaType
alphaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` (TcSigmaType -> TcSigmaType
n_app TcSigmaType
betaTy)

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

       ; LHsExpr GhcTcId
using' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
using TcSigmaType
using_poly_ty
       ; let final_using :: LHsExpr GhcTcId
final_using = (HsExpr GhcTcId -> HsExpr GhcTcId)
-> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
tup_ty)) LHsExpr GhcTcId
using'

       --------------- Bulding the bindersMap ----------------
       ; let mk_n_bndr :: Name -> TcId -> TcId
             mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr Name
n_bndr_name TcId
bndr_id = Name -> TcSigmaType -> TcId
mkLocalIdOrCoVar Name
n_bndr_name (TcSigmaType -> TcSigmaType
n_app (TcId -> TcSigmaType
idType TcId
bndr_id))

             -- Ensure that every old binder of type `b` is linked up with its
             -- new binder which should have type `n b`
             -- See Note [GroupStmt binder map] in GHC.Hs.Expr
             n_bndr_ids :: [TcId]
n_bndr_ids = (Name -> TcId -> TcId) -> [Name] -> [TcId] -> [TcId]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> TcId -> TcId
mk_n_bndr [Name]
n_bndr_names [TcId]
bndr_ids
             bindersMap' :: [(TcId, TcId)]
bindersMap' = [TcId]
bndr_ids [TcId] -> [TcId] -> [(TcId, TcId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcId]
n_bndr_ids

       -- Type check the thing in the environment with
       -- these new binders and return the result
       ; thing
thing <- [TcId] -> TcM thing -> TcM thing
forall a. [TcId] -> TcM a -> TcM a
tcExtendIdEnv [TcId]
n_bndr_ids (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$
                  ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)

       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt :: forall idL idR body.
XTransStmt idL idR body
-> TransForm
-> [ExprLStmt idL]
-> [(IdP idR, IdP idR)]
-> LHsExpr idR
-> Maybe (LHsExpr idR)
-> SyntaxExpr idR
-> SyntaxExpr idR
-> HsExpr idR
-> StmtLR idL idR body
TransStmt { trS_stmts :: [LStmt GhcTcId (LHsExpr GhcTcId)]
trS_stmts = [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', trS_bndrs :: [(IdP GhcTcId, IdP GhcTcId)]
trS_bndrs = [(TcId, TcId)]
[(IdP GhcTcId, IdP GhcTcId)]
bindersMap'
                           , trS_by :: Maybe (LHsExpr GhcTcId)
trS_by = Maybe (LHsExpr GhcTcId)
by', trS_using :: LHsExpr GhcTcId
trS_using = LHsExpr GhcTcId
final_using
                           , trS_ret :: SyntaxExpr GhcTcId
trS_ret = SyntaxExpr GhcTcId
return_op', trS_bind :: SyntaxExpr GhcTcId
trS_bind = SyntaxExpr GhcTcId
bind_op'
                           , trS_ext :: XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
trS_ext = TcSigmaType -> TcSigmaType
n_app TcSigmaType
tup_ty
                           , trS_fmap :: HsExpr GhcTcId
trS_fmap = HsExpr GhcTcId
fmap_op', trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }

-- A parallel set of comprehensions
--      [ (g x, h x) | ... ; let g v = ...
--                   | ... ; let h v = ... ]
--
-- It's possible that g,h are overloaded, so we need to feed the LIE from the
-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
-- Similarly if we had an existential pattern match:
--
--      data T = forall a. Show a => C a
--
--      [ (show x, show y) | ... ; C x <- ...
--                         | ... ; C y <- ... ]
--
-- Then we need the LIE from (show x, show y) to be simplified against
-- the bindings for x and y.
--
-- It's difficult to do this in parallel, so we rely on the renamer to
-- 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.
--
-- Note: The `mzip` function will get typechecked via:
--
--   ParStmt [st1::t1, st2::t2, st3::t3]
--
--   mzip :: m st1
--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
--        -> m (st1, (st2, st3))
--
tcMcStmt HsStmtContext Name
ctxt (ParStmt XParStmt GhcRn GhcRn (LHsExpr GhcRn)
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
mzip_op SyntaxExpr GhcRn
bind_op) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do { TcSigmaType
m_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind

       ; let mzip_ty :: TcSigmaType
mzip_ty  = [TcId] -> TcSigmaType -> TcSigmaType
mkInvForAllTys [TcId
alphaTyVar, TcId
betaTyVar] (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
alphaTy)
                        TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy`
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
betaTy)
                        TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy`
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` [TcSigmaType] -> TcSigmaType
mkBoxedTupleTy [TcSigmaType
alphaTy, TcSigmaType
betaTy])
       ; HsExpr GhcTcId
mzip_op' <- LHsExpr GhcTcId -> HsExpr GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
mzip_op) TcSigmaType
mzip_ty

        -- type dummies since we don't know all binder types yet
       ; [[TcSigmaType]]
id_tys_s <- (([Name] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
-> [[Name]] -> IOEnv (Env TcGblEnv TcLclEnv) [[TcSigmaType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Name] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
 -> [[Name]] -> IOEnv (Env TcGblEnv TcLclEnv) [[TcSigmaType]])
-> ((Name -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType)
    -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType)
-> [[Name]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[TcSigmaType]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM) (IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> Name -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
forall a b. a -> b -> a
const (TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind))
                       [ [Name]
[IdP GhcRn]
names | ParStmtBlock XParStmtBlock GhcRn GhcRn
_ [GuardLStmt GhcRn]
_ [IdP GhcRn]
names SyntaxExpr GhcRn
_ <- [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s ]

       -- Typecheck bind:
       ; let tup_tys :: [TcSigmaType]
tup_tys  = [ [TcSigmaType] -> TcSigmaType
mkBigCoreTupTy [TcSigmaType]
id_tys | [TcSigmaType]
id_tys <- [[TcSigmaType]]
id_tys_s ]
             tuple_ty :: TcSigmaType
tuple_ty = [TcSigmaType] -> TcSigmaType
forall (t :: * -> *). Foldable t => t TcSigmaType -> TcSigmaType
mk_tuple_ty [TcSigmaType]
tup_tys

       ; ((([ParStmtBlock GhcTcId GhcTcId]
blocks', thing
thing), TcSigmaType
inner_res_ty), SyntaxExpr GhcTcId
bind_op')
           <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
-> TcM
     ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
bind_op
                         [ TcSigmaType -> SyntaxOpType
synKnownType (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
tuple_ty)
                         , SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tuple_ty) SyntaxOpType
SynRho ] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
 -> TcM
      ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
-> TcM
     ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
              \ [TcSigmaType
inner_res_ty] ->
              do { ([ParStmtBlock GhcTcId GhcTcId], thing)
stuff <- TcSigmaType
-> ExpSigmaType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
m_ty (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
inner_res_ty)
                                 [TcSigmaType]
tup_tys [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s
                 ; (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType)
-> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParStmtBlock GhcTcId GhcTcId], thing)
stuff, TcSigmaType
inner_res_ty) }

       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> [ParStmtBlock GhcTcId GhcTcId]
-> HsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt TcSigmaType
XParStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
inner_res_ty [ParStmtBlock GhcTcId GhcTcId]
blocks' HsExpr GhcTcId
mzip_op' SyntaxExpr GhcTcId
bind_op', thing
thing) }

  where
    mk_tuple_ty :: t TcSigmaType -> TcSigmaType
mk_tuple_ty t TcSigmaType
tys = (TcSigmaType -> TcSigmaType -> TcSigmaType)
-> t TcSigmaType -> TcSigmaType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\TcSigmaType
tn TcSigmaType
tm -> [TcSigmaType] -> TcSigmaType
mkBoxedTupleTy [TcSigmaType
tn, TcSigmaType
tm]) t TcSigmaType
tys

       -- loop :: Type                                  -- m_ty
       --      -> ExpRhoType                            -- inner_res_ty
       --      -> [TcType]                              -- tup_tys
       --      -> [ParStmtBlock Name]
       --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
    loop :: TcSigmaType
-> ExpSigmaType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
_ ExpSigmaType
inner_res_ty [] [] = do { thing
thing <- ExpSigmaType -> TcM thing
thing_inside ExpSigmaType
inner_res_ty
                                   ; ([ParStmtBlock GhcTcId GhcTcId], thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }
                                   -- matching in the branches

    loop TcSigmaType
m_ty ExpSigmaType
inner_res_ty (TcSigmaType
tup_ty_in : [TcSigmaType]
tup_tys_in)
                           (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
return_op : [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { let m_tup_ty :: TcSigmaType
m_tup_ty = TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
tup_ty_in
           ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([TcId]
ids, SyntaxExpr GhcTcId
return_op', [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing))
                <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType
    -> TcM
         ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
          thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
       thing))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker HsExpr ExpSigmaType
tcMcStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
m_tup_ty) ((ExpSigmaType
  -> TcM
       ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
        thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
        thing)))
-> (ExpSigmaType
    -> TcM
         ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
          thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
       thing))
forall a b. (a -> b) -> a -> b
$
                   \ExpSigmaType
m_tup_ty' ->
                   do { [TcId]
ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
[IdP GhcRn]
names
                      ; let tup_ty :: TcSigmaType
tup_ty = [TcId] -> TcSigmaType
mkBigCoreVarTupTy [TcId]
ids
                      ; (()
_, SyntaxExpr GhcTcId
return_op') <-
                          CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                     [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty] ExpSigmaType
m_tup_ty' (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                                     \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      ; ([ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) <- TcSigmaType
-> ExpSigmaType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
m_ty ExpSigmaType
inner_res_ty [TcSigmaType]
tup_tys_in [ParStmtBlock GhcRn GhcRn]
pairs
                      ; ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId], thing)
-> TcM
     ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
ids, SyntaxExpr GhcTcId
return_op', [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) }
           ; ([ParStmtBlock GhcTcId GhcTcId], thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmtBlock GhcTcId GhcTcId
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> [IdP GhcTcId]
-> SyntaxExpr GhcTcId
-> ParStmtBlock GhcTcId GhcTcId
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTcId GhcTcId
x [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' [TcId]
[IdP GhcTcId]
ids SyntaxExpr GhcTcId
return_op' ParStmtBlock GhcTcId GhcTcId
-> [ParStmtBlock GhcTcId GhcTcId] -> [ParStmtBlock GhcTcId GhcTcId]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) }
    loop TcSigmaType
_ ExpSigmaType
_ [TcSigmaType]
_ [ParStmtBlock GhcRn GhcRn]
_ = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall a. String -> a
panic String
"tcMcStmt.loop"

tcMcStmt HsStmtContext Name
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpSigmaType
_ ExpSigmaType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)


---------------------------------------------------
--           Do-notation
--        (supports rebindable syntax)
---------------------------------------------------

tcDoStmt :: TcExprStmtChecker

tcDoStmt :: HsStmtContext Name
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> (ExpSigmaType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcDoStmt HsStmtContext Name
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Bool
noret SyntaxExpr GhcRn
_) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body ExpSigmaType
res_ty
       ; thing
thing <- ExpSigmaType -> TcM thing
thing_inside (String -> ExpSigmaType
forall a. String -> a
panic String
"tcDoStmt: thing_inside")
       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Bool
noret SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcDoStmt HsStmtContext Name
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs SyntaxExpr GhcRn
bind_op SyntaxExpr GhcRn
fail_op) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  {       -- Deal with rebindable syntax:
                --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
                -- This level of generality is needed for using do-notation
                -- in full generality; see #1537

          ((LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', TcSigmaType
new_res_ty, thing
thing), SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
bind_op [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM
       (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
 -> TcM
      ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                \ [TcSigmaType
rhs_ty, TcSigmaType
pat_ty, TcSigmaType
new_res_ty] ->
                do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty)
                   ; (Located (Pat GhcTcId)
pat', thing
thing) <- HsMatchContext Name
-> LPat GhcRn
-> ExpSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcRn
pat
                                            (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                                      ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)
                   ; (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing)
-> TcM (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', TcSigmaType
new_res_ty, thing
thing) }

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; SyntaxExpr GhcTcId
fail_op' <- CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (SyntaxExpr GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
fail_op TcSigmaType
new_res_ty

        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LPat GhcTcId
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt TcSigmaType
XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
new_res_ty Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
bind_op' SyntaxExpr GhcTcId
fail_op', thing
thing) }

tcDoStmt HsStmtContext Name
ctxt (ApplicativeStmt XApplicativeStmt GhcRn GhcRn (LHsExpr GhcRn)
_ [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs Maybe (SyntaxExpr GhcRn)
mb_join) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { let tc_app_stmts :: ExpSigmaType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ExpSigmaType
ty = HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpSigmaType
-> (TcSigmaType -> TcM thing)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
forall t.
HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpSigmaType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts HsStmtContext Name
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpSigmaType
ty ((TcSigmaType -> TcM thing)
 -> TcM
      ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing))
-> (TcSigmaType -> TcM thing)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
forall a b. (a -> b) -> a -> b
$
                                ExpSigmaType -> TcM thing
thing_inside (ExpSigmaType -> TcM thing)
-> (TcSigmaType -> ExpSigmaType) -> TcSigmaType -> TcM thing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigmaType -> ExpSigmaType
mkCheckExpType
        ; (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
pairs', TcSigmaType
body_ty, thing
thing), Maybe (SyntaxExpr GhcTcId)
mb_join') <- case Maybe (SyntaxExpr GhcRn)
mb_join of
            Maybe (SyntaxExpr GhcRn)
Nothing -> (, Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing) (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
  thing)
 -> (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing),
     Maybe (SyntaxExpr GhcTcId)))
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing),
      Maybe (SyntaxExpr GhcTcId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpSigmaType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ExpSigmaType
res_ty
            Just SyntaxExpr GhcRn
join_op ->
              (SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId))
-> (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
     thing),
    SyntaxExpr GhcTcId)
-> (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
     thing),
    Maybe (SyntaxExpr GhcTcId))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId)
forall a. a -> Maybe a
Just ((([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
   thing),
  SyntaxExpr GhcTcId)
 -> (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing),
     Maybe (SyntaxExpr GhcTcId)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing),
      SyntaxExpr GhcTcId)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing),
      Maybe (SyntaxExpr GhcTcId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM
         ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
          thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
join_op [SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM
       ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
        thing))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
        thing),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM
         ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
          thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
       thing),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty] -> ExpSigmaType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty))

        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> [(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
-> Maybe (SyntaxExpr GhcTcId)
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt TcSigmaType
XApplicativeStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
body_ty [(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
pairs' Maybe (SyntaxExpr GhcTcId)
mb_join', thing
thing) }

tcDoStmt HsStmtContext Name
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
_) ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  {       -- Deal with rebindable syntax;
                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
        ; ((LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, thing
thing), SyntaxExpr GhcTcId
then_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
-> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpSigmaType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
 -> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
-> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rhs_ty)
                  ; thing
thing <- ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)
                  ; (LHsExpr GhcTcId, TcSigmaType, thing)
-> TcM (LHsExpr GhcTcId, TcSigmaType, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, thing
thing) }
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcSigmaType
XBodyStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
rhs_ty LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
then_op' SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcDoStmt HsStmtContext Name
ctxt (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [GuardLStmt GhcRn]
stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcRn]
later_names
                       , recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcRn]
rec_names, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcRn
ret_op
                       , recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcRn
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcRn
bind_op })
         ExpSigmaType
res_ty ExpSigmaType -> TcM thing
thing_inside
  = do  { let tup_names :: [Name]
tup_names = [Name]
[IdP GhcRn]
rec_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
[IdP GhcRn]
rec_names) [Name]
[IdP GhcRn]
later_names
        ; [TcSigmaType]
tup_elt_tys <- Arity -> TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
newFlexiTyVarTys ([Name] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Name]
tup_names) TcSigmaType
liftedTypeKind
        ; let tup_ids :: [TcId]
tup_ids = (Name -> TcSigmaType -> TcId) -> [Name] -> [TcSigmaType] -> [TcId]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> TcSigmaType -> TcId
mkLocalId [Name]
tup_names [TcSigmaType]
tup_elt_tys
              tup_ty :: TcSigmaType
tup_ty  = [TcSigmaType] -> TcSigmaType
mkBigCoreTupTy [TcSigmaType]
tup_elt_tys

        ; [TcId]
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. [TcId] -> TcM a -> TcM a
tcExtendIdEnv [TcId]
tup_ids (TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
 -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing))
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a b. (a -> b) -> a -> b
$ do
        { (([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (SyntaxExpr GhcTcId
ret_op', [HsExpr GhcTcId]
tup_rets)), TcSigmaType
stmts_ty)
                <- (ExpSigmaType
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
-> TcM
     (([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])),
      TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInferInst ((ExpSigmaType
  -> TcM
       ([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
 -> TcM
      (([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExpr GhcTcId, [HsExpr GhcTcId])),
       TcSigmaType))
-> (ExpSigmaType
    -> TcM
         ([LStmt GhcTcId (LHsExpr GhcTcId)],
          (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
-> TcM
     (([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])),
      TcSigmaType)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
                   HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType -> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker HsExpr ExpSigmaType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpSigmaType
exp_ty ((ExpSigmaType -> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
-> (ExpSigmaType -> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
inner_res_ty ->
                   do { [HsExpr GhcTcId]
tup_rets <- (Name -> ExpSigmaType -> TcM (HsExpr GhcTcId))
-> [Name]
-> [ExpSigmaType]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExpr GhcTcId]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckId [Name]
tup_names
                                      ((TcSigmaType -> ExpSigmaType) -> [TcSigmaType] -> [ExpSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> ExpSigmaType
mkCheckExpType [TcSigmaType]
tup_elt_tys)
                             -- Unify the types of the "final" Ids (which may
                             -- be polymorphic) with those of "knot-tied" Ids
                      ; (()
_, SyntaxExpr GhcTcId
ret_op')
                          <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
ret_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty]
                                        ExpSigmaType
inner_res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \[TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      ; (SyntaxExpr GhcTcId, [HsExpr GhcTcId])
-> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcTcId
ret_op', [HsExpr GhcTcId]
tup_rets) }

        ; ((()
_, SyntaxExpr GhcTcId
mfix_op'), TcSigmaType
mfix_res_ty)
            <- (ExpSigmaType -> TcM ((), SyntaxExpr GhcTcId))
-> TcM (((), SyntaxExpr GhcTcId), TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInferInst ((ExpSigmaType -> TcM ((), SyntaxExpr GhcTcId))
 -> TcM (((), SyntaxExpr GhcTcId), TcSigmaType))
-> (ExpSigmaType -> TcM ((), SyntaxExpr GhcTcId))
-> TcM (((), SyntaxExpr GhcTcId), TcSigmaType)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
               CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
mfix_op
                          [TcSigmaType -> SyntaxOpType
synKnownType (TcSigmaType -> TcSigmaType -> TcSigmaType
mkVisFunTy TcSigmaType
tup_ty TcSigmaType
stmts_ty)] ExpSigmaType
exp_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        ; ((thing
thing, TcSigmaType
new_res_ty), SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (thing, TcSigmaType))
-> TcM ((thing, TcSigmaType), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
bind_op
                          [ TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
mfix_res_ty
                          , TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty SyntaxOpType -> SyntaxOpType -> SyntaxOpType
`SynFun` SyntaxOpType
SynRho ]
                          ExpSigmaType
res_ty (([TcSigmaType] -> TcM (thing, TcSigmaType))
 -> TcM ((thing, TcSigmaType), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (thing, TcSigmaType))
-> TcM ((thing, TcSigmaType), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
new_res_ty] ->
               do { thing
thing <- ExpSigmaType -> TcM thing
thing_inside (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
new_res_ty)
                  ; (thing, TcSigmaType) -> TcM (thing, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, TcSigmaType
new_res_ty) }

        ; let rec_ids :: [TcId]
rec_ids = [Name] -> [TcId] -> [TcId]
forall b a. [b] -> [a] -> [a]
takeList [Name]
[IdP GhcRn]
rec_names [TcId]
tup_ids
        ; [TcId]
later_ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
[IdP GhcRn]
later_names
        ; String -> SDoc -> TcRn ()
traceTc String
"tcdo" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [[TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
rec_ids SDoc -> SDoc -> SDoc
<+> [TcSigmaType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((TcId -> TcSigmaType) -> [TcId] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcId -> TcSigmaType
idType [TcId]
rec_ids),
                                 [TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
later_ids SDoc -> SDoc -> SDoc
<+> [TcSigmaType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((TcId -> TcSigmaType) -> [TcId] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcId -> TcSigmaType
idType [TcId]
later_ids)]
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecStmt :: forall idL idR body.
XRecStmt idL idR body
-> [LStmtLR idL idR body]
-> [IdP idR]
-> [IdP idR]
-> SyntaxExpr idR
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
RecStmt { recS_stmts :: [LStmt GhcTcId (LHsExpr GhcTcId)]
recS_stmts = [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', recS_later_ids :: [IdP GhcTcId]
recS_later_ids = [TcId]
[IdP GhcTcId]
later_ids
                          , recS_rec_ids :: [IdP GhcTcId]
recS_rec_ids = [TcId]
[IdP GhcTcId]
rec_ids, recS_ret_fn :: SyntaxExpr GhcTcId
recS_ret_fn = SyntaxExpr GhcTcId
ret_op'
                          , recS_mfix_fn :: SyntaxExpr GhcTcId
recS_mfix_fn = SyntaxExpr GhcTcId
mfix_op', recS_bind_fn :: SyntaxExpr GhcTcId
recS_bind_fn = SyntaxExpr GhcTcId
bind_op'
                          , recS_ext :: XRecStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
recS_ext = RecStmtTc :: TcSigmaType
-> [HsExpr GhcTcId] -> [HsExpr GhcTcId] -> TcSigmaType -> RecStmtTc
RecStmtTc
                            { recS_bind_ty :: TcSigmaType
recS_bind_ty = TcSigmaType
new_res_ty
                            , recS_later_rets :: [HsExpr GhcTcId]
recS_later_rets = []
                            , recS_rec_rets :: [HsExpr GhcTcId]
recS_rec_rets = [HsExpr GhcTcId]
tup_rets
                            , recS_ret_ty :: TcSigmaType
recS_ret_ty = TcSigmaType
stmts_ty} }, thing
thing)
        }}

tcDoStmt HsStmtContext Name
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpSigmaType
_ ExpSigmaType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)



---------------------------------------------------
-- MonadFail Proposal warnings
---------------------------------------------------

-- The idea behind issuing MonadFail warnings is that we add them whenever a
-- failable pattern is encountered. However, instead of throwing a type error
-- when the constraint cannot be satisfied, we only issue a warning in
-- TcErrors.hs.

tcMonadFailOp :: CtOrigin
              -> LPat GhcTcId
              -> SyntaxExpr GhcRn    -- The fail op
              -> TcType              -- Type of the whole do-expression
              -> TcRn (SyntaxExpr GhcTcId)  -- Typechecked fail op
-- Get a 'fail' operator expression, to use if the pattern
-- match fails. If the pattern is irrefutatable, just return
-- noSyntaxExpr; it won't be used
tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (SyntaxExpr GhcTcId)
tcMonadFailOp CtOrigin
orig LPat GhcTcId
pat SyntaxExpr GhcRn
fail_op TcSigmaType
res_ty
  | LPat GhcTcId -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
isIrrefutableHsPat LPat GhcTcId
pat
  = SyntaxExpr GhcTcId -> TcRn (SyntaxExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr

  | Bool
otherwise
  = ((), SyntaxExpr GhcTcId) -> SyntaxExpr GhcTcId
forall a b. (a, b) -> b
snd (((), SyntaxExpr GhcTcId) -> SyntaxExpr GhcTcId)
-> TcM ((), SyntaxExpr GhcTcId) -> TcRn (SyntaxExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
fail_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
stringTy]
                             (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty) (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \[TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

{-
Note [Treat rebindable syntax first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typechecking
        do { bar; ... } :: IO ()
we want to typecheck 'bar' in the knowledge that it should be an IO thing,
pushing info from the context into the RHS.  To do this, we check the
rebindable syntax first, and push that information into (tcMonoExprNC rhs).
Otherwise the error shows up when checking the rebindable syntax, and
the expected/inferred stuff is back to front (see #3613).

Note [typechecking ApplicativeStmt]

join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)

fresh type variables:
   pat_ty_1..pat_ty_n
   exp_ty_1..exp_ty_n
   t_1..t_(n-1)

body  :: body_ty
(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
pat_i :: pat_ty_i
e_i   :: exp_ty_i
<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
<*>_i :: t_(i-1) -> exp_ty_i -> t_i
join :: tn -> res_ty
-}

tcApplicativeStmts
  :: HsStmtContext Name
  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
  -> ExpRhoType                         -- rhs_ty
  -> (TcRhoType -> TcM t)               -- thing_inside
  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)

tcApplicativeStmts :: HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpSigmaType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts HsStmtContext Name
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpSigmaType
rhs_ty TcSigmaType -> TcM t
thing_inside
 = do { TcSigmaType
body_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
      ; let arity :: Arity
arity = [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs
      ; [ExpSigmaType]
ts <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType -> TcM [ExpSigmaType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM (Arity
arityArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) (IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType -> TcM [ExpSigmaType])
-> IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType -> TcM [ExpSigmaType]
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) ExpSigmaType
newInferExpTypeInst
      ; [TcSigmaType]
exp_tys <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity (IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
 -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
      ; [TcSigmaType]
pat_tys <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity (IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
 -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
      ; let fun_ty :: TcSigmaType
fun_ty = [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [TcSigmaType]
pat_tys TcSigmaType
body_ty

       -- NB. do the <$>,<*> operators first, we don't want type errors here
       --     i.e. goOps before goArgs
       -- See Note [Treat rebindable syntax first]
      ; let ([SyntaxExpr GhcRn]
ops, [ApplicativeArg GhcRn]
args) = [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ([SyntaxExpr GhcRn], [ApplicativeArg GhcRn])
forall a b. [(a, b)] -> ([a], [b])
unzip [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs
      ; [SyntaxExpr GhcTcId]
ops' <- TcSigmaType
-> [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps TcSigmaType
fun_ty ([SyntaxExpr GhcRn]
-> [ExpSigmaType]
-> [TcSigmaType]
-> [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SyntaxExpr GhcRn]
ops ([ExpSigmaType]
ts [ExpSigmaType] -> [ExpSigmaType] -> [ExpSigmaType]
forall a. [a] -> [a] -> [a]
++ [ExpSigmaType
rhs_ty]) [TcSigmaType]
exp_tys)

      -- Typecheck each ApplicativeArg separately
      -- See Note [ApplicativeDo and constraints]
      ; [ApplicativeArg GhcTcId]
args' <- ((ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId))
-> [(ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [ApplicativeArg GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType
-> (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg TcSigmaType
body_ty) ([ApplicativeArg GhcRn]
-> [TcSigmaType]
-> [TcSigmaType]
-> [(ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ApplicativeArg GhcRn]
args [TcSigmaType]
pat_tys [TcSigmaType]
exp_tys)

      -- Bring into scope all the things bound by the args,
      -- and typecheck the thing_inside
      -- See Note [ApplicativeDo and constraints]
      ; t
res <- [TcId] -> TcM t -> TcM t
forall a. [TcId] -> TcM a -> TcM a
tcExtendIdEnv ((ApplicativeArg GhcTcId -> [TcId])
-> [ApplicativeArg GhcTcId] -> [TcId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ApplicativeArg GhcTcId -> [TcId]
get_arg_bndrs [ApplicativeArg GhcTcId]
args') (TcM t -> TcM t) -> TcM t -> TcM t
forall a b. (a -> b) -> a -> b
$
               TcSigmaType -> TcM t
thing_inside TcSigmaType
body_ty

      ; ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxExpr GhcTcId]
-> [ApplicativeArg GhcTcId]
-> [(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SyntaxExpr GhcTcId]
ops' [ApplicativeArg GhcTcId]
args', TcSigmaType
body_ty, t
res) }
  where
    goOps :: TcSigmaType
-> [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps TcSigmaType
_ [] = [SyntaxExpr GhcTcId]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    goOps TcSigmaType
t_left ((SyntaxExpr GhcRn
op,ExpSigmaType
t_i,TcSigmaType
exp_ty) : [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
ops)
      = do { (()
_, SyntaxExpr GhcTcId
op')
               <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
op
                             [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
t_left, TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
exp_ty] ExpSigmaType
t_i (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                   \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; TcSigmaType
t_i <- ExpSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpSigmaType
t_i
           ; [SyntaxExpr GhcTcId]
ops' <- TcSigmaType
-> [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps TcSigmaType
t_i [(SyntaxExpr GhcRn, ExpSigmaType, TcSigmaType)]
ops
           ; [SyntaxExpr GhcTcId]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcTcId
op' SyntaxExpr GhcTcId -> [SyntaxExpr GhcTcId] -> [SyntaxExpr GhcTcId]
forall a. a -> [a] -> [a]
: [SyntaxExpr GhcTcId]
ops') }

    goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
          -> TcM (ApplicativeArg GhcTcId)

    goArg :: TcSigmaType
-> (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg TcSigmaType
body_ty (ApplicativeArgOne
                    { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcRn
pat
                    , arg_expr :: forall idL. ApplicativeArg idL -> LHsExpr idL
arg_expr        = LHsExpr GhcRn
rhs
                    , fail_operator :: forall idL. ApplicativeArg idL -> SyntaxExpr idL
fail_operator   = SyntaxExpr GhcRn
fail_op
                    , Bool
XApplicativeArgOne GhcRn
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
is_body_stmt :: Bool
xarg_app_arg_one :: XApplicativeArgOne GhcRn
..
                    }, TcSigmaType
pat_ty, TcSigmaType
exp_ty)
      = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located (Pat GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (Pat GhcRn)
LPat GhcRn
pat) (LHsExpr GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcRn
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a b. (a -> b) -> a -> b
$
        SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (IdP GhcRn) -> Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body) =>
HsStmtContext (IdP (GhcPass idL))
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext Name
HsStmtContext (IdP GhcRn)
ctxt (LPat GhcRn -> LHsExpr GhcRn -> Stmt GhcRn (LHsExpr GhcRn)
forall (idL :: Pass) (idR :: Pass) (bodyR :: * -> *).
(XBindStmt
   (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 ~ NoExtField) =>
LPat (GhcPass idL)
-> Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBindStmt LPat GhcRn
pat LHsExpr GhcRn
rhs))   (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a b. (a -> b) -> a -> b
$
        do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
exp_ty)
           ; (Located (Pat GhcTcId)
pat', ()
_) <- HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcRn
pat (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
pat_ty) (TcRn () -> TcM (LPat GhcTcId, ()))
-> TcRn () -> TcM (LPat GhcTcId, ())
forall a b. (a -> b) -> a -> b
$
                          () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; SyntaxExpr GhcTcId
fail_op' <- CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (SyntaxExpr GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
fail_op TcSigmaType
body_ty

           ; ApplicativeArg GhcTcId
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne
                      { app_arg_pattern :: LPat GhcTcId
app_arg_pattern = Located (Pat GhcTcId)
LPat GhcTcId
pat'
                      , arg_expr :: LHsExpr GhcTcId
arg_expr        = LHsExpr GhcTcId
rhs'
                      , fail_operator :: SyntaxExpr GhcTcId
fail_operator   = SyntaxExpr GhcTcId
fail_op'
                      , Bool
XApplicativeArgOne GhcRn
XApplicativeArgOne GhcTcId
is_body_stmt :: Bool
xarg_app_arg_one :: XApplicativeArgOne GhcTcId
is_body_stmt :: Bool
xarg_app_arg_one :: XApplicativeArgOne GhcRn
.. }
                    ) }

    goArg TcSigmaType
_body_ty (ApplicativeArgMany XApplicativeArgMany GhcRn
x [GuardLStmt GhcRn]
stmts HsExpr GhcRn
ret LPat GhcRn
pat, TcSigmaType
pat_ty, TcSigmaType
exp_ty)
      = do { ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (HsExpr GhcTcId
ret',Located (Pat GhcTcId)
pat')) <-
                HsStmtContext Name
-> TcStmtChecker HsExpr ExpSigmaType
-> [GuardLStmt GhcRn]
-> ExpSigmaType
-> (ExpSigmaType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (HsExpr GhcTcId, Located (Pat GhcTcId)))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt TcStmtChecker HsExpr ExpSigmaType
tcDoStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
exp_ty) ((ExpSigmaType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (HsExpr GhcTcId, Located (Pat GhcTcId))))
-> (ExpSigmaType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (HsExpr GhcTcId, Located (Pat GhcTcId)))
forall a b. (a -> b) -> a -> b
$
                \ExpSigmaType
res_ty  -> do
                  { L SrcSpan
_ HsExpr GhcTcId
ret' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
ret) ExpSigmaType
res_ty
                  ; (Located (Pat GhcTcId)
pat', ()
_) <- HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcRn
pat (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
pat_ty) (TcRn () -> TcM (LPat GhcTcId, ()))
-> TcRn () -> TcM (LPat GhcTcId, ())
forall a b. (a -> b) -> a -> b
$
                                 () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  ; (HsExpr GhcTcId, Located (Pat GhcTcId))
-> TcM (HsExpr GhcTcId, Located (Pat GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId
ret', Located (Pat GhcTcId)
pat')
                  }
           ; ApplicativeArg GhcTcId
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeArgMany GhcTcId
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
-> LPat GhcTcId
-> ApplicativeArg GhcTcId
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcRn
XApplicativeArgMany GhcTcId
x [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' HsExpr GhcTcId
ret' Located (Pat GhcTcId)
LPat GhcTcId
pat') }

    goArg TcSigmaType
_body_ty (XApplicativeArg XXApplicativeArg GhcRn
nec, TcSigmaType
_, TcSigmaType
_) = NoExtCon -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a. NoExtCon -> a
noExtCon XXApplicativeArg GhcRn
NoExtCon
nec

    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
    get_arg_bndrs :: ApplicativeArg GhcTcId -> [TcId]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcTcId
pat }) = LPat GhcTcId -> [IdP GhcTcId]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTcId
pat
    get_arg_bndrs (ApplicativeArgMany { bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern =  LPat GhcTcId
pat }) = LPat GhcTcId -> [IdP GhcTcId]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTcId
pat
    get_arg_bndrs (XApplicativeArg XXApplicativeArg GhcTcId
nec)          = NoExtCon -> [TcId]
forall a. NoExtCon -> a
noExtCon XXApplicativeArg GhcTcId
NoExtCon
nec

{- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An applicative-do is supposed to take place in parallel, so
constraints bound in one arm can't possibly be available in another
(#13242).  Our current rule is this (more details and discussion
on the ticket). Consider

   ...stmts...
   ApplicativeStmts [arg1, arg2, ... argN]
   ...more stmts...

where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
Now, we say that:

* Constraints required by the argi can be solved from
  constraint bound by ...stmts...

* Constraints and existentials bound by the argi are not available
  to solve constraints required either by argj (where i /= j),
  or by ...more stmts....

* Within the stmts of each 'argi' individually, however, constraints bound
  by earlier stmts can be used to solve later ones.

To achieve this, we just typecheck each 'argi' separately, bring all
the variables they bind into scope, and typecheck the thing_inside.

************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************

@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
number of args are used in each equation.
-}

checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
checkArgs :: Name -> MatchGroup GhcRn body -> TcRn ()
checkArgs Name
_ (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
_ [] })
    = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkArgs Name
fun (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
_ (LMatch GhcRn body
match1:[LMatch GhcRn body]
matches) })
    | [LMatch GhcRn body] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcRn body]
bad_matches
    = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise
    = SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Equations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text String
"have different numbers of arguments"
                       , Arity -> SDoc -> SDoc
nest Arity
2 (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LMatch GhcRn body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LMatch GhcRn body
match1))
                       , Arity -> SDoc -> SDoc
nest Arity
2 (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LMatch GhcRn body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc ([LMatch GhcRn body] -> LMatch GhcRn body
forall a. [a] -> a
head [LMatch GhcRn body]
bad_matches)))])
  where
    n_args1 :: Arity
n_args1 = LMatch GhcRn body -> Arity
forall body. LMatch GhcRn body -> Arity
args_in_match LMatch GhcRn body
match1
    bad_matches :: [LMatch GhcRn body]
bad_matches = [LMatch GhcRn body
m | LMatch GhcRn body
m <- [LMatch GhcRn body]
matches, LMatch GhcRn body -> Arity
forall body. LMatch GhcRn body -> Arity
args_in_match LMatch GhcRn body
m Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
/= Arity
n_args1]

    args_in_match :: LMatch GhcRn body -> Int
    args_in_match :: LMatch GhcRn body -> Arity
args_in_match (L SrcSpan
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })) = [Located (Pat GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Located (Pat GhcRn)]
[LPat GhcRn]
pats
    args_in_match (L SrcSpan
_ (XMatch XXMatch GhcRn body
nec)) = NoExtCon -> Arity
forall a. NoExtCon -> a
noExtCon XXMatch GhcRn body
NoExtCon
nec
checkArgs Name
_ (XMatchGroup XXMatchGroup GhcRn body
nec) = NoExtCon -> TcRn ()
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcRn body
NoExtCon
nec