{-
(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 #-}

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

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )

import BasicTypes (LexicalFixity(..))
import HsSyn
import TcRnMonad
import TcEnv
import TcPat
import TcMType
import TcType
import TcBinds
import TcUnify
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)
             -> ExpRhoType     -- Expected type of function
             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
                                -- Returns type of body
tcMatchesFun :: Located Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
tcMatchesFun fn :: Located Name
fn@(L _ fun_name :: Name
fun_name) matches :: MatchGroup GhcRn (LHsExpr GhcRn)
matches exp_ty :: ExpRhoType
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 "tcMatchesFun" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun_name SDoc -> SDoc -> SDoc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_ty)
        ; Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcRn ()
forall body. Name -> MatchGroup GhcRn body -> TcRn ()
checkArgs Name
fun_name MatchGroup GhcRn (LHsExpr GhcRn)
matches

        ; (wrap_gen :: HsWrapper
wrap_gen, (wrap_fun :: HsWrapper
wrap_fun, group :: MatchGroup GhcTcId (LHsExpr GhcTcId)
group))
            <- UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType
    -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM
     (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
forall result.
UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseET (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
fun_name Bool
True) ExpRhoType
exp_ty ((ExpRhoType
  -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM
      (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))))
-> (ExpRhoType
    -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM
     (HsWrapper, (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)))
forall a b. (a -> b) -> a -> b
$ \ exp_rho :: ExpRhoType
exp_rho ->
                  -- Note [Polymorphic expected type for tcMatchesFun]
               do { (matches' :: MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', wrap_fun :: HsWrapper
wrap_fun)
                       <- SDoc
-> Arity
-> ExpRhoType
-> ([ExpRhoType]
    -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a.
SDoc
-> Arity
-> ExpRhoType
-> ([ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald Arity
arity ExpRhoType
exp_rho (([ExpRhoType]
  -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper))
-> ([ExpRhoType]
    -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a b. (a -> b) -> a -> b
$
                          \ pat_tys :: [ExpRhoType]
pat_tys rhs_ty :: ExpRhoType
rhs_ty ->
                          TcMatchCtxt HsExpr
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [ExpRhoType]
pat_tys ExpRhoType
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 body. MatchGroup id body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
matches
    herald :: SDoc
herald = String -> SDoc
text "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 "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)
    -> ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
what, mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpRhoType -> 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))
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatchesCase ctxt :: TcMatchCtxt body
ctxt scrut_ty :: TcSigmaType
scrut_ty matches :: MatchGroup GhcRn (Located (body GhcRn))
matches res_ty :: ExpRhoType
res_ty
  = TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt body
ctxt [TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
scrut_ty] ExpRhoType
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)
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda herald :: SDoc
herald match_ctxt :: TcMatchCtxt HsExpr
match_ctxt match :: MatchGroup GhcRn (LHsExpr GhcRn)
match res_ty :: ExpRhoType
res_ty
  = SDoc
-> Arity
-> ExpRhoType
-> ([ExpRhoType]
    -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a.
SDoc
-> Arity
-> ExpRhoType
-> ([ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald Arity
n_pats ExpRhoType
res_ty (([ExpRhoType]
  -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
 -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper))
-> ([ExpRhoType]
    -> ExpRhoType -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId)))
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ pat_tys :: [ExpRhoType]
pat_tys rhs_ty :: ExpRhoType
rhs_ty ->
    TcMatchCtxt HsExpr
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [ExpRhoType]
pat_tys ExpRhoType
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 = 1   -- must be lambda-case
           | Bool
otherwise               = MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall id body. MatchGroup 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 :: GRHSs GhcRn (LHsExpr GhcRn)
grhss res_ty :: TcSigmaType
res_ty = TcMatchCtxt HsExpr
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs TcMatchCtxt HsExpr
match_ctxt GRHSs GhcRn (LHsExpr GhcRn)
grhss (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
res_ty)
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
PatBindRhs,
                      mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpRhoType -> 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] -> [ExpRhoType] -> TcM [ExpRhoType]
tauifyMultipleMatches group :: [LMatch id body]
group exp_tys :: [ExpRhoType]
exp_tys
  | [LMatch id body] -> Bool
forall id body. [LMatch id body] -> Bool
isSingletonMatchGroup [LMatch id body]
group = [ExpRhoType] -> TcM [ExpRhoType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ExpRhoType]
exp_tys
  | Bool
otherwise                   = (ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType)
-> [ExpRhoType] -> TcM [ExpRhoType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
tauifyExpType [ExpRhoType]
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)
-> ExpRhoType
-> 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
-> [ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatches ctxt :: TcMatchCtxt body
ctxt pat_tys :: [ExpRhoType]
pat_tys rhs_ty :: ExpRhoType
rhs_ty (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L l :: SrcSpan
l matches :: [LMatch GhcRn (Located (body GhcRn))]
matches
                                  , mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
  = do { rhs_ty :: ExpRhoType
rhs_ty:pat_tys :: [ExpRhoType]
pat_tys <- [LMatch GhcRn (Located (body GhcRn))]
-> [ExpRhoType] -> TcM [ExpRhoType]
forall id body.
[LMatch id body] -> [ExpRhoType] -> TcM [ExpRhoType]
tauifyMultipleMatches [LMatch GhcRn (Located (body GhcRn))]
matches (ExpRhoType
rhs_tyExpRhoType -> [ExpRhoType] -> [ExpRhoType]
forall a. a -> [a] -> [a]
:[ExpRhoType]
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
-> [ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (LMatch GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
tcMatch TcMatchCtxt body
ctxt [ExpRhoType]
pat_tys ExpRhoType
rhs_ty) [LMatch GhcRn (Located (body GhcRn))]
matches
       ; [TcSigmaType]
pat_tys  <- (ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType)
-> [ExpRhoType] -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType [ExpRhoType]
pat_tys
       ; TcSigmaType
rhs_ty   <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpRhoType
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 _ _ _ (XMatchGroup {}) = String -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
forall a. String -> a
panic "tcMatches"

-------------
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
-> [ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
tcMatch ctxt :: TcMatchCtxt body
ctxt pat_tys :: [ExpRhoType]
pat_tys rhs_ty :: ExpRhoType
rhs_ty match :: 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
-> [ExpRhoType]
-> ExpRhoType
-> Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
tc_match TcMatchCtxt body
ctxt [ExpRhoType]
pat_tys ExpRhoType
rhs_ty) LMatch GhcRn (Located (body GhcRn))
match
  where
    tc_match :: TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> Match GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
tc_match ctxt :: TcMatchCtxt body
ctxt pat_tys :: [ExpRhoType]
pat_tys rhs_ty :: ExpRhoType
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 { (pats' :: [LPat GhcTcId]
pats', grhss' :: GRHSs GhcTcId (Located (body GhcTcId))
grhss') <- HsMatchContext Name
-> [LPat GhcRn]
-> [ExpRhoType]
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
-> TcM ([LPat GhcTcId], GRHSs GhcTcId (Located (body GhcTcId)))
forall a.
HsMatchContext Name
-> [LPat GhcRn] -> [ExpRhoType] -> 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 [ExpRhoType]
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))
-> ExpRhoType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
TcMatchCtxt body
-> GRHSs GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs TcMatchCtxt body
ctxt GRHSs GhcRn (Located (body GhcRn))
grhss ExpRhoType
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))
NoExt
noExt
                           , 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 = [LPat GhcTcId]
pats'
                           , m_grhss :: GRHSs GhcTcId (Located (body GhcTcId))
m_grhss = GRHSs GhcTcId (Located (body GhcTcId))
grhss' }) }
    tc_match  _ _ _ (XMatch _) = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
forall a. String -> a
panic "tcMatch"

        -- 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 :: Match GhcRn (Located (body GhcRn))
match thing_inside :: 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
            LambdaExpr -> IOEnv
  (Env TcGblEnv TcLclEnv) (Match GhcTcId (Located (body GhcTcId)))
thing_inside
            _          -> 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 (GhcPass 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))
-> ExpRhoType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs ctxt :: TcMatchCtxt body
ctxt (GRHSs _ grhss :: [LGRHS GhcRn (Located (body GhcRn))]
grhss (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds)) res_ty :: ExpRhoType
res_ty
  = do  { (binds' :: HsLocalBinds GhcTcId
binds', grhss' :: [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
-> ExpRhoType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS TcMatchCtxt body
ctxt ExpRhoType
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))
NoExt
noExt [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 _ (XGRHSs _) _ = String -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
forall a. String -> a
panic "tcGRHSs"

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

tcGRHS :: TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS ctxt :: TcMatchCtxt body
ctxt res_ty :: ExpRhoType
res_ty (GRHS _ guards :: [GuardLStmt GhcRn]
guards rhs :: Located (body GhcRn)
rhs)
  = do  { (guards' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
guards', rhs' :: Located (body GhcTcId)
rhs')
            <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> 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 ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (Located (body GhcTcId)))
 -> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], Located (body GhcTcId)))
-> (ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], Located (body GhcTcId))
forall a b. (a -> b) -> a -> b
$
               TcMatchCtxt body
-> Located (body GhcRn)
-> ExpRhoType
-> TcM (Located (body GhcTcId))
forall (body :: * -> *).
TcMatchCtxt body
-> Located (body GhcRn)
-> ExpRhoType
-> 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))
NoExt
noExt [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 _ _ (XGRHS _) = String -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
forall a. String -> a
panic "tcGRHS"

{-
************************************************************************
*                                                                      *
\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] -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcDoStmts ListComp (L l :: SrcSpan
l stmts :: [GuardLStmt GhcRn]
stmts) res_ty :: ExpRhoType
res_ty
  = do  { TcSigmaType
res_ty <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
expTypeToType ExpRhoType
res_ty
        ; (co :: TcCoercionN
co, elt_ty :: 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 ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> 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 ExpRhoType
tcLcStmt TyCon
listTyCon) [GuardLStmt GhcRn]
stmts
                            (TcSigmaType -> ExpRhoType
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 DoExpr (L l :: SrcSpan
l stmts :: [GuardLStmt GhcRn]
stmts) res_ty :: ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> 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 ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; TcSigmaType
res_ty <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpRhoType
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 MDoExpr (L l :: SrcSpan
l stmts :: [GuardLStmt GhcRn]
stmts) res_ty :: ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> 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 ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; TcSigmaType
res_ty <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpRhoType
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 MonadComp (L l :: SrcSpan
l stmts :: [GuardLStmt GhcRn]
stmts) res_ty :: ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> 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 ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; TcSigmaType
res_ty <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpRhoType
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 ctxt :: HsStmtContext Name
ctxt _ _ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody body :: LHsExpr GhcRn
body res_ty :: ExpRhoType
res_ty
  = do  { String -> SDoc -> TcRn ()
traceTc "tcBody" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
        ; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
body ExpRhoType
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 ctxt :: HsStmtContext Name
ctxt stmt_chk :: TcStmtChecker body rho_type
stmt_chk stmts :: [LStmt GhcRn (Located (body GhcRn))]
stmts res_ty :: rho_type
res_ty
  = do { (stmts' :: [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 _ _ [] res_ty :: rho_type
res_ty thing_inside :: 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 ctxt :: HsStmtContext Name
ctxt stmt_chk :: TcStmtChecker body rho_type
stmt_chk (L loc :: SrcSpan
loc (LetStmt x :: XLetStmt GhcRn GhcRn (Located (body GhcRn))
x (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds)) : stmts :: [LStmt GhcRn (Located (body GhcRn))]
stmts)
                                                             res_ty :: rho_type
res_ty thing_inside :: rho_type -> TcM thing
thing_inside
  = do  { (binds' :: HsLocalBinds GhcTcId
binds', (stmts' :: [LStmt GhcTcId (Located (body GhcTcId))]
stmts',thing :: 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 ctxt :: HsStmtContext Name
ctxt stmt_chk :: TcStmtChecker body rho_type
stmt_chk (L loc :: SrcSpan
loc stmt :: StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt : stmts :: [LStmt GhcRn (Located (body GhcRn))]
stmts) res_ty :: rho_type
res_ty thing_inside :: rho_type -> TcM thing
thing_inside
  | ApplicativeStmt{} <- StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt
  = do  { (stmt' :: StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', (stmts' :: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing :: 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
$ \ res_ty' :: 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  { (stmt' :: StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', (stmts' :: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing :: 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 (GhcPass idL), OutputableBndrId (GhcPass 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
$ \ res_ty' :: 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)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcGuardStmt _ (BodyStmt _ guard :: LHsExpr GhcRn
guard _ _) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
guard' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
guard (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
boolTy)
        ; thing
thing  <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
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 ctxt :: HsStmtContext Name
ctxt (BindStmt _ pat :: LPat GhcRn
pat rhs :: LHsExpr GhcRn
rhs _ _) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { (rhs' :: LHsExpr GhcTcId
rhs', rhs_ty :: TcSigmaType
rhs_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
rhs
                                   -- Stmt has a context already
        ; (pat' :: LPat GhcTcId
pat', thing :: thing
thing)  <- HsMatchContext Name
-> CtOrigin
-> LPat GhcRn
-> ExpRhoType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> CtOrigin
-> LPat GhcRn
-> ExpRhoType
-> 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 -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
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 LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

tcGuardStmt _ stmt :: Stmt GhcRn (LHsExpr GhcRn)
stmt _ _
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 ExpRhoType
tcLcStmt _ _ (LastStmt x :: XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x body :: LHsExpr GhcRn
body noret :: Bool
noret _) elt_ty :: ExpRhoType
elt_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body ExpRhoType
elt_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic "tcLcStmt: thing_inside")
       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (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 m_tc :: TyCon
m_tc ctxt :: HsStmtContext Name
ctxt (BindStmt _ pat :: LPat GhcRn
pat rhs :: LHsExpr GhcRn
rhs _ _) elt_ty :: ExpRhoType
elt_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
 = do   { TcSigmaType
pat_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
        ; LHsExpr GhcTcId
rhs'   <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType (TcSigmaType -> ExpRhoType) -> TcSigmaType -> ExpRhoType
forall a b. (a -> b) -> a -> b
$ TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
m_tc [TcSigmaType
pat_ty])
        ; (pat' :: LPat GhcTcId
pat', thing :: thing
thing)  <- HsMatchContext Name
-> LPat GhcRn
-> ExpRhoType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> 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 -> ExpRhoType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (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 LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

-- A boolean guard
tcLcStmt _ _ (BodyStmt _ rhs :: LHsExpr GhcRn
rhs _ _) elt_ty :: ExpRhoType
elt_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
rhs'  <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
boolTy)
        ; thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (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 m_tc :: TyCon
m_tc ctxt :: HsStmtContext Name
ctxt (ParStmt _ bndr_stmts_s :: [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s _ _) elt_ty :: ExpRhoType
elt_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { (pairs' :: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing :: 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)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (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 <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
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 x :: XParStmtBlock GhcRn GhcRn
x stmts :: [GuardLStmt GhcRn]
stmts names :: [IdP GhcRn]
names _ : pairs :: [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { (stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (ids :: [TcId]
ids, pairs' :: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing :: thing
thing))
                <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> 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 ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpRhoType
elt_ty ((ExpRhoType
  -> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing)))
-> (ExpRhoType
    -> TcM ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], [ParStmtBlock GhcTcId GhcTcId], thing))
forall a b. (a -> b) -> a -> b
$ \ _elt_ty' :: ExpRhoType
_elt_ty' ->
                   do { [TcId]
ids <- [Name] -> TcM [TcId]
tcLookupLocalIds [Name]
[IdP GhcRn]
names
                      ; (pairs' :: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing :: 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{}:_) = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall a. String -> a
panic "tcLcStmt"

tcLcStmt m_tc :: TyCon
m_tc ctxt :: 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 }) elt_ty :: ExpRhoType
elt_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do { let (bndr_names :: [Name]
bndr_names, n_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 :: ExpRhoType
unused_ty = String -> SDoc -> ExpRhoType
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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
       ; (stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (bndr_ids :: [TcId]
bndr_ids, by' :: Maybe (LHsExpr GhcTcId, TcSigmaType)
by'))
            <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> 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 ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpRhoType
unused_ty ((ExpRhoType -> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType))))
-> (ExpRhoType
    -> TcM ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([TcId], Maybe (LHsExpr GhcTcId, TcSigmaType)))
forall a b. (a -> b) -> a -> b
$ \_ -> 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)
tcInferSigma 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 ty :: 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
                       ThenForm -> (\ty :: TcSigmaType
ty -> TcSigmaType
ty)
                       _        -> 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
                          Nothing       -> \ty :: TcSigmaType
ty -> TcSigmaType
ty
                          Just (_,e_ty :: TcSigmaType
e_ty) -> \ty :: TcSigmaType
ty -> (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` TcSigmaType
e_ty) TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` 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
`mkFunTy` 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 n_bndr_name :: Name
n_bndr_name bndr_id :: 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 HsExpr
             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 (ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty)

       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (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 _ _ stmt :: Stmt GhcRn (LHsExpr GhcRn)
stmt _ _
  = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcMcStmt _ (LastStmt x :: XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x body :: LHsExpr GhcRn
body noret :: Bool
noret return_op :: SyntaxExpr GhcRn
return_op) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { (body' :: LHsExpr GhcTcId
body', return_op' :: SyntaxExpr GhcTcId
return_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op [SyntaxOpType
SynRho] ExpRhoType
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
$
               \ [a_ty :: TcSigmaType
a_ty] ->
               LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
a_ty)
        ; thing
thing      <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic "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 ctxt :: HsStmtContext Name
ctxt (BindStmt _ pat :: LPat GhcRn
pat rhs :: LHsExpr GhcRn
rhs bind_op :: SyntaxExpr GhcRn
bind_op fail_op :: SyntaxExpr GhcRn
fail_op) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
  = do  { ((rhs' :: LHsExpr GhcTcId
rhs', pat' :: LPat GhcTcId
pat', thing :: thing
thing, new_res_ty :: TcSigmaType
new_res_ty), bind_op' :: SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
bind_op
                          [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> TcM (LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType))
 -> TcM
      ((LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \ [rhs_ty :: TcSigmaType
rhs_ty, pat_ty :: TcSigmaType
pat_ty, new_res_ty :: TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty)
                  ; (pat' :: LPat GhcTcId
pat', thing :: thing
thing) <- HsMatchContext Name
-> LPat GhcRn
-> ExpRhoType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> 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 -> ExpRhoType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                                     ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
new_res_ty)
                  ; (LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType)
-> TcM (LHsExpr GhcTcId, LPat GhcTcId, thing, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
rhs', LPat 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) 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 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 _ (BodyStmt _ rhs :: LHsExpr GhcRn
rhs then_op :: SyntaxExpr GhcRn
then_op guard_op :: SyntaxExpr GhcRn
guard_op) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> 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
thing, rhs' :: LHsExpr GhcTcId
rhs', rhs_ty :: TcSigmaType
rhs_ty, guard_op' :: SyntaxExpr GhcTcId
guard_op'), then_op' :: SyntaxExpr GhcTcId
then_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId))
-> TcM
     ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
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
$
               \ [rhs_ty :: TcSigmaType
rhs_ty, new_res_ty :: TcSigmaType
new_res_ty] ->
               do { (rhs' :: LHsExpr GhcTcId
rhs', guard_op' :: SyntaxExpr GhcTcId
guard_op')
                      <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
guard_op [SyntaxOpType
SynAny]
                                    (TcSigmaType -> ExpRhoType
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
$
                         \ [test_ty :: TcSigmaType
test_ty] ->
                         LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
test_ty)
                  ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
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 ctxt :: 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 }) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do { let star_star_kind :: TcSigmaType
star_star_kind = TcSigmaType
liftedTypeKind TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` TcSigmaType
liftedTypeKind
       ; TcSigmaType
m1_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
star_star_kind
       ; TcSigmaType
m2_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
star_star_kind
       ; 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
                    ThenForm -> (TcSigmaType -> TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcSigmaType -> TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (\ty :: TcSigmaType
ty -> TcSigmaType
ty)
                    _        -> do { TcSigmaType
n_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
star_star_kind
                                   ; (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
                          Nothing -> \res :: TcSigmaType
res -> TcSigmaType
res
                          Just {} -> \res :: TcSigmaType
res -> (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` TcSigmaType
by_e_ty) TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` 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
`mkFunTy` 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 (bndr_names :: [Name]
bndr_names, n_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
       ; (stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (bndr_ids :: [TcId]
bndr_ids, by' :: Maybe (LHsExpr GhcTcId)
by', return_op' :: SyntaxExpr GhcTcId
return_op')) <-
            HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> 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 ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
stmts
                           (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
using_arg_ty) ((ExpRhoType
  -> TcM ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], Maybe (LHsExpr GhcTcId), SyntaxExpr GhcTcId)))
-> (ExpRhoType
    -> 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
$ \res_ty' :: ExpRhoType
res_ty' -> do
                { Maybe (LHsExpr GhcTcId)
by' <- case Maybe (LHsExpr GhcRn)
by of
                           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 e :: LHsExpr GhcRn
e  -> do { LHsExpr GhcTcId
e' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
e
                                                   (TcSigmaType -> ExpRhoType
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,..)
                ; (_, return_op' :: SyntaxExpr GhcTcId
return_op') <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                       [TcSigmaType -> SyntaxOpType
synKnownType ([TcId] -> TcSigmaType
mkBigCoreVarTupTy [TcId]
bndr_ids)]
                                       ExpRhoType
res_ty' (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ _ -> () -> 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
       ; (_, bind_op' :: SyntaxExpr GhcTcId
bind_op')  <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([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
`mkFunTy` TcSigmaType
new_res_ty) ]
                             ExpRhoType
res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

       --------------- Typecheck the 'fmap' function -------------
       ; HsExpr GhcTcId
fmap_op' <- case TransForm
form of
                       ThenForm -> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                       _ -> (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
`mkFunTy` TcSigmaType
betaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` (TcSigmaType -> TcSigmaType
n_app TcSigmaType
alphaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` (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 n_bndr_name :: Name
n_bndr_name bndr_id :: 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 HsExpr
             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
$
                  ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
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 ctxt :: HsStmtContext Name
ctxt (ParStmt _ bndr_stmts_s :: [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s mzip_op :: HsExpr GhcRn
mzip_op bind_op :: SyntaxExpr GhcRn
bind_op) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do { let star_star_kind :: TcSigmaType
star_star_kind = TcSigmaType
liftedTypeKind TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` TcSigmaType
liftedTypeKind
       ; TcSigmaType
m_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
star_star_kind

       ; 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
`mkFunTy`
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
betaTy)
                        TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy`
                        (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 _ _ names :: [IdP GhcRn]
names _ <- [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

       ; (((blocks' :: [ParStmtBlock GhcTcId GhcTcId]
blocks', thing :: thing
thing), inner_res_ty :: TcSigmaType
inner_res_ty), bind_op' :: SyntaxExpr GhcTcId
bind_op')
           <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
-> TcM
     ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([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 ] ExpRhoType
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
$
              \ [inner_res_ty :: TcSigmaType
inner_res_ty] ->
              do { ([ParStmtBlock GhcTcId GhcTcId], thing)
stuff <- TcSigmaType
-> ExpRhoType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
m_ty (TcSigmaType -> ExpRhoType
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 tys :: t TcSigmaType
tys = (TcSigmaType -> TcSigmaType -> TcSigmaType)
-> t TcSigmaType -> TcSigmaType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\tn :: TcSigmaType
tn tm :: 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
-> ExpRhoType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop _ inner_res_ty :: ExpRhoType
inner_res_ty [] [] = do { thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
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 m_ty :: TcSigmaType
m_ty inner_res_ty :: ExpRhoType
inner_res_ty (tup_ty_in :: TcSigmaType
tup_ty_in : tup_tys_in :: [TcSigmaType]
tup_tys_in)
                           (ParStmtBlock x :: XParStmtBlock GhcRn GhcRn
x stmts :: [GuardLStmt GhcRn]
stmts names :: [IdP GhcRn]
names return_op :: SyntaxExpr GhcRn
return_op : pairs :: [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { let m_tup_ty :: TcSigmaType
m_tup_ty = TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
tup_ty_in
           ; (stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (ids :: [TcId]
ids, return_op' :: SyntaxExpr GhcTcId
return_op', pairs' :: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing :: thing
thing))
                <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> 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 ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
m_tup_ty) ((ExpRhoType
  -> TcM
       ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
        thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([TcId], SyntaxExpr GhcTcId, [ParStmtBlock GhcTcId GhcTcId],
        thing)))
-> (ExpRhoType
    -> 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
$
                   \m_tup_ty' :: ExpRhoType
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
                      ; (_, return_op' :: SyntaxExpr GhcTcId
return_op') <-
                          CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                     [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty] ExpRhoType
m_tup_ty' (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                                     \ _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      ; (pairs' :: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing :: thing
thing) <- TcSigmaType
-> ExpRhoType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
m_ty ExpRhoType
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 _ _ _ _ = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall a. String -> a
panic "tcMcStmt.loop"

tcMcStmt _ stmt :: Stmt GhcRn (LHsExpr GhcRn)
stmt _ _
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcDoStmt _ (LastStmt x :: XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x body :: LHsExpr GhcRn
body noret :: Bool
noret _) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
body ExpRhoType
res_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic "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 ctxt :: HsStmtContext Name
ctxt (BindStmt _ pat :: LPat GhcRn
pat rhs :: LHsExpr GhcRn
rhs bind_op :: SyntaxExpr GhcRn
bind_op fail_op :: SyntaxExpr GhcRn
fail_op) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> 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 Trac #1537

          ((rhs' :: LHsExpr GhcTcId
rhs', pat' :: LPat GhcTcId
pat', new_res_ty :: TcSigmaType
new_res_ty, thing :: thing
thing), bind_op' :: SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
bind_op [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> TcM (LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing))
 -> TcM
      ((LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                \ [rhs_ty :: TcSigmaType
rhs_ty, pat_ty :: TcSigmaType
pat_ty, new_res_ty :: TcSigmaType
new_res_ty] ->
                do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty)
                   ; (pat' :: LPat GhcTcId
pat', thing :: thing
thing) <- HsMatchContext Name
-> LPat GhcRn
-> ExpRhoType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> 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 -> ExpRhoType
mkCheckExpType TcSigmaType
pat_ty) (TcM thing -> TcM (LPat GhcTcId, thing))
-> TcM thing -> TcM (LPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                                      ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
new_res_ty)
                   ; (LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing)
-> TcM (LHsExpr GhcTcId, LPat GhcTcId, TcSigmaType, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
rhs', LPat 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) 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 LPat GhcTcId
pat' LHsExpr GhcTcId
rhs' SyntaxExpr GhcTcId
bind_op' SyntaxExpr GhcTcId
fail_op', thing
thing) }

tcDoStmt ctxt :: HsStmtContext Name
ctxt (ApplicativeStmt _ pairs :: [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs mb_join :: Maybe (SyntaxExpr GhcRn)
mb_join) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  { let tc_app_stmts :: ExpRhoType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ty :: ExpRhoType
ty = HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcSigmaType -> TcM thing)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
forall t.
HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts HsStmtContext Name
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
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
$
                                ExpRhoType -> TcM thing
thing_inside (ExpRhoType -> TcM thing)
-> (TcSigmaType -> ExpRhoType) -> TcSigmaType -> TcM thing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigmaType -> ExpRhoType
mkCheckExpType
        ; ((pairs' :: [(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
pairs', body_ty :: TcSigmaType
body_ty, thing :: thing
thing), mb_join' :: Maybe (SyntaxExpr GhcTcId)
mb_join') <- case Maybe (SyntaxExpr GhcRn)
mb_join of
            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
<$> ExpRhoType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ExpRhoType
res_ty
            Just join_op :: 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]
-> ExpRhoType
-> ([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]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
join_op [SyntaxOpType
SynRho] ExpRhoType
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
$
               \ [rhs_ty :: TcSigmaType
rhs_ty] -> ExpRhoType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts (TcSigmaType -> ExpRhoType
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 _ (BodyStmt _ rhs :: LHsExpr GhcRn
rhs then_op :: SyntaxExpr GhcRn
then_op _) res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> TcM thing
thing_inside
  = do  {       -- Deal with rebindable syntax;
                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
        ; ((rhs' :: LHsExpr GhcTcId
rhs', rhs_ty :: TcSigmaType
rhs_ty, thing :: thing
thing), then_op' :: SyntaxExpr GhcTcId
then_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
-> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
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
$
               \ [rhs_ty :: TcSigmaType
rhs_ty, new_res_ty :: TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty)
                  ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
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 ctxt :: 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 })
         res_ty :: ExpRhoType
res_ty thing_inside :: ExpRhoType -> 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
        { ((stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (ret_op' :: SyntaxExpr GhcTcId
ret_op', tup_rets :: [HsExpr GhcTcId]
tup_rets)), stmts_ty :: TcSigmaType
stmts_ty)
                <- (ExpRhoType
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
-> TcM
     (([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])),
      TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInferInst ((ExpRhoType
  -> TcM
       ([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
 -> TcM
      (([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExpr GhcTcId, [HsExpr GhcTcId])),
       TcSigmaType))
-> (ExpRhoType
    -> 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
$ \ exp_ty :: ExpRhoType
exp_ty ->
                   HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> 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 ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
exp_ty ((ExpRhoType -> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExpr GhcTcId, [HsExpr GhcTcId])))
-> (ExpRhoType -> TcM (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (SyntaxExpr GhcTcId, [HsExpr GhcTcId]))
forall a b. (a -> b) -> a -> b
$ \ inner_res_ty :: ExpRhoType
inner_res_ty ->
                   do { [HsExpr GhcTcId]
tup_rets <- (Name -> ExpRhoType -> TcM (HsExpr GhcTcId))
-> [Name]
-> [ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExpr GhcTcId]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckId [Name]
tup_names
                                      ((TcSigmaType -> ExpRhoType) -> [TcSigmaType] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> ExpRhoType
mkCheckExpType [TcSigmaType]
tup_elt_tys)
                             -- Unify the types of the "final" Ids (which may
                             -- be polymorphic) with those of "knot-tied" Ids
                      ; (_, ret_op' :: SyntaxExpr GhcTcId
ret_op')
                          <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
ret_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty]
                                        ExpRhoType
inner_res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \_ -> () -> 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) }

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

        ; ((thing :: thing
thing, new_res_ty :: TcSigmaType
new_res_ty), bind_op' :: SyntaxExpr GhcTcId
bind_op')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (thing, TcSigmaType))
-> TcM ((thing, TcSigmaType), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([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 ]
                          ExpRhoType
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
$
               \ [new_res_ty :: TcSigmaType
new_res_ty] ->
               do { thing
thing <- ExpRhoType -> TcM thing
thing_inside (TcSigmaType -> ExpRhoType
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 "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 _ stmt :: Stmt GhcRn (LHsExpr GhcRn)
stmt _ _
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 orig :: CtOrigin
orig pat :: LPat GhcTcId
pat fail_op :: SyntaxExpr GhcRn
fail_op res_ty :: TcSigmaType
res_ty
  | LPat GhcTcId -> Bool
forall (p :: Pass).
OutputableBndrId (GhcPass 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]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
fail_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
stringTy]
                             (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
res_ty) (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \_ -> () -> 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 Trac #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)]
-> ExpRhoType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts ctxt :: HsStmtContext Name
ctxt pairs :: [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs rhs_ty :: ExpRhoType
rhs_ty thing_inside :: 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
      ; [ExpRhoType]
ts <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType -> TcM [ExpRhoType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM (Arity
arityArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-1) (IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType -> TcM [ExpRhoType])
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType -> TcM [ExpRhoType]
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
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
mkFunTys [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 (ops :: [SyntaxExpr GhcRn]
ops, args :: [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, ExpRhoType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps TcSigmaType
fun_ty ([SyntaxExpr GhcRn]
-> [ExpRhoType]
-> [TcSigmaType]
-> [(SyntaxExpr GhcRn, ExpRhoType, TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SyntaxExpr GhcRn]
ops ([ExpRhoType]
ts [ExpRhoType] -> [ExpRhoType] -> [ExpRhoType]
forall a. [a] -> [a] -> [a]
++ [ExpRhoType
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 (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg ([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, ExpRhoType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps _ [] = [SyntaxExpr GhcTcId]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    goOps t_left :: TcSigmaType
t_left ((op :: SyntaxExpr GhcRn
op,t_i :: ExpRhoType
t_i,exp_ty :: TcSigmaType
exp_ty) : ops :: [(SyntaxExpr GhcRn, ExpRhoType, TcSigmaType)]
ops)
      = do { (_, op' :: SyntaxExpr GhcTcId
op')
               <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([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] ExpRhoType
t_i (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                   \ _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; TcSigmaType
t_i <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
readExpType ExpRhoType
t_i
           ; [SyntaxExpr GhcTcId]
ops' <- TcSigmaType
-> [(SyntaxExpr GhcRn, ExpRhoType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExpr GhcTcId]
goOps TcSigmaType
t_i [(SyntaxExpr GhcRn, ExpRhoType, 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 :: (ApplicativeArg GhcRn, Type, Type)
          -> TcM (ApplicativeArg GhcTcId)

    goArg :: (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg (ApplicativeArgOne x :: XApplicativeArgOne GhcRn
x pat :: LPat GhcRn
pat rhs :: LHsExpr GhcRn
rhs isBody :: Bool
isBody, pat_ty :: TcSigmaType
pat_ty, exp_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 (LPat GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc 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 (GhcPass idL), OutputableBndrId (GhcPass 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)))
 ~ NoExt) =>
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 -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
exp_ty)
           ; (pat' :: LPat GhcTcId
pat', _) <- HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> 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 -> ExpRhoType
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 ()
           ; ApplicativeArg GhcTcId
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeArgOne GhcTcId
-> LPat GhcTcId
-> LHsExpr GhcTcId
-> Bool
-> ApplicativeArg GhcTcId
forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne XApplicativeArgOne GhcRn
XApplicativeArgOne GhcTcId
x LPat GhcTcId
pat' LHsExpr GhcTcId
rhs' Bool
isBody) }

    goArg (ApplicativeArgMany x :: XApplicativeArgMany GhcRn
x stmts :: [GuardLStmt GhcRn]
stmts ret :: HsExpr GhcRn
ret pat :: LPat GhcRn
pat, pat_ty :: TcSigmaType
pat_ty, exp_ty :: TcSigmaType
exp_ty)
      = do { (stmts' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (ret' :: HsExpr GhcTcId
ret',pat' :: LPat GhcTcId
pat')) <-
                HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM (HsExpr GhcTcId, LPat GhcTcId))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)], (HsExpr GhcTcId, LPat 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 ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
exp_ty) ((ExpRhoType -> TcM (HsExpr GhcTcId, LPat GhcTcId))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (HsExpr GhcTcId, LPat GhcTcId)))
-> (ExpRhoType -> TcM (HsExpr GhcTcId, LPat GhcTcId))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)], (HsExpr GhcTcId, LPat GhcTcId))
forall a b. (a -> b) -> a -> b
$
                \res_ty :: ExpRhoType
res_ty  -> do
                  { L _ ret' :: HsExpr GhcTcId
ret' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
ret) ExpRhoType
res_ty
                  ; (pat' :: LPat GhcTcId
pat', _) <- HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpRhoType -> 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 -> ExpRhoType
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, LPat GhcTcId)
-> TcM (HsExpr GhcTcId, LPat GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId
ret', LPat 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' LPat GhcTcId
pat') }

    goArg (XApplicativeArg _, _, _) = String -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a. String -> a
panic "tcApplicativeStmts"

    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
    get_arg_bndrs :: ApplicativeArg GhcTcId -> [TcId]
get_arg_bndrs (ApplicativeArgOne _ pat :: LPat GhcTcId
pat _ _)  = LPat GhcTcId -> [IdP GhcTcId]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTcId
pat
    get_arg_bndrs (ApplicativeArgMany _ _ _ pat :: LPat GhcTcId
pat) = LPat GhcTcId -> [IdP GhcTcId]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTcId
pat
    get_arg_bndrs (XApplicativeArg _)            = String -> [TcId]
forall a. String -> a
panic "tcApplicativeStmts"


{- 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
(Trac #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 _ (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L _ [] })
    = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkArgs fun :: Name
fun (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L _ (match1 :: LMatch GhcRn body
match1:matches :: [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 "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 "have different numbers of arguments"
                       , Arity -> SDoc -> SDoc
nest 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 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 _ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })) = [LPat GhcRn] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LPat GhcRn]
pats
    args_in_match (L _ (XMatch _)) = String -> Arity
forall a. String -> a
panic "checkArgs"
checkArgs _ (XMatchGroup{}) = String -> TcRn ()
forall a. String -> a
panic "checkArgs"