{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes       #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE ScopedTypeVariables  #-}

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

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

-}

-- | Typecheck some @Matches@
module GHC.Tc.Gen.Match
   ( tcFunBindMatches
   , tcCaseMatches
   , tcLambdaMatches
   , tcGRHSList
   , tcGRHSsPat
   , TcStmtChecker
   , TcExprStmtChecker
   , TcCmdStmtChecker
   , tcStmts
   , tcStmtsAndThen
   , tcDoStmts
   , tcBody
   , tcDoStmt
   , tcGuardStmt
   , checkArgCounts
   )
where

import GHC.Prelude

import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
                                       , tcMonoExprNC, tcExpr
                                       , tcCheckMonoExpr, tcCheckMonoExprNC
                                       , tcCheckPolyExpr, tcPolyLExpr )

import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPat )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Gen.Bind
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence

import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCon
-- Create chunkified tuple types for monad comprehensions
import GHC.Core.Make

import GHC.Hs

import GHC.Builtin.Types
import GHC.Builtin.Types.Prim

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Driver.DynFlags ( getDynFlags )

import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )

import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)

import qualified GHC.LanguageExtensions as LangExt


{-
************************************************************************
*                                                                      *
\subsection{tcFunBindMatches, tcCaseMatches}
*                                                                      *
************************************************************************

`tcFunBindMatches` typechecks a `[Match]` list which occurs in a
`FunBind`.  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.
-}

tcFunBindMatches :: UserTypeCtxt
                 -> Name            -- Function name
                 -> Mult            -- The multiplicity of the binder
                 -> MatchGroup GhcRn (LHsExpr GhcRn)
                 -> [ExpPatType]    -- Scoped skolemised binders
                 -> ExpRhoType      -- Expected type of function; caller
                                    -- has skolemised any outer forall's
                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-- See Note [Skolemisation overview] in GHC.Tc.Utils.Unify
tcFunBindMatches :: UserTypeCtxt
-> Name
-> Mult
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches UserTypeCtxt
ctxt Name
fun_name Mult
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys ExpRhoType
exp_ty
  = Bool
-> SDoc
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition MatchGroup GhcRn (LHsExpr GhcRn)
matches) (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches) (TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
 -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
    do  {  -- Check that they all have the same no of arguments
          VisArity
arity <- MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM VisArity
forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches

        ; String -> SDoc -> TcRn ()
traceTc String
"tcFunBindMatches 1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun_name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr Mult
mult SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ VisArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr VisArity
arity)

        ; (HsWrapper
wrap_fun, (HsWrapper
wrap_mult, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r))
             <- ExpectedFunTyOrigin
-> UserTypeCtxt
-> VisArity
-> ExpRhoType
-> ([ExpPatType]
    -> ExpRhoType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> VisArity
-> ExpRhoType
-> ([ExpPatType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
ctxt VisArity
arity ExpRhoType
exp_ty (([ExpPatType]
  -> ExpRhoType
  -> TcM
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> TcM
      (HsWrapper,
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> ([ExpPatType]
    -> ExpRhoType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ \ [ExpPatType]
pat_tys ExpRhoType
rhs_ty ->
                Mult
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM
   (HsWrapper,
    MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
                   -- Makes sure that if the binding is unrestricted, it counts as
                   -- consuming its rhs Many times.

                do { String -> SDoc -> TcRn ()
traceTc String
"tcFunBindMatches 2" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt, [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
invis_pat_tys
                                                      , [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
pat_tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
rhs_ty ])
                   ; TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody ([ExpPatType]
invis_pat_tys [ExpPatType] -> [ExpPatType] -> [ExpPatType]
forall a. [a] -> [a] -> [a]
++ [ExpPatType]
pat_tys) ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches }

        ; (HsWrapper,
 MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap_fun HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_mult, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r) }
  where
    herald :: ExpectedFunTyOrigin
herald        = TypedThing
-> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
ExpectedFunTyMatches (Name -> TypedThing
NameThing Name
fun_name) MatchGroup GhcRn (LHsExpr GhcRn)
matches

funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts })
  = Bool -> Bool
not ([GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts) Bool -> Bool -> Bool
&& (GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> Bool)
-> [GenLocated
      SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated
  SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Bool
forall {l} {p} {body}. GenLocated l (Match p body) -> Bool
is_fun_rhs [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts
  where
    is_fun_rhs :: GenLocated l (Match p body) -> Bool
is_fun_rhs (L l
_ (Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt = FunRhs {} })) = Bool
True
    is_fun_rhs GenLocated l (Match p body)
_                                    = Bool
False

tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant
                -> MatchGroup GhcRn (LHsExpr GhcRn)
                -> [ExpPatType]  -- Already skolemised
                -> ExpSigmaType  -- NB can be a sigma-type
                -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches :: HsExpr GhcRn
-> HsLamVariant
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr GhcRn
e HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys ExpRhoType
res_ty
  =  do { VisArity
arity <- MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM VisArity
forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches
            -- Check argument counts since this is also used for \cases

        ; (HsWrapper
wrapper, (HsWrapper
mult_co_wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r))
            <- ExpectedFunTyOrigin
-> UserTypeCtxt
-> VisArity
-> ExpRhoType
-> ([ExpPatType]
    -> ExpRhoType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> VisArity
-> ExpRhoType
-> ([ExpPatType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
GenSigCtxt VisArity
arity ExpRhoType
res_ty (([ExpPatType]
  -> ExpRhoType
  -> TcM
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> TcM
      (HsWrapper,
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> ([ExpPatType]
    -> ExpRhoType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ \ [ExpPatType]
pat_tys ExpRhoType
rhs_ty ->
               TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tc_body ([ExpPatType]
invis_pat_tys [ExpPatType] -> [ExpPatType] -> [ExpPatType]
forall a. [a] -> [a] -> [a]
++ [ExpPatType]
pat_tys) ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches

        ; (HsWrapper,
 MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
mult_co_wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r) }
  where
    herald :: ExpectedFunTyOrigin
herald = HsLamVariant -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTyLam HsLamVariant
lam_variant HsExpr GhcRn
e
             -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify

    tc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tc_body | Origin -> Bool
isDoExpansionGenerated (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> XMG GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall p body. MatchGroup p body -> XMG p body
mg_ext MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches)
              -- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in
              -- `GHC.Tc.Gen.Do`. Testcase: Typeable1
            = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC -- NB: Do not add any error contexts
                       -- It has already been done
            | Bool
otherwise
            = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody

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

tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))
              => TcMatchAltChecker body    -- ^ Typecheck the alternative RHSS
              -> Scaled TcSigmaTypeFRR     -- ^ Type of scrutinee
              -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
              -> ExpRhoType                               -- ^ Type of the whole case expression
              -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
                -- Translated alternatives
                -- wrapper goes from MatchGroup's ty to expected ty

tcCaseMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> Scaled Mult
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches TcMatchAltChecker body
tc_body (Scaled Mult
scrut_mult Mult
scrut_ty) MatchGroup GhcRn (LocatedA (body GhcRn))
matches ExpRhoType
res_ty
  = TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchAltChecker body
tc_body [Scaled ExpRhoType -> ExpPatType
ExpFunPatTy (Mult -> ExpRhoType -> Scaled ExpRhoType
forall a. Mult -> a -> Scaled a
Scaled Mult
scrut_mult (Mult -> ExpRhoType
mkCheckExpType Mult
scrut_ty))] ExpRhoType
res_ty MatchGroup GhcRn (LocatedA (body GhcRn))
matches

-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
           -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-- Used for pattern bindings
tcGRHSsPat :: Mult
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Mult
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpRhoType
res_ty
  = Mult
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (GRHSs GhcTc (LHsExpr GhcTc))
 -> TcM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ do
    { (HsWrapper
mult_co_wrapper, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r) <- HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> TcM
     (HsWrapper, GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatBindRhs LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody GRHSs GhcRn (LHsExpr GhcRn)
GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss ExpRhoType
res_ty
    ; GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ HsWrapper
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall {p} {l}.
(XRec p (GRHS p (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 ~ GenLocated l (GRHS p (GenLocated SrcSpanAnnA (HsExpr GhcTc)))) =>
HsWrapper
-> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mkWrap HsWrapper
mult_co_wrapper GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
r }
  where
    mkWrap :: HsWrapper
-> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mkWrap HsWrapper
wrap grhss :: GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss@(GRHSs { grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = L l
loc (GRHS XCGRHS p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x [GuardLStmt p]
guards GenLocated SrcSpanAnnA (HsExpr GhcTc)
body) : [XRec p (GRHS p (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rhss }) =
      GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss { grhssGRHSs = L loc (GRHS x guards (mkLHsWrap wrap body)) : rhss }
    mkWrap HsWrapper
_ (GRHSs { grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [] }) = String -> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. HasCallStack => String -> a
panic String
"tcGRHSsPat: empty GHRSs"
    mkWrap HsWrapper
_ GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ = String -> GRHSs p (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. HasCallStack => String -> a
panic String
"tcGRHSsPat: non-empty extensions"
    -- Should be the following but it warns of redundant pattern and I couldn't
    -- find a way to silence them
    --
    -- mkWrap _ (GRHSs { grhssGRHSs = L _ (XGRHS absent) : _ }) = dataConCantHappen absent
    -- mkWrap _ (XGRHSs absent) = dataConCantHappen absent

{- *********************************************************************
*                                                                      *
                tcMatch
*                                                                      *
********************************************************************* -}

-- | Type checker for a body of a match alternative
type TcMatchAltChecker body   -- c.f. TcStmtChecker, also in this module
  =  LocatedA (body GhcRn)
  -> ExpRhoType
  -> TcM (LocatedA (body GhcTc))

type AnnoBody body
  = ( Outputable (body GhcRn)
    , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
    , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
    , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
    , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO
    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO
    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
    , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
    )

-- | Type-check a MatchGroup.
tcMatches :: (AnnoBody body, Outputable (body GhcTc))
          => TcMatchAltChecker body
          -> [ExpPatType]             -- ^ Expected pattern types.
          -> ExpRhoType               -- ^ Expected result-type of the Match.
          -> MatchGroup GhcRn (LocatedA (body GhcRn))
          -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))

tcMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
l [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
                                     , mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcRn (LocatedA (body GhcRn))
origin })
  | [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches  -- Deal with case e of {}
    -- Since there are no branches, no one else will fill in rhs_ty
    -- when in inference mode, so we must do it ourselves,
    -- here, using expTypeToType
  = do { UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
       ; [Scaled Mult]
pat_tys <- (Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> [Scaled ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
scaledExpTypeToType ([ExpPatType] -> [Scaled ExpRhoType]
filter_out_forall_pat_tys [ExpPatType]
pat_tys)
       ; Mult
rhs_ty  <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
rhs_ty
       ; (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts = SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l []
                                 , mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext = [Scaled Mult] -> Mult -> Origin -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty XMG GhcRn (LocatedA (body GhcRn))
Origin
origin
                                 }) }

  | Bool
otherwise
  = do { [(UsageEnv,
  (HsWrapper,
   GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))]
umatches <- (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (UsageEnv,
       (HsWrapper,
        GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))))
-> [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(UsageEnv,
       (HsWrapper,
        GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcM
  (HsWrapper,
   GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (UsageEnv,
      (HsWrapper,
       GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM
   (HsWrapper,
    GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (UsageEnv,
       (HsWrapper,
        GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))))
-> (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
    -> TcM
         (HsWrapper,
          GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (UsageEnv,
      (HsWrapper,
       GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty) [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
       ; let ([UsageEnv]
usages, [(HsWrapper,
  GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))]
wmatches) = [(UsageEnv,
  (HsWrapper,
   GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))]
-> ([UsageEnv],
    [(HsWrapper,
      GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))])
forall a b. [(a, b)] -> ([a], [b])
unzip [(UsageEnv,
  (HsWrapper,
   GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))]
umatches
       ; let ([HsWrapper]
wrappers, [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
matches') = [(HsWrapper,
  GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))]
-> ([HsWrapper],
    [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))])
forall a b. [(a, b)] -> ([a], [b])
unzip [(HsWrapper,
  GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))]
wmatches
       ; let wrapper :: HsWrapper
wrapper = [HsWrapper] -> HsWrapper
forall a. Monoid a => [a] -> a
mconcat [HsWrapper]
wrappers
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
       ; [Scaled Mult]
pat_tys  <- (Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> [Scaled ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
forall (m :: * -> *).
MonadIO m =>
Scaled ExpRhoType -> m (Scaled Mult)
readScaledExpType ([ExpPatType] -> [Scaled ExpRhoType]
filter_out_forall_pat_tys [ExpPatType]
pat_tys)
       ; Mult
rhs_ty   <- ExpRhoType -> TcM Mult
forall (m :: * -> *). MonadIO m => ExpRhoType -> m Mult
readExpType ExpRhoType
rhs_ty
       ; String -> SDoc -> TcRn ()
traceTc String
"tcMatches" ([GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
matches' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Scaled Mult] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Scaled Mult]
pat_tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr Mult
rhs_ty)
       ; (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrapper, MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts   = SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))]
matches'
                             , mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext    = [Scaled Mult] -> Mult -> Origin -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty XMG GhcRn (LocatedA (body GhcRn))
Origin
origin
                             }) }
  where
    -- We filter out foralls because we have no use for them in HsToCore.
    filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR]
    filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpRhoType]
filter_out_forall_pat_tys = (ExpPatType -> Maybe (Scaled ExpRhoType))
-> [ExpPatType] -> [Scaled ExpRhoType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ExpPatType -> Maybe (Scaled ExpRhoType)
match_fun_pat_ty
      where
        match_fun_pat_ty :: ExpPatType -> Maybe (Scaled ExpRhoType)
match_fun_pat_ty (ExpFunPatTy Scaled ExpRhoType
t)  = Scaled ExpRhoType -> Maybe (Scaled ExpRhoType)
forall a. a -> Maybe a
Just Scaled ExpRhoType
t
        match_fun_pat_ty ExpForAllPatTy{} = Maybe (Scaled ExpRhoType)
forall a. Maybe a
Nothing

-------------
tcMatch :: (AnnoBody body)
        => TcMatchAltChecker body
        -> [ExpPatType]          -- Expected pattern types
        -> ExpRhoType            -- Expected result-type of the Match.
        -> LMatch GhcRn (LocatedA (body GhcRn))
        -> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))

tcMatch :: forall (body :: * -> *).
AnnoBody body =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty LMatch GhcRn (LocatedA (body GhcRn))
match
  = do { (L SrcSpanAnnA
loc (HsWrapper
wrapper, Match GhcTc (LocatedA (body GhcTc))
r)) <- (Match GhcRn (LocatedA (body GhcRn))
 -> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> TcRn
     (GenLocated
        SrcSpanAnnA (HsWrapper, Match GhcTc (LocatedA (body GhcTc))))
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA ([ExpPatType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
tc_match [ExpPatType]
pat_tys ExpRhoType
rhs_ty) LMatch GhcRn (LocatedA (body GhcRn))
LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match
       ; (HsWrapper, LocatedA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HsWrapper, LocatedA (Match GhcTc (LocatedA (body GhcTc))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrapper, SrcSpanAnnA
-> Match GhcTc (LocatedA (body GhcTc))
-> LocatedA (Match GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Match GhcTc (LocatedA (body GhcTc))
r) }
  where
    tc_match :: [ExpPatType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
tc_match [ExpPatType]
pat_tys ExpRhoType
rhs_ty
             match :: Match GhcRn (LocatedA (body GhcRn))
match@(Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcRn))
ctxt, 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 (LocatedA (body GhcRn))
grhss })
      = TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
add_match_ctxt (TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
 -> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc))))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
        do { ([GenLocated SrcSpanAnnA (Pat GhcTc)]
pats', (HsWrapper
wrapper, GRHSs GhcTc (LocatedA (body GhcTc))
grhss')) <- HsMatchContextRn
-> [LPat GhcRn]
-> [ExpPatType]
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM
     ([LPat GhcTc], (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc))))
forall a.
HsMatchContextRn
-> [LPat GhcRn] -> [ExpPatType] -> TcM a -> TcM ([LPat GhcTc], a)
tcMatchPats HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContextRn
ctxt [LPat GhcRn]
pats [ExpPatType]
pat_tys (TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
 -> TcM
      ([LPat GhcTc], (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))))
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM
     ([LPat GhcTc], (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc))))
forall a b. (a -> b) -> a -> b
$
                                           HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body GRHSs GhcRn (LocatedA (body GhcRn))
grhss ExpRhoType
rhs_ty
             -- NB: pats' are just the /value/ patterns
             -- See Note [tcMatchPats] in GHC.Tc.Gen.Pat

           ; (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrapper, Match { m_ext :: XCMatch GhcTc (LocatedA (body GhcTc))
m_ext   = [AddEpAnn]
XCMatch GhcTc (LocatedA (body GhcTc))
forall a. NoAnn a => a
noAnn
                                    , m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcTc))
m_ctxt  = HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContext (LIdP (NoGhcTc GhcTc))
ctxt
                                    , m_pats :: [LPat GhcTc]
m_pats  = [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats'
                                    , m_grhss :: GRHSs GhcTc (LocatedA (body GhcTc))
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
grhss' }) }
      where
        -- 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"
        -- But for \cases with many alternatives, it is helpful to say
        --     which particular alternative we are looking at
        add_match_ctxt :: TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
add_match_ctxt TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
thing_inside = case HsMatchContext (LIdP (NoGhcTc GhcRn))
ctxt of
            LamAlt HsLamVariant
LamSingle -> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
thing_inside
            StmtCtxt (HsDoStmt{}) -> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
thing_inside -- this is an expanded do stmt
            HsMatchContext (LIdP (NoGhcTc GhcRn))
_          -> SDoc
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatchInCtxt Match GhcRn (LocatedA (body GhcRn))
match) TcM (HsWrapper, Match GhcTc (LocatedA (body GhcTc)))
thing_inside

-------------
tcGRHSs :: AnnoBody body
        => HsMatchContextRn
        -> TcMatchAltChecker body
        -> GRHSs GhcRn (LocatedA (body GhcRn))
        -> ExpRhoType
        -> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-- 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 :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body (GRHSs XCGRHSs GhcRn (LocatedA (body GhcRn))
_ [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss HsLocalBinds GhcRn
binds) ExpRhoType
res_ty
  = do  { (HsLocalBinds GhcTc
binds', HsWrapper
wrapper, [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss') <- HsLocalBinds GhcRn
-> TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> TcM
     (HsLocalBinds GhcTc, HsWrapper,
      [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
 -> TcM
      (HsLocalBinds GhcTc, HsWrapper,
       [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]))
-> TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> TcM
     (HsLocalBinds GhcTc, HsWrapper,
      [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall a b. (a -> b) -> a -> b
$ do
                                       HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss ExpRhoType
res_ty
        ; (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrapper, XCGRHSs GhcTc (LocatedA (body GhcTc))
-> [LGRHS GhcTc (LocatedA (body GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (LocatedA (body GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LocatedA (body GhcTc))
EpAnnComments
emptyComments [LGRHS GhcTc (LocatedA (body GhcTc))]
[GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss' HsLocalBinds GhcTc
binds') }

tcGRHSList :: forall body. AnnoBody body
           => HsMatchContextRn -> TcMatchAltChecker body
           -> [LGRHS GhcRn (LocatedA (body GhcRn))] -> ExpRhoType
           -> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss ExpRhoType
res_ty
   = do { ([UsageEnv]
usages, [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss') <- (GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (UsageEnv,
       GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> [GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([UsageEnv],
      [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((GRHS GhcRn (LocatedA (body GhcRn))
 -> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))))
-> GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (UsageEnv, GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
tc_alt) [LGRHS GhcRn (LocatedA (body GhcRn))]
[GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))]
grhss
        ; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
        ; [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss' }
   where
     stmt_ctxt :: HsStmtContext (GenLocated SrcSpanAnnN Name)
stmt_ctxt = HsMatchContext (GenLocated SrcSpanAnnN Name)
-> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn -> HsStmtContext fn
PatGuard HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt

     tc_alt :: GRHS GhcRn (LocatedA (body GhcRn))
            -> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
     tc_alt :: GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
tc_alt (GRHS XCGRHS GhcRn (LocatedA (body GhcRn))
_ [GuardLStmt GhcRn]
guards LocatedA (body GhcRn)
rhs)
       = TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (GRHS GhcTc (LocatedA (body GhcTc)))
 -> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
         do  { ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
guards', LocatedA (body GhcTc)
rhs')
                   <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      LocatedA (body GhcTc))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
stmt_ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (LocatedA (body GhcTc)))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       LocatedA (body GhcTc)))
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      LocatedA (body GhcTc))
forall a b. (a -> b) -> a -> b
$
                      TcMatchAltChecker body
tc_body LocatedA (body GhcRn)
rhs
             ; GRHS GhcTc (LocatedA (body GhcTc))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHS GhcTc (LocatedA (body GhcTc))
-> [GuardLStmt GhcTc]
-> LocatedA (body GhcTc)
-> GRHS GhcTc (LocatedA (body GhcTc))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
EpAnn GrhsAnn
forall a. NoAnn a => a
noAnn [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
guards' LocatedA (body GhcTc)
rhs') }

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

tcDoStmts :: HsDoFlavour
          -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
          -> ExpRhoType
          -> TcM (HsExpr GhcTc)          -- Returns a HsDo
tcDoStmts :: HsDoFlavour
-> LocatedL [GuardLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
ListComp (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { Mult
res_ty <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionN
co, Mult
elt_ty) <- Mult -> TcM (TcCoercionN, Mult)
matchExpectedListTy Mult
res_ty
        ; let list_ty :: Mult
list_ty = Mult -> Mult
mkListTy Mult
elt_ty
        ; [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ListComp) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
listTyCon) [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts
                            (Mult -> ExpRhoType
mkCheckExpType Mult
elt_ty)
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionN -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionN
co (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
list_ty HsDoFlavour
ListComp (SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts')) }

tcDoStmts doExpr :: HsDoFlavour
doExpr@(DoExpr Maybe ModuleName
_) ss :: LocatedL [GuardLStmt GhcRn]
ss@(L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { Bool
isApplicativeDo <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ApplicativeDo
        ; if Bool
isApplicativeDo
          then do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
doExpr) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
                  ; Mult
res_ty <- ExpRhoType -> TcM Mult
forall (m :: * -> *). MonadIO m => ExpRhoType -> m Mult
readExpType ExpRhoType
res_ty
                  ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
res_ty HsDoFlavour
doExpr (SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts')) }
          else do { GenLocated SrcSpanAnnA (HsExpr GhcRn)
expanded_expr <- HsDoFlavour -> [GuardLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts HsDoFlavour
doExpr [GuardLStmt GhcRn]
stmts
                                               -- Do expansion on the fly
                  ; HsExpr GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedExprTc (XDo GhcRn
-> HsDoFlavour -> XRec GhcRn [GuardLStmt GhcRn] -> HsExpr GhcRn
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcRn
NoExtField
noExtField HsDoFlavour
doExpr XRec GhcRn [GuardLStmt GhcRn]
LocatedL [GuardLStmt GhcRn]
ss) (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
expanded_expr) ExpRhoType
res_ty }
        }

tcDoStmts mDoExpr :: HsDoFlavour
mDoExpr@(MDoExpr Maybe ModuleName
_) ss :: LocatedL [GuardLStmt GhcRn]
ss@(L SrcSpanAnnL
_ [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { GenLocated SrcSpanAnnA (HsExpr GhcRn)
expanded_expr <- HsDoFlavour -> [GuardLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts HsDoFlavour
mDoExpr [GuardLStmt GhcRn]
stmts -- Do expansion on the fly
        ; HsExpr GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedExprTc (XDo GhcRn
-> HsDoFlavour -> XRec GhcRn [GuardLStmt GhcRn] -> HsExpr GhcRn
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcRn
NoExtField
noExtField HsDoFlavour
mDoExpr XRec GhcRn [GuardLStmt GhcRn]
LocatedL [GuardLStmt GhcRn]
ss) (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
expanded_expr) ExpRhoType
res_ty  }

tcDoStmts HsDoFlavour
MonadComp (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
MonadComp) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
        ; Mult
res_ty <- ExpRhoType -> TcM Mult
forall (m :: * -> *). MonadIO m => ExpRhoType -> m Mult
readExpType ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
res_ty HsDoFlavour
MonadComp (SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts')) }
tcDoStmts ctxt :: HsDoFlavour
ctxt@HsDoFlavour
GhciStmtCtxt LocatedL [GuardLStmt GhcRn]
_ ExpRhoType
_ = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (HsDoFlavour -> SDoc
pprHsDoFlavour HsDoFlavour
ctxt)

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

tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC LHsExpr GhcRn
body ExpRhoType
res_ty
  = do  { String -> SDoc -> TcRn ()
traceTc String
"tcBodyNC" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
        ; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC 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. HsStmtContextRn
                -> Stmt GhcRn (LocatedA (body GhcRn))
                -> rho_type                 -- Result type for comprehension
                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
                -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)

tcStmts :: (AnnoBody body) => HsStmtContextRn
        -> TcStmtChecker body rho_type   -- NB: higher-rank type
        -> [LStmt GhcRn (LocatedA (body GhcRn))]
        -> rho_type
        -> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts :: forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty
  = do { ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', ()
_) <- HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ())
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty ((rho_type -> TcRn ())
 -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ()))
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ())
forall a b. (a -> b) -> a -> b
$
                        TcRn () -> rho_type -> TcRn ()
forall a b. a -> b -> a
const (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts' }

tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn
               -> TcStmtChecker body rho_type    -- NB: higher-rank type
               -> [LStmt GhcRn (LocatedA (body GhcRn))]
               -> rho_type
               -> (rho_type -> TcM thing)
               -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)

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

tcStmtsAndThen :: forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
_ 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
        ; ([GenLocated
    SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }

-- LetStmts are handled uniformly, regardless of context
tcStmtsAndThen HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpanAnnA
loc (LetStmt XLetStmt GhcRn GhcRn (LocatedA (body GhcRn))
x HsLocalBinds GhcRn
binds) : [LStmt GhcRn (LocatedA (body GhcRn))]
stmts)
                                                             rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { (HsLocalBinds GhcTc
binds', HsWrapper
_, ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts',thing
thing)) <- HsLocalBinds GhcRn
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
-> TcM
     (HsLocalBinds GhcTc, HsWrapper,
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (IOEnv
   (Env TcGblEnv TcLclEnv)
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
    thing)
 -> TcM
      (HsLocalBinds GhcTc, HsWrapper,
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
-> TcM
     (HsLocalBinds GhcTc, HsWrapper,
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$
              HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty rho_type -> TcM thing
thing_inside
        ; ([GenLocated
    SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
-> HsLocalBinds GhcTc -> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (LocatedA (body GhcRn))
XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
x HsLocalBinds GhcTc
binds') GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
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 HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpanAnnA
loc StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt : [LStmt GhcRn (LocatedA (body GhcRn))]
stmts) rho_type
res_ty rho_type -> TcM thing
thing_inside
  | ApplicativeStmt{} <- StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt
  = do  { (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt', ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing)) <-
             HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated
             SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
          thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContextRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty ((rho_type
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing))
 -> TcM
      (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing)))
-> (rho_type
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated
             SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
          thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
               HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty'  ((rho_type -> TcM thing)
 -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall a b. (a -> b) -> a -> b
$
                 rho_type -> TcM thing
thing_inside
        ; ([GenLocated
    SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }

  -- For the vanilla case, handle the location-setting part
  | Bool
otherwise
  = do  { (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt', ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing)) <-
                SrcSpanAnnA
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc                             (TcM
   (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
    ([GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
     thing))
 -> TcM
      (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing)))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$
                SDoc
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) fn body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable fn,
 Outputable body,
 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext fn -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt)        (TcM
   (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
    ([GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
     thing))
 -> TcM
      (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing)))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$
                HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated
             SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
          thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContextRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty                   ((rho_type
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing))
 -> TcM
      (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
       ([GenLocated
           SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
        thing)))
-> (rho_type
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated
             SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
          thing))
-> TcM
     (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
                IOEnv
  (Env TcGblEnv TcLclEnv)
  ([GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
   thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a. TcM a -> TcM a
popErrCtxt                                  (IOEnv
   (Env TcGblEnv TcLclEnv)
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
    thing)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([GenLocated
          SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
       thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a b. (a -> b) -> a -> b
$
                HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty'  ((rho_type -> TcM thing)
 -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall a b. (a -> b) -> a -> b
$
                rho_type -> TcM thing
thing_inside
        ; ([GenLocated
    SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }

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

tcGuardStmt :: TcExprStmtChecker
tcGuardStmt :: TcStmtChecker HsExpr ExpRhoType
tcGuardStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
guard SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { GenLocated SrcSpanAnnA (HsExpr GhcTc)
guard' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
guard Mult
boolTy
          -- Scale the guard to Many (see #19120 and #19193)
        ; thing
thing  <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
res_ty
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
boolTy GenLocated SrcSpanAnnA (HsExpr GhcTc)
guard' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcGuardStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { -- The Many on the next line and the unrestricted on the line after
          -- are linked. These must be the same multiplicity. Consider
          --   x <- rhs -> u
          --
          -- The multiplicity of x in u must be the same as the multiplicity at
          -- which the rhs has been consumed. When solving #18738, we want these
          -- two multiplicity to still be the same.
          (GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
rhs_ty) <- Mult -> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult))
-> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
tcInferRhoNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
                                   -- Stmt has a context already
        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRBindStmtGuard Mult
rhs_ty
        ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing)  <- HsMatchContextRn
-> CtOrigin
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContextRn
-> CtOrigin
-> LPat GhcRn
-> Scaled Mult
-> TcM a
-> TcM (LPat GhcTc, a)
tcCheckPat_O (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs)
                                         LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
rhs_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
res_ty
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', thing
thing) }

tcGuardStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String
-> SDoc
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcGuardStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr 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

{-
Note [Binding in list comprehension isn't linear]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`.
But, the way the desugaring works, we get something like

case xs of
  () : xs ' -> letrec next_stmt = … xs' …

In the current typing rules for letrec in Core, next_stmt is necessarily of
multiplicity Many and so is every free variable, including xs'. Which, in turns,
requires xs to be of multiplicity Many.

Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having
non-Many multiplicities. But it's a fair bit of work to implement.

Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then
we just conservatively make it unrestricted instead.

If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]]
isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have
to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh
multiplicity variable. We'd also use the same multiplicity variable in the call
to `tcCheckPat` instead of `unrestricted`.
-}

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

tcLcStmt :: TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
_ HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body ExpRhoType
elt_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcLcStmt: thing_inside")
       ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

-- A generator, pat <- rhs
tcLcStmt TyCon
m_tc HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
 = do   { Mult
pat_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
          -- About the next `tcScalingUsage ManyTy` and unrestricted
          -- see Note [Binding in list comprehension isn't linear]
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'   <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs (TyCon -> [Mult] -> Mult
mkTyConApp TyCon
m_tc [Mult
pat_ty])
        ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing)  <- HsMatchContextRn
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
                            Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', thing
thing) }

-- A boolean guard
tcLcStmt TyCon
_ HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do  { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'  <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
boolTy
        ; thing
thing <- Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
boolTy GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

-- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions]
tcLcStmt TyCon
m_tc HsStmtContextRn
ctxt (ParStmt XParStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = Mult
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
 -> TcM
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$ -- parallel list comprehension never desugars to something linear.
    do  { LocalRdrEnv
env <- RnM LocalRdrEnv
getLocalRdrEnv
        ; ([ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) <- LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcRn GhcRn]
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
loop LocalRdrEnv
env [] [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
unitTy [ParStmtBlock GhcTc GhcTc]
pairs' HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
  where
    -- loop :: LocalRdrEnv -- The original LocalRdrEnv
    --      -> [Name]      -- Variables bound by earlier branches
    --      -> [([LStmt GhcRn], [GhcRn])]
    --      -> TcM ([([LStmt GhcTc], [GhcTc])], thing)
    --
    -- Invariant: on entry to `loop`, the LocalRdrEnv is set to
    --            origEnv, the LocalRdrEnv for the entire comprehension
    loop :: LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcRn GhcRn]
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
loop LocalRdrEnv
_ [Name]
allBinds [] = do { thing
thing <- [Name] -> TcM thing -> TcM thing
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
allBinds (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
                            ; ([ParStmtBlock GhcTc GhcTc], thing)
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }   -- matching in the branches

    loop LocalRdrEnv
origEnv [Name]
priorBinds (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
_ : [ParStmtBlock GhcRn GhcRn]
pairs)
      = do { ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', ([Id]
ids, [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing))
                <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
elt_ty ((ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       ([Id], [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
_elt_ty' ->
                   do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
                      ; ([ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) <- LocalRdrEnv
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
origEnv (RnM ([ParStmtBlock GhcTc GhcTc], thing)
 -> RnM ([ParStmtBlock GhcTc GhcTc], thing))
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
forall a b. (a -> b) -> a -> b
$
                          LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcRn GhcRn]
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
loop LocalRdrEnv
origEnv ([IdP GhcRn]
[Name]
names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
priorBinds) [ParStmtBlock GhcRn GhcRn]
pairs
                      ; ([Id], [ParStmtBlock GhcTc GhcTc], thing)
-> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
           ; ([ParStmtBlock GhcTc GhcTc], thing)
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XParStmtBlock GhcTc GhcTc
-> [GuardLStmt GhcTc]
-> [IdP GhcTc]
-> SyntaxExpr GhcTc
-> ParStmtBlock GhcTc GhcTc
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' [IdP GhcTc]
[Id]
ids SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr ParStmtBlock GhcTc GhcTc
-> [ParStmtBlock GhcTc GhcTc] -> [ParStmtBlock GhcTc GhcTc]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing ) }

tcLcStmt TyCon
m_tc HsStmtContextRn
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
  = Mult
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
 -> TcM
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$ -- Transform statements are too complex: just make everything multiplicity Many
    do { let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
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
ppr [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap)
             -- The inner 'stmts' lack a LastStmt, so the element type
             --  passed in to tcStmtsAndThen is never looked at
       ; ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
by'))
            <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
    -> TcM ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsStmtContext fn
TransStmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
unused_ty ((ExpRhoType
  -> TcM ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))))
-> (ExpRhoType
    -> TcM ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
_ -> do
               { Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
by' <- (GenLocated SrcSpanAnnA (HsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
tcInferRho Maybe (LHsExpr GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by
               ; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names
               ; ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
-> TcM ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndr_ids, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
by') }

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

             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
             by_arrow :: Mult -> Mult
by_arrow = case Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
by' of
                          Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
Nothing       -> \Mult
ty -> Mult
ty
                          Just (GenLocated SrcSpanAnnA (HsExpr GhcTc)
_,Mult
e_ty) -> \Mult
ty -> (Mult
alphaTy HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
e_ty) HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
ty

             tup_ty :: Mult
tup_ty        = [Id] -> Mult
HasDebugCallStack => [Id] -> Mult
mkBigCoreVarTupTy [Id]
bndr_ids
             poly_arg_ty :: Mult
poly_arg_ty   = Mult -> Mult
m_app Mult
alphaTy
             poly_res_ty :: Mult
poly_res_ty   = Mult -> Mult
m_app (Mult -> Mult
n_app Mult
alphaTy)
             using_poly_ty :: Mult
using_poly_ty = Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                             Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                             Mult
poly_arg_ty HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
poly_res_ty

       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
using' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
using Mult
using_poly_ty
       ; let final_using :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
final_using = (HsExpr GhcTc -> HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) GenLocated SrcSpanAnnA (HsExpr GhcTc)
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 -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
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 [TransStmt 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)

       ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt { trS_stmts :: [GuardLStmt GhcTc]
trS_stmts = [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(IdP GhcTc, IdP GhcTc)]
[(Id, Id)]
bindersMap'
                           , trS_by :: Maybe (LHsExpr GhcTc)
trS_by = ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
by', trS_using :: LHsExpr GhcTc
trS_using = LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
final_using
                           , trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
                           , trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
                           , trS_fmap :: HsExpr GhcTc
trS_fmap = HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                           , trS_ext :: XTransStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
trS_ext = XTransStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
unitTy
                           , trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }

tcLcStmt TyCon
_ HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String
-> SDoc
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)


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

tcMcStmt :: TcExprStmtChecker

tcMcStmt :: TcStmtChecker HsExpr ExpRhoType
tcMcStmt HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
return_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  { (GenLocated SrcSpanAnnA (HsExpr GhcTc)
body', SyntaxExprTc
return_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> IOEnv
       (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
a_ty] [Mult
mult]->
               Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Mult
a_ty
        ; thing
thing      <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcMcStmt: thing_inside")
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
SyntaxExprTc
return_op', thing
thing) }

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

tcMcStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbsrn LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
  = do  { ((Mult
rhs_ty, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing, Mult
new_res_ty), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> TcM
         (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
          GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
     ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
       GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbsrn)
                          [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> TcM
       (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
        GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
 -> TcM
      ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
        GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
       SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> TcM
         (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
          GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
     ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
       GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult, Mult
pat_mult] ->
               do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
                  ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- Mult
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
 -> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing))
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) LPat GhcRn
pat (Mult -> Mult -> Scaled Mult
forall a. Mult -> a -> Scaled a
Scaled Mult
pat_mult Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
                                     ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                  ; (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
 GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult)
-> TcM
     (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
      GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
rhs_ty, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing, Mult
new_res_ty) }

        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> FixedRuntimeRepContext
FRRBindStmt StmtOrigin
MonadComprehension) Mult
rhs_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 a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
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)
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
MCompPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty

        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
                , xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
                , xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
                , xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
                }
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbstc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', thing
thing) }

-- Boolean expressions.
--
--   [ body | stmts, expr ]  ->  expr :: m Bool
--
tcMcStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr 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, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, Mult
test_ty, SyntaxExprTc
guard_op'), SyntaxExprTc
then_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> TcM
         (thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
          SyntaxExprTc))
-> TcM
     ((thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
       SyntaxExprTc),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> TcM
       (thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
        SyntaxExprTc))
 -> TcM
      ((thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
        SyntaxExprTc),
       SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> TcM
         (thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
          SyntaxExprTc))
-> TcM
     ((thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
       SyntaxExprTc),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult] ->
               do { ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
test_ty), SyntaxExprTc
guard_op')
                      <- Mult
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
 -> TcM
      ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                         CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
guard_op [SyntaxOpType
SynAny]
                                    (Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty) (([Mult]
  -> [Mult]
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
 -> TcM
      ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                         \ [Mult
test_ty] [Mult
test_mult] -> do
                           GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
test_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
test_ty
                           (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult))
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult)
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
test_ty)
                  ; thing
thing <- Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                  ; (thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
 SyntaxExprTc)
-> TcM
     (thing, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, Mult,
      SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, Mult
test_ty, SyntaxExprTc
guard_op') }

        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRBodyStmtGuard Mult
test_ty
        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> VisArity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
MonadComprehension VisArity
1) Mult
rhs_ty
        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> VisArity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
MonadComprehension VisArity
2) Mult
new_res_ty

        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
rhs_ty GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
SyntaxExprTc
then_op' SyntaxExpr GhcTc
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 HsStmtContextRn
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 { Mult
m1_ty   <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
       ; Mult
m2_ty   <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
       ; Mult
tup_ty  <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
       ; Mult
by_e_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind  -- The type of the 'by' expression (if any)

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

             poly_arg_ty :: Mult
poly_arg_ty  = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy
             using_arg_ty :: Mult
using_arg_ty = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tup_ty
             poly_res_ty :: Mult
poly_res_ty  = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
alphaTy
             using_res_ty :: Mult
using_res_ty = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
tup_ty
             using_poly_ty :: Mult
using_poly_ty = Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                             Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                             Mult
poly_arg_ty HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
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 [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap
       ; ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
by', SyntaxExprTc
return_op')) <-
            HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
    -> TcM
         ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
          SyntaxExprTc))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
       SyntaxExprTc))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsStmtContext fn
TransStmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts
                           (Mult -> ExpRhoType
mkCheckExpType Mult
using_arg_ty) ((ExpRhoType
  -> TcM
       ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
        SyntaxExprTc))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
        SyntaxExprTc)))
-> (ExpRhoType
    -> TcM
         ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
          SyntaxExprTc))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
       SyntaxExprTc))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
res_ty' -> do
                { Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
by' <- case Maybe (LHsExpr GhcRn)
by of
                           Maybe (LHsExpr GhcRn)
Nothing -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. Maybe a
Nothing
                           Just LHsExpr GhcRn
e  -> do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
e' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
e Mult
by_e_ty
                                         ; Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnA (HsExpr GhcTc)
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
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op
                                       [Mult -> SyntaxOpType
synKnownType ([Id] -> Mult
HasDebugCallStack => [Id] -> Mult
mkBigCoreVarTupTy [Id]
bndr_ids)]
                                       ExpRhoType
res_ty' (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                ; ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)), SyntaxExprTc)
-> TcM
     ([Id], Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)), SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndr_ids, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
by', SyntaxExprTc
return_op') }

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

       --------------- Typecheck the 'fmap' function -------------
       ; HsExpr GhcTc
fmap_op' <- case TransForm
form of
                       TransForm
ThenForm -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
                       TransForm
_ -> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (IOEnv
   (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> TcM (HsExpr GhcTc))
-> (Mult
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Mult
-> TcM (HsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcRn
fmap_op) (Mult -> TcM (HsExpr GhcTc)) -> Mult -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                            Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                            Id -> Mult -> Mult
mkInfForAllTy Id
betaTyVar  (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                            (Mult
alphaTy HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
betaTy)
                            HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
alphaTy)
                            HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
betaTy)

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

       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
using' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
using Mult
using_poly_ty
       ; let final_using :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
final_using = (HsExpr GhcTc -> HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) GenLocated SrcSpanAnnA (HsExpr GhcTc)
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 -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
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 [TransStmt binder map] in GHC.Hs.Expr
             n_bndr_ids :: [Id]
n_bndr_ids = String -> (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c.
HasDebugCallStack =>
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 (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)

       ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt { trS_stmts :: [GuardLStmt GhcTc]
trS_stmts = [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(IdP GhcTc, IdP GhcTc)]
[(Id, Id)]
bindersMap'
                           , trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (LHsExpr GhcTc)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
by', trS_using :: LHsExpr GhcTc
trS_using = LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
final_using
                           , trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExpr GhcTc
SyntaxExprTc
return_op', trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
                           , trS_ext :: XTransStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
trS_ext = Mult -> Mult
n_app Mult
tup_ty
                           , trS_fmap :: HsExpr GhcTc
trS_fmap = HsExpr GhcTc
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 HsStmtContextRn
ctxt (ParStmt XParStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
mzip_op SyntaxExpr GhcRn
bind_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do { Mult
m_ty   <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind

       ; let mzip_ty :: Mult
mzip_ty  = [Id] -> Mult -> Mult
mkInfForAllTys [Id
alphaTyVar, Id
betaTyVar] (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy)
                        HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
betaTy)
                        HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` [Mult] -> Mult
mkBoxedTupleTy [Mult
alphaTy, Mult
betaTy])
       ; HsExpr GhcTc
mzip_op' <- GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcRn
mzip_op) Mult
mzip_ty

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

       -- Typecheck bind:
       ; let tup_tys :: [Mult]
tup_tys  = [ [Mult] -> Mult
HasDebugCallStack => [Mult] -> Mult
mkBigCoreTupTy [Mult]
id_tys | [Mult]
id_tys <- [[Mult]]
id_tys_s ]
             tuple_ty :: Mult
tuple_ty = [Mult] -> Mult
forall {t :: * -> *}. Foldable t => t Mult -> Mult
mk_tuple_ty [Mult]
tup_tys

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

       ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
inner_res_ty [ParStmtBlock GhcTc GhcTc]
blocks' HsExpr GhcTc
mzip_op' SyntaxExpr GhcTc
SyntaxExprTc
bind_op', thing
thing) }

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

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

    loop Mult
m_ty ExpRhoType
inner_res_ty (Mult
tup_ty_in : [Mult]
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 :: Mult
m_tup_ty = Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tup_ty_in
           ; ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing))
                <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
    -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
m_tup_ty) ((ExpRhoType
  -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType
    -> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$
                   \ExpRhoType
m_tup_ty' ->
                   do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
                      ; let tup_ty :: Mult
tup_ty = [Id] -> Mult
HasDebugCallStack => [Id] -> Mult
mkBigCoreVarTupTy [Id]
ids
                      ; (()
_, SyntaxExprTc
return_op') <-
                          CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op
                                     [Mult -> SyntaxOpType
synKnownType Mult
tup_ty] ExpRhoType
m_tup_ty' (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                                     \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      ; ([ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) <- Mult
-> ExpRhoType
-> [Mult]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop Mult
m_ty ExpRhoType
inner_res_ty [Mult]
tup_tys_in [ParStmtBlock GhcRn GhcRn]
pairs
                      ; ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
           ; ([ParStmtBlock GhcTc GhcTc], thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmtBlock GhcTc GhcTc
-> [GuardLStmt GhcTc]
-> [IdP GhcTc]
-> SyntaxExpr GhcTc
-> ParStmtBlock GhcTc GhcTc
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' [IdP GhcTc]
[Id]
ids SyntaxExpr GhcTc
SyntaxExprTc
return_op' ParStmtBlock GhcTc GhcTc
-> [ParStmtBlock GhcTc GhcTc] -> [ParStmtBlock GhcTc GhcTc]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
    loop Mult
_ ExpRhoType
_ [Mult]
_ [ParStmtBlock GhcRn GhcRn]
_ = String
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. HasCallStack => String -> a
panic String
"tcMcStmt.loop"

tcMcStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String
-> SDoc
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)


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

tcDoStmt :: TcExprStmtChecker

tcDoStmt :: TcStmtChecker HsExpr ExpRhoType
tcDoStmt HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body ExpRhoType
res_ty
       ; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcDoStmt: thing_inside")
       ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcDoStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbsrn LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do  {       -- Deal with rebindable syntax:
                --       (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
                -- This level of generality is needed for using do-notation
                -- in full generality; see #1537

          ((Mult
rhs_ty, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> TcM
         (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
          GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
     ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
       GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbsrn) [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> TcM
       (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
        GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
 -> TcM
      ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
        GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
       SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> TcM
         (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
          GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
     ((Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
       GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                \ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult,Mult
pat_mult] ->
                do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <-Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
                   ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- Mult
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
 -> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing))
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) LPat GhcRn
pat (Mult -> Mult -> Scaled Mult
forall a. Mult -> a -> Scaled a
Scaled Mult
pat_mult Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
                                      ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                   ; (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
 GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing)
-> TcM
     (Mult, GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult,
      GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
rhs_ty, GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing) }

        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> FixedRuntimeRepContext
FRRBindStmt StmtOrigin
DoNotation) Mult
rhs_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 a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
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)
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty
        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
                , xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
                , xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
                , xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
                }
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbstc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', thing
thing) }

tcDoStmt HsStmtContextRn
ctxt (ApplicativeStmt XApplicativeStmt
  GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts ExpRhoType
ty = HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall t.
HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContextRn
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
ty ((Mult -> TcM thing)
 -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$
                                ExpRhoType -> TcM thing
thing_inside (ExpRhoType -> TcM thing)
-> (Mult -> ExpRhoType) -> Mult -> TcM thing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mult -> ExpRhoType
mkCheckExpType
        ; (([(SyntaxExprTc, ApplicativeArg GhcTc)]
pairs', Mult
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 GhcTc)], Mult, thing)
 -> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
     Maybe SyntaxExprTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
      Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts ExpRhoType
res_ty
            Just SyntaxExpr GhcRn
join_op ->
              (SyntaxExprTc -> Maybe SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
    SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
    Maybe SyntaxExprTc)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just ((([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
  SyntaxExprTc)
 -> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
     Maybe SyntaxExprTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
      SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
      Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
join_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       ([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
       SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
rhs_ty] [Mult
rhs_mult] -> Mult
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
 -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$ ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts (Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty))

        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeStmt
  GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
-> FailOperator GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt XApplicativeStmt
  GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
pairs' FailOperator GhcTc
Maybe SyntaxExprTc
mb_join', thing
thing) }
tcDoStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr 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
        ; ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, thing
thing), SyntaxExprTc
then_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
    -> [Mult]
    -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing),
      SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
  -> [Mult]
  -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing))
 -> TcM
      ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing),
       SyntaxExprTc))
-> ([Mult]
    -> [Mult]
    -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing),
      SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult] ->
               do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
                  ; thing
thing <- Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                  ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), Mult, Mult, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, thing
thing) }
        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> VisArity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
DoNotation VisArity
1) Mult
rhs_ty
        ; HasDebugCallStack => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> VisArity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
DoNotation VisArity
2) Mult
new_res_ty
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Mult
rhs_ty GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
SyntaxExprTc
then_op' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcDoStmt HsStmtContextRn
ctxt (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 = [IdP GhcRn]
[Name]
rec_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcRn -> [IdP GhcRn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcRn]
rec_names) [IdP GhcRn]
[Name]
later_names
        ; [Mult]
tup_elt_tys <- VisArity -> Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
newFlexiTyVarTys ([Name] -> VisArity
forall a. [a] -> VisArity
forall (t :: * -> *) a. Foldable t => t a -> VisArity
length [Name]
tup_names) Mult
liftedTypeKind
        ; let tup_ids :: [Id]
tup_ids = (Name -> Mult -> Id) -> [Name] -> [Mult] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Mult
t -> HasDebugCallStack => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n Mult
ManyTy Mult
t) [Name]
tup_names [Mult]
tup_elt_tys
                -- Many because it's a recursive definition
              tup_ty :: Mult
tup_ty  = [Mult] -> Mult
HasDebugCallStack => [Mult] -> Mult
mkBigCoreTupTy [Mult]
tup_elt_tys

        ; [Id]
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
tup_ids (TcM
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
 -> TcM
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)),
       thing))
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$ do
        { (([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', (SyntaxExprTc
ret_op', [HsExpr GhcTc]
tup_rets)), Mult
stmts_ty)
                <- (ExpRhoType
 -> TcM
      ([GenLocated
          SrcSpanAnnA
          (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
       (SyntaxExprTc, [HsExpr GhcTc])))
-> TcM
     (([GenLocated
          SrcSpanAnnA
          (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
       (SyntaxExprTc, [HsExpr GhcTc])),
      Mult)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Mult)
tcInfer ((ExpRhoType
  -> TcM
       ([GenLocated
           SrcSpanAnnA
           (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
        (SyntaxExprTc, [HsExpr GhcTc])))
 -> TcM
      (([GenLocated
           SrcSpanAnnA
           (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
        (SyntaxExprTc, [HsExpr GhcTc])),
       Mult))
-> (ExpRhoType
    -> TcM
         ([GenLocated
             SrcSpanAnnA
             (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
          (SyntaxExprTc, [HsExpr GhcTc])))
-> TcM
     (([GenLocated
          SrcSpanAnnA
          (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
       (SyntaxExprTc, [HsExpr GhcTc])),
      Mult)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
                   HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      (SyntaxExprTc, [HsExpr GhcTc]))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
[GenLocated
   SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts ExpRhoType
exp_ty ((ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       (SyntaxExprTc, [HsExpr GhcTc])))
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      (SyntaxExprTc, [HsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
inner_res_ty ->
                   do { [HsExpr GhcTc]
tup_rets <- (Name -> ExpRhoType -> TcM (HsExpr GhcTc))
-> [Name]
-> [ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExpr GhcTc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId [Name]
tup_names
                                      ((Mult -> ExpRhoType) -> [Mult] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map Mult -> ExpRhoType
mkCheckExpType [Mult]
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
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
ret_op [Mult -> SyntaxOpType
synKnownType Mult
tup_ty]
                                        ExpRhoType
inner_res_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      ; (SyntaxExprTc, [HsExpr GhcTc])
-> TcM (SyntaxExprTc, [HsExpr GhcTc])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExprTc
ret_op', [HsExpr GhcTc]
tup_rets) }

        ; ((()
_, SyntaxExprTc
mfix_op'), Mult
mfix_res_ty)
            <- (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), Mult)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Mult)
tcInfer ((ExpRhoType -> TcM ((), SyntaxExprTc))
 -> TcM (((), SyntaxExprTc), Mult))
-> (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), Mult)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
               CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
mfix_op
                          [Mult -> SyntaxOpType
synKnownType (HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
mkVisFunTyMany Mult
tup_ty Mult
stmts_ty)] ExpRhoType
exp_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        ; ((thing
thing, Mult
new_res_ty), SyntaxExprTc
bind_op')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM (thing, Mult))
-> TcM ((thing, Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
bind_op
                          [ Mult -> SyntaxOpType
synKnownType Mult
mfix_res_ty
                          , SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (Mult -> SyntaxOpType
synKnownType Mult
tup_ty) SyntaxOpType
SynRho ]
                          ExpRhoType
res_ty (([Mult] -> [Mult] -> TcM (thing, Mult))
 -> TcM ((thing, Mult), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcM (thing, Mult))
-> TcM ((thing, Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \ [Mult
new_res_ty] [Mult]
_ ->
               do { thing
thing <- ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                  ; (thing, Mult) -> TcM (thing, Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, Mult
new_res_ty) }

        ; let rec_ids :: [Id]
rec_ids = [Name] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
takeList [IdP GhcRn]
[Name]
rec_names [Id]
tup_ids
        ; [Id]
later_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
later_names
        ; String -> SDoc -> TcRn ()
traceTc String
"tcdo" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [[Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rec_ids SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Mult] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Id -> Mult) -> [Id] -> [Mult]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
rec_ids),
                                 [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
later_ids SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Mult] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Id -> Mult) -> [Id] -> [Mult]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
later_ids)]
        ; (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecStmt { recS_stmts :: XRec GhcTc [LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
recS_stmts = SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', recS_later_ids :: [IdP GhcTc]
recS_later_ids = [IdP GhcTc]
[Id]
later_ids
                          , recS_rec_ids :: [IdP GhcTc]
recS_rec_ids = [IdP GhcTc]
[Id]
rec_ids, recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExpr GhcTc
SyntaxExprTc
ret_op'
                          , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExpr GhcTc
SyntaxExprTc
mfix_op', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
                          , recS_ext :: XRecStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
recS_ext = RecStmtTc
                            { recS_bind_ty :: Mult
recS_bind_ty = Mult
new_res_ty
                            , recS_later_rets :: [HsExpr GhcTc]
recS_later_rets = []
                            , recS_rec_rets :: [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
tup_rets
                            , recS_ret_ty :: Mult
recS_ret_ty = Mult
stmts_ty} }, thing
thing)
        }}

tcDoStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = String
-> SDoc
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr 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".

tcMonadFailOp :: CtOrigin
              -> LPat GhcTc
              -> SyntaxExpr GhcRn    -- The fail op
              -> TcType              -- Type of the whole do-expression
              -> TcRn (FailOperator GhcTc)  -- 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 GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp CtOrigin
orig LPat GhcTc
pat SyntaxExpr GhcRn
fail_op Mult
res_ty = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    if DynFlags -> LPat GhcTc -> Bool
forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcTc
pat
      then Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
      else 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
<$> (CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
SyntaxExprRn
fail_op [Mult -> SyntaxOpType
synKnownType Mult
stringTy]
                            (Mult -> ExpRhoType
mkCheckExpType Mult
res_ty) (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

{-
Note [Treat rebindable syntax first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typechecking
        do { bar; ... } :: IO ()
we want to typecheck 'bar' in the knowledge that it should be an IO thing,
pushing info from the context into the RHS.  To do this, we check the
rebindable syntax first, and push that information into (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

Note [Scoping in parallel list comprehensions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a parallel list comprehension like [ ebody | a <- blah1; e1 | b <- blah2; e2 ]
we want to ensure that in the lexical environment, tcl_rdr :: LocalRdrEnv, we have
  * 'a' in scope in e1, but not 'b'
  * 'b' in scope in e2, but not 'a'
  * Both in scope in ebody
We don't want too /many/ variables in the LocalRdrEnv, else we make stupid
suggestions for an out-of-scope variable (#22940).

To achieve this we:
  * At the start of each branch, reset the LocalRdrEnv to the outer scope.
  * Before typechecking ebody, add to LocalRdrEnv all the variables bound in
    all branches. This step is done with bindLocalNames.
-}

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

tcApplicativeStmts :: forall t.
HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContextRn
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
rhs_ty Mult -> TcM t
thing_inside
 = do { Mult
body_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
      ; let arity :: VisArity
arity = [(SyntaxExprRn, ApplicativeArg GhcRn)] -> VisArity
forall a. [a] -> VisArity
forall (t :: * -> *) a. Foldable t => t a -> VisArity
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
      ; [ExpRhoType]
ts <- VisArity
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType]
forall (m :: * -> *) a. Applicative m => VisArity -> m a -> m [a]
replicateM (VisArity
arityVisArity -> VisArity -> VisArity
forall a. Num a => a -> a -> a
-VisArity
1) (IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
 -> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType])
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType]
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
newInferExpType
      ; [Mult]
exp_tys <- VisArity -> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall (m :: * -> *) a. Applicative m => VisArity -> m a -> m [a]
replicateM VisArity
arity (TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall a b. (a -> b) -> a -> b
$ Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
      ; [Mult]
pat_tys <- VisArity -> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall (m :: * -> *) a. Applicative m => VisArity -> m a -> m [a]
replicateM VisArity
arity (TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall a b. (a -> b) -> a -> b
$ Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
      ; let fun_ty :: Mult
fun_ty = [Mult] -> Mult -> Mult
mkVisFunTysMany [Mult]
pat_tys Mult
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' <- Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
fun_ty ([SyntaxExprRn]
-> [ExpRhoType] -> [Mult] -> [(SyntaxExprRn, ExpRhoType, Mult)]
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]) [Mult]
exp_tys)

      -- Typecheck each ApplicativeArg separately
      -- See Note [ApplicativeDo and constraints]
      ; [ApplicativeArg GhcTc]
args' <- ((ApplicativeArg GhcRn, Mult, Mult)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> [(ApplicativeArg GhcRn, Mult, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [ApplicativeArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Mult
-> (ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
goArg Mult
body_ty) ([ApplicativeArg GhcRn]
-> [Mult] -> [Mult] -> [(ApplicativeArg GhcRn, Mult, Mult)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ApplicativeArg GhcRn]
args [Mult]
pat_tys [Mult]
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 GhcTc -> [Id]) -> [ApplicativeArg GhcTc] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ApplicativeArg GhcTc -> [Id]
get_arg_bndrs [ApplicativeArg GhcTc]
args') (TcM t -> TcM t) -> TcM t -> TcM t
forall a b. (a -> b) -> a -> b
$
               Mult -> TcM t
thing_inside Mult
body_ty

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

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

    goArg :: Mult
-> (ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
goArg Mult
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 :: Bool
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
..
                    }, Mult
pat_ty, Mult
exp_ty)
      = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat) (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
        SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) fn body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable fn,
 Outputable body,
 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext fn -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt (LPat GhcRn
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (bodyR :: * -> *).
LPat GhcRn
-> LocatedA (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
mkRnBindStmt LPat GhcRn
pat LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs))   (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
        do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'      <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
rhs Mult
exp_ty
           ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', ()
_) <- HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcRn () -> TcM (LPat GhcTc, ())
forall a.
HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcRn () -> TcM (LPat GhcTc, ()))
-> TcRn () -> TcM (LPat GhcTc, ())
forall a b. (a -> b) -> a -> b
$
                          () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
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)
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 GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
body_ty

           ; ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
                      { xarg_app_arg_one :: XApplicativeArgOne GhcTc
xarg_app_arg_one = Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
fail_op'
                      , app_arg_pattern :: LPat GhcTc
app_arg_pattern = LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat'
                      , arg_expr :: LHsExpr GhcTc
arg_expr        = LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
                      , Bool
is_body_stmt :: Bool
is_body_stmt :: Bool
.. }
                    ) }

    goArg Mult
_body_ty (ApplicativeArgMany XApplicativeArgMany GhcRn
x [GuardLStmt GhcRn]
stmts HsExpr GhcRn
ret LPat GhcRn
pat HsDoFlavour
ctxt, Mult
pat_ty, Mult
exp_ty)
      = do { ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts', (HsExpr GhcTc
ret',GenLocated SrcSpanAnnA (Pat GhcTc)
pat')) <-
                HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
    -> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM
     (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
exp_ty) ((ExpRhoType
  -> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
 -> TcM
      ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
       (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))))
-> (ExpRhoType
    -> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
     ([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))],
      (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$
                \ExpRhoType
res_ty  -> do
                  { HsExpr GhcTc
ret'      <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
ret ExpRhoType
res_ty
                  ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', ()
_) <- HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcRn () -> TcM (LPat GhcTc, ())
forall a.
HsMatchContextRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsMatchContext fn
StmtCtxt (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt)) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcRn () -> TcM (LPat GhcTc, ()))
-> TcRn () -> TcM (LPat GhcTc, ())
forall a b. (a -> b) -> a -> b
$
                                 () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  ; (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
ret', GenLocated SrcSpanAnnA (Pat GhcTc)
pat')
                  }
           ; ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeArgMany GhcTc
-> [GuardLStmt GhcTc]
-> HsExpr GhcTc
-> LPat GhcTc
-> HsDoFlavour
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsDoFlavour
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcRn
XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts' HsExpr GhcTc
ret' LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' HsDoFlavour
ctxt) }

    get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
    get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcTc
pat }) = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat
    get_arg_bndrs (ApplicativeArgMany { bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern =  LPat GhcTc
pat })    = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
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}
*                                                                      *
************************************************************************
-}

-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-- number of /required/ args are used in each equation.
-- Returns the arity, the number of required args
-- E.g.  f @a True  y = ...
--       f    False z = ...
--       The MatchGroup for `f` has arity 2, not 3
checkArgCounts :: AnnoBody body
               => MatchGroup GhcRn (LocatedA (body GhcRn))
               -> TcM VisArity
checkArgCounts :: forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [] })
    = VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
1 -- See Note [Empty MatchGroups] in GHC.Rename.Bind
               --   case e of {} or \case {}
               -- Both have arity 1

checkArgCounts (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1:[LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches) })
    | [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches  -- There was only one match; nothing to check
    = VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
n_args1

    -- Two or more matches: check that they agree on arity
    | Just NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches <- Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches
    = TcRnMessage -> TcM VisArity
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM VisArity) -> TcRnMessage -> TcM VisArity
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> MatchArgBadMatches -> TcRnMessage
TcRnMatchesHaveDiffNumArgs (Match GhcRn (LocatedA (body GhcRn))
-> HsMatchContext (LIdP (NoGhcTc GhcRn))
forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> Match GhcRn (LocatedA (body GhcRn))
forall l e. GenLocated l e -> e
unLoc LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1))
                 (MatchArgBadMatches -> TcRnMessage)
-> MatchArgBadMatches -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
-> MatchArgBadMatches
forall body.
LocatedA (Match GhcRn body)
-> NonEmpty (LocatedA (Match GhcRn body)) -> MatchArgBadMatches
MatchArgMatches LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1 NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches
    | Bool
otherwise
    = VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
n_args1
  where
    n_args1 :: VisArity
n_args1 = LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> VisArity
forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1
    mb_bad_matches :: Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches = [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> Maybe
     (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m | LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m <- [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches, LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> VisArity
forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m VisArity -> VisArity -> Bool
forall a. Eq a => a -> a -> Bool
/= VisArity
n_args1]

    reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity
    -- Counts the number of /required/ args in the match
    reqd_args_in_match :: forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })) = (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)] -> VisArity
forall a. (a -> Bool) -> [a] -> VisArity
count (Pat GhcRn -> Bool
forall p. Pat p -> Bool
isVisArgPat (Pat GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc) [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats