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

-}

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

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

-- | Typecheck some @Matches@
module GHC.Tc.Gen.Match
   ( tcMatchesFun
   , tcGRHS
   , tcGRHSsPat
   , tcMatchesCase
   , tcMatchLambda
   , TcMatchCtxt(..)
   , TcStmtChecker
   , TcExprStmtChecker
   , TcCmdStmtChecker
   , tcStmts
   , tcStmtsAndThen
   , tcDoStmts
   , tcBody
   , tcDoStmt
   , tcGuardStmt
   )
where

import GHC.Prelude

import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho
                                     , tcCheckId, tcLExpr, tcLExprNC, tcExpr
                                     , tcCheckExpr )

import GHC.Types.Basic (LexicalFixity(..))
import GHC.Hs
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Gen.Bind
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Types.Name
import GHC.Builtin.Types
import GHC.Types.Id
import GHC.Core.TyCon
import GHC.Builtin.Types.Prim
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.SrcLoc

-- Create chunkified tuple tybes for monad comprehensions
import GHC.Core.Make

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 GHC.Tc.Gen.Pat.
-}

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

        ; (HsWrapper
wrap_gen, (HsWrapper
wrap_fun, 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
$ \ ExpRhoType
exp_rho ->
                  -- Note [Polymorphic expected type for tcMatchesFun]
               do { (MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', 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
$
                          \ [ExpRhoType]
pat_tys 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)))
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
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
External instance of the constraint type forall m. Monad (IOEnv m)
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsWrapper
wrap_gen HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_fun, MatchGroup GhcTcId (LHsExpr GhcTcId)
group) }
  where
    arity :: Arity
arity = MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
matches
    herald :: SDoc
herald = String -> SDoc
text String
"The equation(s) for"
             SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
fun_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"have"
    what :: HsMatchContext GhcRn
what = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: LIdP GhcRn
mc_fun = Located Name
LIdP GhcRn
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 GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
what, mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody }
    strictness :: SrcStrictness
strictness
      | [L SrcSpan
_ Match GhcRn (LHsExpr GhcRn)
match] <- GenLocated SrcSpan [LMatch GhcRn (LHsExpr GhcRn)]
-> [LMatch GhcRn (LHsExpr GhcRn)]
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan [LMatch GhcRn (LHsExpr GhcRn)]
 -> [LMatch GhcRn (LHsExpr GhcRn)])
-> GenLocated SrcSpan [LMatch GhcRn (LHsExpr GhcRn)]
-> [LMatch GhcRn (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcRn (LHsExpr GhcRn)
-> GenLocated SrcSpan [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 p. HsMatchContext p -> SrcStrictness
mc_strictness = SrcStrictness
SrcStrict } <- Match GhcRn (LHsExpr GhcRn) -> HsMatchContext (NoGhcTc GhcRn)
forall p body. Match p body -> HsMatchContext (NoGhcTc 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 TcMatchCtxt body
ctxt TcSigmaType
scrut_ty MatchGroup GhcRn (Located (body GhcRn))
matches 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)))
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
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 GHC.Tc.Utils.Unify
              -> 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 SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match 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
$ \ [ExpRhoType]
pat_tys 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)))
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
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 = Arity
1   -- must be lambda-case
           | Bool
otherwise               = MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
match

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

tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
-- Used for pattern bindings
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> TcSigmaType -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss TcSigmaType
res_ty = TcMatchCtxt HsExpr
-> GRHSs GhcRn (LHsExpr GhcRn)
-> 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 GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
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 [LMatch id body]
group [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
External instance of the constraint type forall m. Monad (IOEnv m)
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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
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 GhcRn
mc_what :: HsMatchContext GhcRn,  -- 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 TcMatchCtxt body
ctxt [ExpRhoType]
pat_tys ExpRhoType
rhs_ty (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
l [LMatch GhcRn (Located (body GhcRn))]
matches
                                  , mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
  = do { ExpRhoType
rhs_ty:[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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
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)))
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
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
External instance of the constraint type forall m. Monad (IOEnv m)
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 }) }

-------------
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 TcMatchCtxt body
ctxt [ExpRhoType]
pat_tys ExpRhoType
rhs_ty LMatch GhcRn (Located (body GhcRn))
match
  = (Match GhcRn (Located (body GhcRn))
 -> TcM (Match GhcTcId (Located (body GhcTcId))))
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (TcMatchCtxt body
-> [ExpRhoType]
-> ExpRhoType
-> Match GhcRn (Located (body GhcRn))
-> TcM (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))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
tc_match TcMatchCtxt body
ctxt [ExpRhoType]
pat_tys 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))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
add_match_ctxt Match GhcRn (Located (body GhcRn))
match (TcM (Match GhcTcId (Located (body GhcTcId)))
 -> TcM (Match GhcTcId (Located (body GhcTcId))))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
forall a b. (a -> b) -> a -> b
$
        do { ([Located (Pat GhcTcId)]
pats', GRHSs GhcTcId (Located (body GhcTcId))
grhss') <- HsMatchContext GhcRn
-> [LPat GhcRn]
-> [ExpRhoType]
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
-> TcM ([LPat GhcTcId], GRHSs GhcTcId (Located (body GhcTcId)))
forall a.
HsMatchContext GhcRn
-> [LPat GhcRn] -> [ExpRhoType] -> TcM a -> TcM ([LPat GhcTcId], a)
tcPats (TcMatchCtxt body -> HsMatchContext GhcRn
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
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))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcTcId (Located (body GhcTcId))
m_ext = XCMatch GhcTcId (Located (body GhcTcId))
NoExtField
noExtField
                           , m_ctxt :: HsMatchContext (NoGhcTc GhcTcId)
m_ctxt = TcMatchCtxt body -> HsMatchContext GhcRn
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt, m_pats :: [LPat GhcTcId]
m_pats = [Located (Pat GhcTcId)]
[LPat GhcTcId]
pats'
                           , m_grhss :: GRHSs GhcTcId (Located (body GhcTcId))
m_grhss = GRHSs GhcTcId (Located (body GhcTcId))
grhss' }) }

        -- 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))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
add_match_ctxt Match GhcRn (Located (body GhcRn))
match TcM (Match GhcTcId (Located (body GhcTcId)))
thing_inside
        = case TcMatchCtxt body -> HsMatchContext GhcRn
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt of
            HsMatchContext GhcRn
LambdaExpr -> TcM (Match GhcTcId (Located (body GhcTcId)))
thing_inside
            HsMatchContext GhcRn
_          -> SDoc
-> TcM (Match GhcTcId (Located (body GhcTcId)))
-> TcM (Match GhcTcId (Located (body GhcTcId)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (Located (body GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
pprMatchInCtxt Match GhcRn (Located (body GhcRn))
match) TcM (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 TcMatchCtxt body
ctxt (GRHSs XCGRHSs GhcRn (Located (body GhcRn))
_ [LGRHS GhcRn (Located (body GhcRn))]
grhss (L SrcSpan
l HsLocalBinds GhcRn
binds)) ExpRhoType
res_ty
  = do  { (HsLocalBinds GhcTcId
binds', [Located (GRHS GhcTcId (Located (body GhcTcId)))]
grhss')
            <- HsLocalBinds GhcRn
-> TcM [Located (GRHS GhcTcId (Located (body GhcTcId)))]
-> TcM
     (HsLocalBinds GhcTcId,
      [Located (GRHS GhcTcId (Located (body GhcTcId)))])
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [Located (GRHS GhcTcId (Located (body GhcTcId)))]
 -> TcM
      (HsLocalBinds GhcTcId,
       [Located (GRHS GhcTcId (Located (body GhcTcId)))]))
-> TcM [Located (GRHS GhcTcId (Located (body GhcTcId)))]
-> TcM
     (HsLocalBinds GhcTcId,
      [Located (GRHS GhcTcId (Located (body GhcTcId)))])
forall a b. (a -> b) -> a -> b
$
               (LGRHS GhcRn (Located (body GhcRn))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Located (GRHS GhcTcId (Located (body GhcTcId)))))
-> [LGRHS GhcRn (Located (body GhcRn))]
-> TcM [Located (GRHS GhcTcId (Located (body GhcTcId)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM ((GRHS GhcRn (Located (body GhcRn))
 -> TcM (GRHS GhcTcId (Located (body GhcTcId))))
-> LGRHS GhcRn (Located (body GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Located (GRHS GhcTcId (Located (body GhcTcId))))
forall a b. (a -> TcM b) -> Located a -> TcM (Located 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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCGRHSs GhcTcId (Located (body GhcTcId))
-> [Located (GRHS GhcTcId (Located (body GhcTcId)))]
-> LHsLocalBinds GhcTcId
-> GRHSs GhcTcId (Located (body GhcTcId))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTcId (Located (body GhcTcId))
NoExtField
noExtField [Located (GRHS GhcTcId (Located (body GhcTcId)))]
grhss' (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds')) }

-------------
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 TcMatchCtxt body
ctxt ExpRhoType
res_ty (GRHS XCGRHS GhcRn (Located (body GhcRn))
_ [GuardLStmt GhcRn]
guards Located (body GhcRn)
rhs)
  = do  { ([LStmt GhcTcId (LHsExpr GhcTcId)]
guards', Located (body GhcTcId)
rhs')
            <- HsStmtContext GhcRn
-> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCGRHS GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located (body GhcTcId)
-> GRHS GhcTcId (Located (body GhcTcId))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTcId (Located (body GhcTcId))
NoExtField
noExtField [LStmt GhcTcId (LHsExpr GhcTcId)]
guards' Located (body GhcTcId)
rhs') }
  where
    stmt_ctxt :: HsStmtContext GhcRn
stmt_ctxt  = HsMatchContext GhcRn -> HsStmtContext GhcRn
forall p. HsMatchContext p -> HsStmtContext p
PatGuard (TcMatchCtxt body -> HsMatchContext GhcRn
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt)

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

tcDoStmts :: HsStmtContext GhcRn
          -> Located [LStmt GhcRn (LHsExpr GhcRn)]
          -> ExpRhoType
          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo
tcDoStmts :: HsStmtContext GhcRn
-> Located [GuardLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcDoStmts HsStmtContext GhcRn
ListComp (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { TcSigmaType
res_ty <- ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionN
co, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionN, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
        ; let list_ty :: TcSigmaType
list_ty = TcSigmaType -> TcSigmaType
mkListTy TcSigmaType
elt_ty
        ; [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmts HsStmtContext GhcRn
forall p. HsStmtContext p
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionN -> HsExpr GhcTcId -> HsExpr GhcTcId
mkHsWrapCo TcCoercionN
co (XDo GhcTcId
-> HsStmtContext GhcRn
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
list_ty HsStmtContext GhcRn
forall p. HsStmtContext p
ListComp (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext GhcRn
DoExpr (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmts HsStmtContext GhcRn
forall p. HsStmtContext p
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XDo GhcTcId
-> HsStmtContext GhcRn
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext GhcRn
MDoExpr (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmts HsStmtContext GhcRn
forall p. HsStmtContext p
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XDo GhcTcId
-> HsStmtContext GhcRn
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext GhcRn
forall p. HsStmtContext p
MDoExpr (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext GhcRn
MonadComp (L SrcSpan
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> TcM [LStmt GhcTcId (LHsExpr GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmts HsStmtContext GhcRn
forall p. HsStmtContext p
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XDo GhcTcId
-> HsStmtContext GhcRn
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo TcSigmaType
XDo GhcTcId
res_ty HsStmtContext GhcRn
forall p. HsStmtContext p
MonadComp (SrcSpan
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> Located [LStmt GhcTcId (LHsExpr GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts')) }

tcDoStmts HsStmtContext GhcRn
ctxt Located [GuardLStmt GhcRn]
_ ExpRhoType
_ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (HsStmtContext GhcRn -> SDoc
forall id. Outputable (IdP id) => HsStmtContext id -> SDoc
External instance of the constraint type Outputable Name
pprStmtContext HsStmtContext GhcRn
ctxt)

tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody LHsExpr GhcRn
body ExpRhoType
res_ty
  = do  { String -> SDoc -> TcRn ()
traceTc String
"tcBody" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable ExpRhoType
ppr ExpRhoType
res_ty)
        ; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExpr 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 GhcRn
                -> 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 GhcRn
        -> TcStmtChecker body rho_type   -- NB: higher-rank type
        -> [LStmt GhcRn (Located (body GhcRn))]
        -> rho_type
        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts :: HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (Located (body GhcRn))]
stmts rho_type
res_ty
  = do { ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', ()
_) <- HsStmtContext GhcRn
-> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
tcStmtsAndThen HsStmtContext GhcRn
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
External instance of the constraint type forall m. Monad (IOEnv m)
return ())
       ; [LStmt GhcTcId (Located (body GhcTcId))]
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return [LStmt GhcTcId (Located (body GhcTcId))]
stmts' }

tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn
               -> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext GhcRn
_ TcStmtChecker body rho_type
_ [] rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { thing
thing <- rho_type -> TcM thing
thing_inside rho_type
res_ty
        ; ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([], thing
thing) }

-- LetStmts are handled uniformly, regardless of context
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpan
loc (LetStmt XLetStmt GhcRn GhcRn (Located (body GhcRn))
x (L SrcSpan
l HsLocalBinds GhcRn
binds)) : [LStmt GhcRn (Located (body GhcRn))]
stmts)
                                                             rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { (HsLocalBinds GhcTcId
binds', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts',thing
thing)) <- HsLocalBinds GhcRn
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM
     (HsLocalBinds GhcTcId,
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
 -> TcM
      (HsLocalBinds GhcTcId,
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM
     (HsLocalBinds GhcTcId,
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$
              HsStmtContext GhcRn
-> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
tcStmtsAndThen HsStmtContext GhcRn
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
External instance of the constraint type forall m. Monad (IOEnv m)
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 something strange and broke a test (ado002).
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpan
loc StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt : [LStmt GhcRn (Located (body GhcRn))]
stmts) rho_type
res_ty rho_type -> TcM thing
thing_inside
  | ApplicativeStmt{} <- StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt
  = do  { (StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing)) <-
             HsStmtContext GhcRn
-> 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 GhcRn
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt rho_type
res_ty ((rho_type
  -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
               HsStmtContext GhcRn
-> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
tcStmtsAndThen HsStmtContext GhcRn
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
External instance of the constraint type forall m. Monad (IOEnv m)
return (SrcSpan
-> StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
-> LStmt GhcTcId (Located (body GhcTcId))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt' LStmt GhcTcId (Located (body GhcTcId))
-> [LStmt GhcTcId (Located (body GhcTcId))]
-> [LStmt GhcTcId (Located (body GhcTcId))]
forall a. a -> [a] -> [a]
: [LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing) }

  -- For the vanilla case, handle the location-setting part
  | Bool
otherwise
  = do  { (StmtLR GhcTcId GhcTcId (Located (body GhcTcId))
stmt', ([LStmt GhcTcId (Located (body GhcTcId))]
stmts', thing
thing)) <-
                SrcSpan
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc                              (TcM
   (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
    ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$
                SDoc
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body) =>
HsStmtContext (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
pprStmtInCtxt HsStmtContext 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 GhcRn
-> 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 GhcRn
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
stmt rho_type
res_ty                   ((rho_type
  -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
 -> TcM
      (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
       ([LStmt GhcTcId (Located (body GhcTcId))], thing)))
-> (rho_type
    -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM
     (StmtLR GhcTcId GhcTcId (Located (body GhcTcId)),
      ([LStmt GhcTcId (Located (body GhcTcId))], thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
                TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a. TcM a -> TcM a
popErrCtxt                                  (TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
 -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing))
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
forall a b. (a -> b) -> a -> b
$
                HsStmtContext GhcRn
-> 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 GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
Evidence bound by a type signature of the constraint type Outputable (body GhcRn)
tcStmtsAndThen HsStmtContext GhcRn
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
External instance of the constraint type forall m. Monad (IOEnv m)
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 GhcRn
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcGuardStmt HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
guard SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
guard' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExpr 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
External instance of the constraint type forall m. Monad (IOEnv m)
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). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

tcGuardStmt HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { (LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
rhs
                                   -- Stmt has a context already
        ; (Located (Pat GhcTcId)
pat', thing
thing)  <- HsMatchContext GhcRn
-> CtOrigin
-> LPat GhcRn
-> TcSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext GhcRn
-> CtOrigin
-> LPat GhcRn
-> TcSigmaType
-> TcM a
-> TcM (LPat GhcTcId, a)
tcCheckPat_O (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
rhs)
                                         LPat GhcRn
pat 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
External instance of the constraint type forall m. Monad (IOEnv m)
return (LPat GhcTcId -> LHsExpr GhcTcId -> Stmt GhcTcId (LHsExpr GhcTcId)
forall (bodyR :: * -> *).
LPat GhcTcId
-> Located (bodyR GhcTcId)
-> StmtLR GhcTcId GhcTcId (Located (bodyR GhcTcId))
mkTcBindStmt Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

tcGuardStmt HsStmtContext GhcRn
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcGuardStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
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 TyCon
_ HsStmtContext GhcRn
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC LHsExpr GhcRn
body ExpRhoType
elt_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic String
"tcLcStmt: thing_inside")
       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Maybe Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Maybe Bool
noret SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

-- A generator, pat <- rhs
tcLcStmt TyCon
m_tc HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs) ExpRhoType
elt_ty 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)
tcLExpr 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])
        ; (Located (Pat GhcTcId)
pat', thing
thing)  <- HsMatchContext GhcRn
-> LPat GhcRn
-> TcSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat 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)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LPat GhcTcId -> LHsExpr GhcTcId -> Stmt GhcTcId (LHsExpr GhcTcId)
forall (bodyR :: * -> *).
LPat GhcTcId
-> Located (bodyR GhcTcId)
-> StmtLR GhcTcId GhcTcId (Located (bodyR GhcTcId))
mkTcBindStmt Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

-- A boolean guard
tcLcStmt TyCon
_ HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do  { LHsExpr GhcTcId
rhs'  <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExpr LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
boolTy)
        ; thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

-- ParStmt: See notes with tcMcStmt
tcLcStmt TyCon
m_tc HsStmtContext GhcRn
ctxt (ParStmt XParStmt GhcRn GhcRn (LHsExpr GhcRn)
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do  { ([ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) <- [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
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
External instance of the constraint type forall m. Monad (IOEnv m)
return ([], thing
thing) }         -- matching in the branches

    loop (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
_ : [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([Id]
ids, [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing))
                <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> TcM ([Id], [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], [ParStmtBlock GhcTcId GhcTcId], thing))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
ctxt (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpRhoType
elt_ty ((ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTcId GhcTcId], thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([Id], [ParStmtBlock GhcTcId GhcTcId], thing)))
-> (ExpRhoType
    -> TcM ([Id], [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], [ParStmtBlock GhcTcId GhcTcId], thing))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
_elt_ty' ->
                   do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
[IdP GhcRn]
names
                      ; ([ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) <- [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop [ParStmtBlock GhcRn GhcRn]
pairs
                      ; ([Id], [ParStmtBlock GhcTcId GhcTcId], thing)
-> TcM ([Id], [ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Id]
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
External instance of the constraint type forall m. Monad (IOEnv m)
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' [Id]
[IdP GhcTcId]
ids SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr ParStmtBlock GhcTcId GhcTcId
-> [ParStmtBlock GhcTcId GhcTcId] -> [ParStmtBlock GhcTcId GhcTcId]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing ) }

tcLcStmt TyCon
m_tc HsStmtContext GhcRn
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 }) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do { let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap
             unused_ty :: ExpRhoType
unused_ty = String -> SDoc -> ExpRhoType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: inner ty" ([(Name, Name)] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a b. (Outputable a, Outputable b) => Outputable (a, b)
External instance of the constraint type Outputable Name
ppr [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap)
             -- The inner 'stmts' lack a LastStmt, so the element type
             --  passed in to tcStmtsAndThen is never looked at
       ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([Id]
bndr_ids, Maybe (LHsExpr GhcTcId, TcSigmaType)
by'))
            <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType)))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen (HsStmtContext GhcRn -> HsStmtContext GhcRn
forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcRn
ctxt) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpRhoType
unused_ty ((ExpRhoType -> TcM ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType)))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType))))
-> (ExpRhoType -> TcM ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType)))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
_ -> 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)
External instance of the constraint type forall m. Applicative (IOEnv m)
External instance of the constraint type Traversable Maybe
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho Maybe (LHsExpr GhcRn)
by
               ; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names
               ; ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType))
-> TcM ([Id], Maybe (LHsExpr GhcTcId, TcSigmaType))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Id]
bndr_ids, Maybe (LHsExpr GhcTcId, TcSigmaType)
by') }

       ; let m_app :: TcSigmaType -> TcSigmaType
m_app TcSigmaType
ty = TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
m_tc [TcSigmaType
ty]

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

         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
       ; let n_app :: TcSigmaType -> TcSigmaType
n_app = case TransForm
form of
                       TransForm
ThenForm -> (\TcSigmaType
ty -> TcSigmaType
ty)
                       TransForm
_        -> TcSigmaType -> TcSigmaType
m_app

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

             tup_ty :: TcSigmaType
tup_ty        = [Id] -> TcSigmaType
mkBigCoreVarTupTy [Id]
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 = Id -> TcSigmaType -> TcSigmaType
mkInfForAllTy Id
alphaTyVar (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType -> TcSigmaType
by_arrow (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                             TcSigmaType
poly_arg_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
poly_res_ty

       ; LHsExpr GhcTcId
using' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcCheckExpr 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
External instance of the constraint type forall l. Functor (GenLocated l)
fmap (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
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 -> Id -> Id
mk_n_bndr Name
n_bndr_name Id
bndr_id = HasDebugCallStack => Name -> TcSigmaType -> Id
Name -> TcSigmaType -> Id
External instance of the constraint type HasDebugCallStack
mkLocalId Name
n_bndr_name (TcSigmaType -> TcSigmaType
n_app (Id -> TcSigmaType
idType Id
bndr_id))

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

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

       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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 = [(Id, Id)]
[(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
External instance of the constraint type Functor Maybe
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). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr
                           , trS_bind :: SyntaxExpr GhcTcId
trS_bind = SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr
                           , trS_fmap :: HsExpr GhcTcId
trS_fmap = HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                           , trS_ext :: XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
trS_ext = TcSigmaType
XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
unitTy
                           , trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }

tcLcStmt TyCon
_ HsStmtContext GhcRn
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)


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

tcMcStmt :: TcExprStmtChecker

tcMcStmt :: HsStmtContext GhcRn
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcMcStmt HsStmtContext GhcRn
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Maybe Bool
noret SyntaxExpr GhcRn
return_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { (LHsExpr GhcTcId
body', SyntaxExprTc
return_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExprTc))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
a_ty] ->
               LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC LHsExpr GhcRn
body (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
a_ty)
        ; thing
thing      <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic String
"tcMcStmt: thing_inside")
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Maybe Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Maybe Bool
noret SyntaxExpr GhcTcId
SyntaxExprTc
return_op', thing
thing) }

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

tcMcStmt HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
xbsrn LPat GhcRn
pat LHsExpr GhcRn
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
  = do  { ((LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', thing
thing, TcSigmaType
new_res_ty), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
XBindStmtRn
xbsrn)
                          [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> TcM
       (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
 -> TcM
      ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
       SyntaxExprTc))
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
pat_ty, TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty)
                  ; (Located (Pat GhcTcId)
pat', thing
thing) <- HsMatchContext GhcRn
-> LPat GhcRn
-> TcSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat 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, Located (Pat GhcTcId), thing, TcSigmaType)
-> TcM (LHsExpr GhcTcId, Located (Pat GhcTcId), thing, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', thing
thing, TcSigmaType
new_res_ty) }

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
External instance of the constraint type Monad Maybe
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
     -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable Maybe
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
XBindStmtRn
xbsrn) ((SyntaxExprRn
  -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
            CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (FailOperator GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
MCompPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail TcSigmaType
new_res_ty

        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc :: SyntaxExpr GhcTcId
-> TcSigmaType -> FailOperator GhcTcId -> XBindStmtTc
XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTcId
xbstc_bindOp = SyntaxExpr GhcTcId
SyntaxExprTc
bind_op'
                , xbstc_boundResultType :: TcSigmaType
xbstc_boundResultType = TcSigmaType
new_res_ty
                , xbstc_failOp :: FailOperator GhcTcId
xbstc_failOp = FailOperator GhcTcId
Maybe SyntaxExprTc
fail_op'
                }
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LPat GhcTcId
-> LHsExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
XBindStmtTc
xbstc Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

-- Boolean expressions.
--
--   [ body | stmts, expr ]  ->  expr :: m Bool
--
tcMcStmt HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
guard_op) ExpRhoType
res_ty 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, LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, SyntaxExprTc
guard_op'), SyntaxExprTc
then_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc))
-> TcM
     ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc))
 -> TcM
      ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc),
       SyntaxExprTc))
-> ([TcSigmaType]
    -> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc))
-> TcM
     ((thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
new_res_ty] ->
               do { (LHsExpr GhcTcId
rhs', SyntaxExprTc
guard_op')
                      <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
guard_op [SyntaxOpType
SynAny]
                                    (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty) (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExprTc))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                         \ [TcSigmaType
test_ty] ->
                         LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExpr 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, SyntaxExprTc)
-> TcM (thing, LHsExpr GhcTcId, TcSigmaType, SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (thing
thing, LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, SyntaxExprTc
guard_op') }
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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
SyntaxExprTc
then_op' SyntaxExpr GhcTcId
SyntaxExprTc
guard_op', thing
thing) }

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

-- We type [ body | (stmts, group by e using f), ... ]
--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
--
-- We type the functions as follows:
--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
--
tcMcStmt HsStmtContext GhcRn
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 }) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do { TcSigmaType
m1_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind
       ; TcSigmaType
m2_ty   <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
typeToTypeKind
       ; TcSigmaType
tup_ty  <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
       ; TcSigmaType
by_e_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind  -- The type of the 'by' expression (if any)

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

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

             -- 'stmts' returns a result of type (m1_ty tuple_ty),
             -- typically something like [(Int,Bool,Int)]
             -- We don't know what tuple_ty is yet, so we use a variable
       ; let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bindersMap
       ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([Id]
bndr_ids, Maybe (LHsExpr GhcTcId)
by', SyntaxExprTc
return_op')) <-
            HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> TcM ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen (HsStmtContext GhcRn -> HsStmtContext GhcRn
forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcRn
ctxt) TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
stmts
                           (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
using_arg_ty) ((ExpRhoType -> TcM ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc)))
-> (ExpRhoType
    -> TcM ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
res_ty' -> do
                { Maybe (LHsExpr GhcTcId)
by' <- case Maybe (LHsExpr GhcRn)
by of
                           Maybe (LHsExpr GhcRn)
Nothing -> Maybe (LHsExpr GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Maybe (LHsExpr GhcTcId)
forall a. Maybe a
Nothing
                           Just LHsExpr GhcRn
e  -> do { LHsExpr GhcTcId
e' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExpr 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
External instance of the constraint type forall m. Monad (IOEnv m)
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
                ; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names

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

                ; ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc)
-> TcM ([Id], Maybe (LHsExpr GhcTcId), SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Id]
bndr_ids, Maybe (LHsExpr GhcTcId)
by', SyntaxExprTc
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
       ; (()
_, SyntaxExprTc
bind_op')  <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
bind_op
                             [ TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
using_res_ty
                             , TcSigmaType -> SyntaxOpType
synKnownType (TcSigmaType -> TcSigmaType
n_app TcSigmaType
tup_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
new_res_ty) ]
                             ExpRhoType
res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()

       --------------- Typecheck the 'fmap' function -------------
       ; HsExpr GhcTcId
fmap_op' <- case TransForm
form of
                       TransForm
ThenForm -> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return HsExpr GhcTcId
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                       TransForm
_ -> (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap LHsExpr GhcTcId -> HsExpr GhcTcId
forall l e. GenLocated l e -> e
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)
tcCheckExpr (HsExpr GhcRn -> LHsExpr GhcRn
forall e. e -> Located e
noLoc HsExpr GhcRn
fmap_op) (TcSigmaType -> TcM (HsExpr GhcTcId))
-> TcSigmaType -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                            Id -> TcSigmaType -> TcSigmaType
mkInfForAllTy Id
alphaTyVar (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                            Id -> TcSigmaType -> TcSigmaType
mkInfForAllTy Id
betaTyVar  (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                            (TcSigmaType
alphaTy TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` TcSigmaType
betaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` (TcSigmaType -> TcSigmaType
n_app TcSigmaType
alphaTy)
                            TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy` (TcSigmaType -> TcSigmaType
n_app TcSigmaType
betaTy)

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

       ; LHsExpr GhcTcId
using' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcCheckExpr 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
External instance of the constraint type forall l. Functor (GenLocated l)
fmap (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
tup_ty)) LHsExpr GhcTcId
using'

       --------------- Building the bindersMap ----------------
       ; let mk_n_bndr :: Name -> TcId -> TcId
             mk_n_bndr :: Name -> Id -> Id
mk_n_bndr Name
n_bndr_name Id
bndr_id = HasDebugCallStack => Name -> TcSigmaType -> Id
Name -> TcSigmaType -> Id
External instance of the constraint type HasDebugCallStack
mkLocalId Name
n_bndr_name (TcSigmaType -> TcSigmaType
n_app (Id -> TcSigmaType
idType Id
bndr_id))

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

       -- Type check the thing in the environment with
       -- these new binders and return the result
       ; thing
thing <- [Id] -> TcM thing -> TcM thing
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
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
External instance of the constraint type forall m. Monad (IOEnv m)
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 = [(Id, Id)]
[(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
SyntaxExprTc
return_op', trS_bind :: SyntaxExpr GhcTcId
trS_bind = SyntaxExpr GhcTcId
SyntaxExprTc
bind_op'
                           , trS_ext :: XTransStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
trS_ext = TcSigmaType -> TcSigmaType
n_app TcSigmaType
tup_ty
                           , trS_fmap :: HsExpr GhcTcId
trS_fmap = HsExpr GhcTcId
fmap_op', trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }

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

       ; let mzip_ty :: TcSigmaType
mzip_ty  = [Id] -> TcSigmaType -> TcSigmaType
mkInfForAllTys [Id
alphaTyVar, Id
betaTyVar] (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
alphaTy)
                        TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy`
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
betaTy)
                        TcSigmaType -> TcSigmaType -> TcSigmaType
`mkVisFunTy`
                        (TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` [TcSigmaType] -> TcSigmaType
mkBoxedTupleTy [TcSigmaType
alphaTy, TcSigmaType
betaTy])
       ; HsExpr GhcTcId
mzip_op' <- LHsExpr GhcTcId -> HsExpr GhcTcId
forall l e. GenLocated l e -> e
unLoc (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
`fmap` LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcCheckExpr (HsExpr GhcRn -> LHsExpr GhcRn
forall e. e -> Located e
noLoc 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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM) (IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> Name -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
forall a b. a -> b -> a
const (TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind))
                       [ [Name]
[IdP GhcRn]
names | ParStmtBlock XParStmtBlock GhcRn GhcRn
_ [GuardLStmt GhcRn]
_ [IdP GhcRn]
names SyntaxExpr GhcRn
_ <- [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s ]

       -- Typecheck bind:
       ; let tup_tys :: [TcSigmaType]
tup_tys  = [ [TcSigmaType] -> TcSigmaType
mkBigCoreTupTy [TcSigmaType]
id_tys | [TcSigmaType]
id_tys <- [[TcSigmaType]]
id_tys_s ]
             tuple_ty :: TcSigmaType
tuple_ty = [TcSigmaType] -> TcSigmaType
forall {t :: * -> *}. Foldable t => t TcSigmaType -> TcSigmaType
External instance of the constraint type Foldable []
mk_tuple_ty [TcSigmaType]
tup_tys

       ; ((([ParStmtBlock GhcTcId GhcTcId]
blocks', thing
thing), TcSigmaType
inner_res_ty), SyntaxExprTc
bind_op')
           <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
-> TcM
     ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
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),
       SyntaxExprTc))
-> ([TcSigmaType]
    -> TcM (([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType))
-> TcM
     ((([ParStmtBlock GhcTcId GhcTcId], thing), TcSigmaType),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
              \ [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
External instance of the constraint type forall m. Monad (IOEnv m)
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
External instance of the constraint type forall m. Monad (IOEnv m)
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
SyntaxExprTc
bind_op', thing
thing) }

  where
    mk_tuple_ty :: t TcSigmaType -> TcSigmaType
mk_tuple_ty t TcSigmaType
tys = (TcSigmaType -> TcSigmaType -> TcSigmaType)
-> t TcSigmaType -> TcSigmaType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Evidence bound by a type signature of the constraint type Foldable t
foldr1 (\TcSigmaType
tn TcSigmaType
tm -> [TcSigmaType] -> TcSigmaType
mkBoxedTupleTy [TcSigmaType
tn, TcSigmaType
tm]) t TcSigmaType
tys

       -- loop :: Type                                  -- m_ty
       --      -> ExpRhoType                            -- inner_res_ty
       --      -> [TcType]                              -- tup_tys
       --      -> [ParStmtBlock Name]
       --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
    loop :: TcSigmaType
-> ExpRhoType
-> [TcSigmaType]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
loop TcSigmaType
_ 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
External instance of the constraint type forall m. Monad (IOEnv m)
return ([], thing
thing) }
                                   -- matching in the branches

    loop TcSigmaType
m_ty ExpRhoType
inner_res_ty (TcSigmaType
tup_ty_in : [TcSigmaType]
tup_tys_in)
                           (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
return_op : [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { let m_tup_ty :: TcSigmaType
m_tup_ty = TcSigmaType
m_ty TcSigmaType -> TcSigmaType -> TcSigmaType
`mkAppTy` TcSigmaType
tup_ty_in
           ; ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing))
                <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType
    -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
m_tup_ty) ((ExpRhoType
  -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing)))
-> (ExpRhoType
    -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing))
forall a b. (a -> b) -> a -> b
$
                   \ExpRhoType
m_tup_ty' ->
                   do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
[IdP GhcRn]
names
                      ; let tup_ty :: TcSigmaType
tup_ty = [Id] -> TcSigmaType
mkBigCoreVarTupTy [Id]
ids
                      ; (()
_, SyntaxExprTc
return_op') <-
                          CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op
                                     [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty] ExpRhoType
m_tup_ty' (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                                     \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
                      ; ([ParStmtBlock GhcTcId GhcTcId]
pairs', 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
                      ; ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing)
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTcId GhcTcId], thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Id]
ids, SyntaxExprTc
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
External instance of the constraint type forall m. Monad (IOEnv m)
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' [Id]
[IdP GhcTcId]
ids SyntaxExpr GhcTcId
SyntaxExprTc
return_op' ParStmtBlock GhcTcId GhcTcId
-> [ParStmtBlock GhcTcId GhcTcId] -> [ParStmtBlock GhcTcId GhcTcId]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTcId GhcTcId]
pairs', thing
thing) }
    loop TcSigmaType
_ ExpRhoType
_ [TcSigmaType]
_ [ParStmtBlock GhcRn GhcRn]
_ = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTcId GhcTcId], thing)
forall a. String -> a
panic String
"tcMcStmt.loop"

tcMcStmt HsStmtContext GhcRn
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr Stmt GhcRn (LHsExpr GhcRn)
stmt)


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

tcDoStmt :: TcExprStmtChecker

tcDoStmt :: HsStmtContext GhcRn
-> Stmt GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
tcDoStmt HsStmtContext GhcRn
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
x LHsExpr GhcRn
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do { LHsExpr GhcTcId
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC LHsExpr GhcRn
body ExpRhoType
res_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. String -> a
panic String
"tcDoStmt: thing_inside")
       ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LHsExpr GhcTcId
-> Maybe Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
XLastStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
x LHsExpr GhcTcId
body' Maybe Bool
noret SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

tcDoStmt HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
xbsrn LPat GhcRn
pat LHsExpr GhcRn
rhs) ExpRhoType
res_ty 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 #1537

          ((LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', TcSigmaType
new_res_ty, thing
thing), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
XBindStmtRn
xbsrn) [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> TcM
       (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
 -> TcM
      ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
       SyntaxExprTc))
-> ([TcSigmaType]
    -> TcM
         (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing))
-> TcM
     ((LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                \ [TcSigmaType
rhs_ty, TcSigmaType
pat_ty, TcSigmaType
new_res_ty] ->
                do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
rhs_ty)
                   ; (Located (Pat GhcTcId)
pat', thing
thing) <- HsMatchContext GhcRn
-> LPat GhcRn
-> TcSigmaType
-> TcM thing
-> TcM (LPat GhcTcId, thing)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat 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, Located (Pat GhcTcId), TcSigmaType, thing)
-> TcM (LHsExpr GhcTcId, Located (Pat GhcTcId), TcSigmaType, thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LHsExpr GhcTcId
rhs', Located (Pat GhcTcId)
pat', TcSigmaType
new_res_ty, thing
thing) }

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
External instance of the constraint type Monad Maybe
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
     -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable Maybe
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
XBindStmtRn
xbsrn) ((SyntaxExprRn
  -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
            CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (FailOperator GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail TcSigmaType
new_res_ty
        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc :: SyntaxExpr GhcTcId
-> TcSigmaType -> FailOperator GhcTcId -> XBindStmtTc
XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTcId
xbstc_bindOp = SyntaxExpr GhcTcId
SyntaxExprTc
bind_op'
                , xbstc_boundResultType :: TcSigmaType
xbstc_boundResultType = TcSigmaType
new_res_ty
                , xbstc_failOp :: FailOperator GhcTcId
xbstc_failOp = FailOperator GhcTcId
Maybe SyntaxExprTc
fail_op'
                }
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> LPat GhcTcId
-> LHsExpr GhcTcId
-> Stmt GhcTcId (LHsExpr GhcTcId)
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
XBindStmtTc
xbstc Located (Pat GhcTcId)
LPat GhcTcId
pat' LHsExpr GhcTcId
rhs', thing
thing) }

tcDoStmt HsStmtContext GhcRn
ctxt (ApplicativeStmt XApplicativeStmt GhcRn GhcRn (LHsExpr GhcRn)
_ [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs FailOperator GhcRn
mb_join) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { let tc_app_stmts :: ExpRhoType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ExpRhoType
ty = HsStmtContext GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcSigmaType -> TcM thing)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
forall t.
HsStmtContext GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts HsStmtContext GhcRn
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
        ; (([(SyntaxExprTc, ApplicativeArg GhcTcId)]
pairs', TcSigmaType
body_ty, thing
thing), Maybe SyntaxExprTc
mb_join') <- case FailOperator GhcRn
mb_join of
            FailOperator GhcRn
Nothing -> (, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing)
 -> (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
     Maybe SyntaxExprTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
      Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> ExpRhoType
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType,
      thing)
tc_app_stmts ExpRhoType
res_ty
            Just SyntaxExpr GhcRn
join_op ->
              (SyntaxExprTc -> Maybe SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
    SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
    Maybe SyntaxExprTc)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
External instance of the constraint type Arrow (->)
second SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just ((([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
  SyntaxExprTc)
 -> (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
     Maybe SyntaxExprTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
      SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
      Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$>
              (CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
join_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType]
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       ([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
       SyntaxExprTc))
-> ([TcSigmaType]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTcId)], TcSigmaType, thing),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [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
External instance of the constraint type forall m. Monad (IOEnv m)
return (XApplicativeStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
-> [(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)]
-> FailOperator 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)]
[(SyntaxExprTc, ApplicativeArg GhcTcId)]
pairs' FailOperator GhcTcId
Maybe SyntaxExprTc
mb_join', thing
thing) }

tcDoStmt HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  {       -- Deal with rebindable syntax;
                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
        ; ((LHsExpr GhcTcId
rhs', TcSigmaType
rhs_ty, thing
thing), SyntaxExprTc
then_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
-> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
 -> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExprTc))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId, TcSigmaType, thing))
-> TcM ((LHsExpr GhcTcId, TcSigmaType, thing), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType
rhs_ty, TcSigmaType
new_res_ty] ->
               do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcLExprNC 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
External instance of the constraint type forall m. Monad (IOEnv m)
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
External instance of the constraint type forall m. Monad (IOEnv m)
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
SyntaxExprTc
then_op' SyntaxExpr GhcTcId
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

tcDoStmt HsStmtContext GhcRn
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 })
         ExpRhoType
res_ty 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
External instance of the constraint type Eq Name
External instance of the constraint type Foldable []
`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
External instance of the constraint type Foldable []
length [Name]
tup_names) TcSigmaType
liftedTypeKind
        ; let tup_ids :: [Id]
tup_ids = (Name -> TcSigmaType -> Id) -> [Name] -> [TcSigmaType] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith HasDebugCallStack => Name -> TcSigmaType -> Id
Name -> TcSigmaType -> Id
External instance of the constraint type HasDebugCallStack
mkLocalId [Name]
tup_names [TcSigmaType]
tup_elt_tys
              tup_ty :: TcSigmaType
tup_ty  = [TcSigmaType] -> TcSigmaType
mkBigCoreTupTy [TcSigmaType]
tup_elt_tys

        ; [Id]
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
tup_ids (TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
 -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing))
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a b. (a -> b) -> a -> b
$ do
        { (([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (SyntaxExprTc
ret_op', [HsExpr GhcTcId]
tup_rets)), TcSigmaType
stmts_ty)
                <- (ExpRhoType
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExprTc, [HsExpr GhcTcId])))
-> TcM
     (([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExprTc, [HsExpr GhcTcId])),
      TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer ((ExpRhoType
  -> TcM
       ([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExprTc, [HsExpr GhcTcId])))
 -> TcM
      (([LStmt GhcTcId (LHsExpr GhcTcId)],
        (SyntaxExprTc, [HsExpr GhcTcId])),
       TcSigmaType))
-> (ExpRhoType
    -> TcM
         ([LStmt GhcTcId (LHsExpr GhcTcId)],
          (SyntaxExprTc, [HsExpr GhcTcId])))
-> TcM
     (([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExprTc, [HsExpr GhcTcId])),
      TcSigmaType)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
                   HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTcId]))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (SyntaxExprTc, [HsExpr GhcTcId]))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
exp_ty ((ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTcId]))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (SyntaxExprTc, [HsExpr GhcTcId])))
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTcId]))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (SyntaxExprTc, [HsExpr GhcTcId]))
forall a b. (a -> b) -> a -> b
$ \ 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]
External instance of the constraint type forall m. Applicative (IOEnv m)
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
                      ; (()
_, SyntaxExprTc
ret_op')
                          <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
ret_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
tup_ty]
                                        ExpRhoType
inner_res_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
                      ; (SyntaxExprTc, [HsExpr GhcTcId])
-> TcM (SyntaxExprTc, [HsExpr GhcTcId])
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (SyntaxExprTc
ret_op', [HsExpr GhcTcId]
tup_rets) }

        ; ((()
_, SyntaxExprTc
mfix_op'), TcSigmaType
mfix_res_ty)
            <- (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer ((ExpRhoType -> TcM ((), SyntaxExprTc))
 -> TcM (((), SyntaxExprTc), TcSigmaType))
-> (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), TcSigmaType)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
               CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
mfix_op
                          [TcSigmaType -> SyntaxOpType
synKnownType (TcSigmaType -> TcSigmaType -> TcSigmaType
mkVisFunTy TcSigmaType
tup_ty TcSigmaType
stmts_ty)] ExpRhoType
exp_ty (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()

        ; ((thing
thing, TcSigmaType
new_res_ty), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM (thing, TcSigmaType))
-> TcM ((thing, TcSigmaType), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
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), SyntaxExprTc))
-> ([TcSigmaType] -> TcM (thing, TcSigmaType))
-> TcM ((thing, TcSigmaType), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [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
External instance of the constraint type forall m. Monad (IOEnv m)
return (thing
thing, TcSigmaType
new_res_ty) }

        ; let rec_ids :: [Id]
rec_ids = [Name] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
takeList [Name]
[IdP GhcRn]
rec_names [Id]
tup_ids
        ; [Id]
later_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
[IdP GhcRn]
later_names
        ; String -> SDoc -> TcRn ()
traceTc String
"tcdo" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [[Id] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Id
ppr [Id]
rec_ids SDoc -> SDoc -> SDoc
<+> [TcSigmaType] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable TcSigmaType
ppr ((Id -> TcSigmaType) -> [Id] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TcSigmaType
idType [Id]
rec_ids),
                                 [Id] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Id
ppr [Id]
later_ids SDoc -> SDoc -> SDoc
<+> [TcSigmaType] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable TcSigmaType
ppr ((Id -> TcSigmaType) -> [Id] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TcSigmaType
idType [Id]
later_ids)]
        ; (Stmt GhcTcId (LHsExpr GhcTcId), thing)
-> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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 = [Id]
[IdP GhcTcId]
later_ids
                          , recS_rec_ids :: [IdP GhcTcId]
recS_rec_ids = [Id]
[IdP GhcTcId]
rec_ids, recS_ret_fn :: SyntaxExpr GhcTcId
recS_ret_fn = SyntaxExpr GhcTcId
SyntaxExprTc
ret_op'
                          , recS_mfix_fn :: SyntaxExpr GhcTcId
recS_mfix_fn = SyntaxExpr GhcTcId
SyntaxExprTc
mfix_op', recS_bind_fn :: SyntaxExpr GhcTcId
recS_bind_fn = SyntaxExpr GhcTcId
SyntaxExprTc
bind_op'
                          , recS_ext :: XRecStmt GhcTcId GhcTcId (LHsExpr GhcTcId)
recS_ext = RecStmtTc :: TcSigmaType
-> [HsExpr GhcTcId] -> [HsExpr GhcTcId] -> TcSigmaType -> RecStmtTc
RecStmtTc
                            { recS_bind_ty :: TcSigmaType
recS_bind_ty = TcSigmaType
new_res_ty
                            , recS_later_rets :: [HsExpr GhcTcId]
recS_later_rets = []
                            , recS_rec_rets :: [HsExpr GhcTcId]
recS_rec_rets = [HsExpr GhcTcId]
tup_rets
                            , recS_ret_ty :: TcSigmaType
recS_ret_ty = TcSigmaType
stmts_ty} }, thing
thing)
        }}

tcDoStmt HsStmtContext GhcRn
_ Stmt GhcRn (LHsExpr GhcRn)
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String -> SDoc -> TcM (Stmt GhcTcId (LHsExpr GhcTcId), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
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
-- GHC.Tc.Errors.hs.

tcMonadFailOp :: CtOrigin
              -> LPat GhcTcId
              -> SyntaxExpr GhcRn    -- The fail op
              -> TcType              -- Type of the whole do-expression
              -> TcRn (FailOperator GhcTcId)  -- Typechecked fail op
-- Get a 'fail' operator expression, to use if the pattern match fails.
-- This won't be used in cases where we've already determined the pattern
-- match can't fail (so the fail op is Nothing), however, it seems that the
-- isIrrefutableHsPat test is still required here for some reason I haven't
-- yet determined.
tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (FailOperator GhcTcId)
tcMonadFailOp CtOrigin
orig LPat GhcTcId
pat SyntaxExpr GhcRn
fail_op TcSigmaType
res_ty
  | LPat GhcTcId -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
isIrrefutableHsPat LPat GhcTcId
pat
  = Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
  | Bool
otherwise
  = SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (SyntaxExprTc -> Maybe SyntaxExprTc)
-> (((), SyntaxExprTc) -> SyntaxExprTc)
-> ((), SyntaxExprTc)
-> Maybe SyntaxExprTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), SyntaxExprTc) -> SyntaxExprTc
forall a b. (a, b) -> b
snd (((), SyntaxExprTc) -> Maybe SyntaxExprTc)
-> TcM ((), SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> (CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
SyntaxExprRn
fail_op [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
stringTy]
                             (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
res_ty) (([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcSigmaType] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[TcSigmaType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
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 (tcLExprNC rhs).
Otherwise the error shows up when checking the rebindable syntax, and
the expected/inferred stuff is back to front (see #3613).

Note [typechecking ApplicativeStmt]

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

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

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

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

tcApplicativeStmts :: HsStmtContext GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcSigmaType -> TcM t)
-> TcM
     ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], TcSigmaType, t)
tcApplicativeStmts HsStmtContext GhcRn
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
rhs_ty TcSigmaType -> TcM t
thing_inside
 = do { TcSigmaType
body_ty <- TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
      ; let arity :: Arity
arity = [(SyntaxExprRn, ApplicativeArg GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
External instance of the constraint type Foldable []
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
      ; [ExpRhoType]
ts <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType -> TcM [ExpRhoType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
External instance of the constraint type forall m. Applicative (IOEnv m)
replicateM (Arity
arityArity -> Arity -> Arity
forall a. Num a => a -> a -> a
External instance of the constraint type Num Arity
-Arity
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
newInferExpType
      ; [TcSigmaType]
exp_tys <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
External instance of the constraint type forall m. Applicative (IOEnv m)
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]
External instance of the constraint type forall m. Applicative (IOEnv m)
replicateM Arity
arity (IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
 -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType])
-> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
      ; let fun_ty :: TcSigmaType
fun_ty = [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [TcSigmaType]
pat_tys TcSigmaType
body_ty

       -- NB. do the <$>,<*> operators first, we don't want type errors here
       --     i.e. goOps before goArgs
       -- See Note [Treat rebindable syntax first]
      ; let ([SyntaxExprRn]
ops, [ApplicativeArg GhcRn]
args) = [(SyntaxExprRn, ApplicativeArg GhcRn)]
-> ([SyntaxExprRn], [ApplicativeArg GhcRn])
forall a b. [(a, b)] -> ([a], [b])
unzip [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
      ; [SyntaxExprTc]
ops' <- TcSigmaType
-> [(SyntaxExprRn, ExpRhoType, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps TcSigmaType
fun_ty ([SyntaxExprRn]
-> [ExpRhoType]
-> [TcSigmaType]
-> [(SyntaxExprRn, ExpRhoType, TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SyntaxExprRn]
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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (TcSigmaType
-> (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg TcSigmaType
body_ty) ([ApplicativeArg GhcRn]
-> [TcSigmaType]
-> [TcSigmaType]
-> [(ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ApplicativeArg GhcRn]
args [TcSigmaType]
pat_tys [TcSigmaType]
exp_tys)

      -- Bring into scope all the things bound by the args,
      -- and typecheck the thing_inside
      -- See Note [ApplicativeDo and constraints]
      ; t
res <- [Id] -> TcM t -> TcM t
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv ((ApplicativeArg GhcTcId -> [Id])
-> [ApplicativeArg GhcTcId] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
External instance of the constraint type Foldable []
concatMap ApplicativeArg GhcTcId -> [Id]
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

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

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

    goArg :: TcSigmaType
-> (ApplicativeArg GhcRn, TcSigmaType, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
goArg TcSigmaType
body_ty (ApplicativeArgOne
                    { xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
xarg_app_arg_one = XApplicativeArgOne GhcRn
fail_op
                    , app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcRn
pat
                    , arg_expr :: forall idL. ApplicativeArg idL -> LHsExpr idL
arg_expr = LHsExpr GhcRn
rhs
                    , Bool
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
is_body_stmt :: Bool
..
                    }, TcSigmaType
pat_ty, TcSigmaType
exp_ty)
      = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (GenLocated SrcSpan (Pat GhcRn) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
pat) (LHsExpr GhcRn -> SrcSpan
forall l e. GenLocated l e -> l
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 GhcRn -> Stmt GhcRn (LHsExpr GhcRn) -> SDoc
forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body) =>
HsStmtContext (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
pprStmtInCtxt HsStmtContext GhcRn
ctxt (LPat GhcRn -> LHsExpr GhcRn -> Stmt GhcRn (LHsExpr GhcRn)
forall (bodyR :: * -> *).
LPat GhcRn
-> Located (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))
mkRnBindStmt 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)
tcLExprNC LHsExpr GhcRn
rhs (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
exp_ty)
           ; (Located (Pat GhcTcId)
pat', ()
_) <- HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat 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
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
           ; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
External instance of the constraint type Monad Maybe
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
     -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable Maybe
forM Maybe SyntaxExprRn
XApplicativeArgOne GhcRn
fail_op ((SyntaxExprRn
  -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
               CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcSigmaType
-> TcRn (FailOperator GhcTcId)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) Located (Pat GhcTcId)
LPat GhcTcId
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail TcSigmaType
body_ty

           ; ApplicativeArg GhcTcId
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne
                      { xarg_app_arg_one :: XApplicativeArgOne GhcTcId
xarg_app_arg_one = Maybe SyntaxExprTc
XApplicativeArgOne GhcTcId
fail_op'
                      , app_arg_pattern :: LPat GhcTcId
app_arg_pattern = Located (Pat GhcTcId)
LPat GhcTcId
pat'
                      , arg_expr :: LHsExpr GhcTcId
arg_expr        = LHsExpr GhcTcId
rhs'
                      , Bool
is_body_stmt :: Bool
is_body_stmt :: Bool
.. }
                    ) }

    goArg TcSigmaType
_body_ty (ApplicativeArgMany XApplicativeArgMany GhcRn
x [GuardLStmt GhcRn]
stmts HsExpr GhcRn
ret LPat GhcRn
pat, TcSigmaType
pat_ty, TcSigmaType
exp_ty)
      = do { ([LStmt GhcTcId (LHsExpr GhcTcId)]
stmts', (HsExpr GhcTcId
ret',Located (Pat GhcTcId)
pat')) <-
                HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (HsExpr GhcTcId, Located (Pat GhcTcId)))
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
stmts (TcSigmaType -> ExpRhoType
mkCheckExpType TcSigmaType
exp_ty) ((ExpRhoType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
 -> TcM
      ([LStmt GhcTcId (LHsExpr GhcTcId)],
       (HsExpr GhcTcId, Located (Pat GhcTcId))))
-> (ExpRhoType -> TcM (HsExpr GhcTcId, Located (Pat GhcTcId)))
-> TcM
     ([LStmt GhcTcId (LHsExpr GhcTcId)],
      (HsExpr GhcTcId, Located (Pat GhcTcId)))
forall a b. (a -> b) -> a -> b
$
                \ExpRhoType
res_ty  -> do
                  { HsExpr GhcTcId
ret'      <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
ret ExpRhoType
res_ty
                  ; (Located (Pat GhcTcId)
pat', ()
_) <- HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcRn () -> TcM (LPat GhcTcId, ())
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType -> TcM a -> TcM (LPat GhcTcId, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat 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
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
                  ; (HsExpr GhcTcId, Located (Pat GhcTcId))
-> TcM (HsExpr GhcTcId, Located (Pat GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsExpr GhcTcId
ret', Located (Pat GhcTcId)
pat')
                  }
           ; ApplicativeArg GhcTcId
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XApplicativeArgMany GhcTcId
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> HsExpr GhcTcId
-> LPat GhcTcId
-> ApplicativeArg GhcTcId
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcRn
XApplicativeArgMany GhcTcId
x [LStmt GhcTcId (LHsExpr GhcTcId)]
stmts' HsExpr GhcTcId
ret' Located (Pat GhcTcId)
LPat GhcTcId
pat') }

    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcTcId
pat }) = LPat GhcTcId -> [IdP GhcTcId]
forall p. CollectPass p => LPat p -> [IdP p]
External instance of the constraint type CollectPass GhcTcId
collectPatBinders LPat GhcTcId
pat
    get_arg_bndrs (ApplicativeArgMany { bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern =  LPat GhcTcId
pat }) = LPat GhcTcId -> [IdP GhcTcId]
forall p. CollectPass p => LPat p -> [IdP p]
External instance of the constraint type CollectPass GhcTcId
collectPatBinders LPat GhcTcId
pat

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

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

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

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

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

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

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

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

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

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

    args_in_match :: LMatch GhcRn body -> Int
    args_in_match :: LMatch GhcRn body -> Arity
args_in_match (L SrcSpan
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })) = [GenLocated SrcSpan (Pat GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
External instance of the constraint type Foldable []
length [GenLocated SrcSpan (Pat GhcRn)]
[LPat GhcRn]
pats