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

{-# 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
   ( tcMatchesFun
   , tcGRHS
   , tcGRHSsPat
   , tcMatchesCase
   , tcMatchLambda
   , TcMatchCtxt(..)
   , TcStmtChecker
   , TcExprStmtChecker
   , TcCmdStmtChecker
   , tcStmts
   , tcStmtsAndThen
   , tcDoStmts
   , tcBody
   , tcDoStmt
   , tcGuardStmt
   )
where

import GHC.Prelude

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

import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
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.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 tybes 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.Session ( getDynFlags )

import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc

import Control.Monad
import Control.Arrow ( second )

#include "HsVersions.h"

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

@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
@FunMonoBind@.  The second argument is the name of the function, which
is used in error messages.  It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.
-}

tcMatchesFun :: LocatedN Name
             -> MatchGroup GhcRn (LHsExpr GhcRn)
             -> ExpRhoType    -- Expected type of function
             -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
                                -- Returns type of body
tcMatchesFun :: GenLocated SrcSpanAnnN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun fn :: GenLocated SrcSpanAnnN Name
fn@(L SrcSpanAnnN
_ Name
fun_name) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
exp_ty
  = do  {  -- Check that they all have the same no of arguments
           -- Location is in the monad, set the caller so that
           -- any inter-equation error messages get some vaguely
           -- sensible location.        Note: we have to do this odd
           -- ann-grabbing, because we don't always have annotations in
           -- hand when we call tcMatchesFun...
          String -> SDoc -> TcRn ()
traceTc String
"tcMatchesFun" (forall a. Outputable a => a -> SDoc
ppr Name
fun_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_ty)
        ; forall (body :: * -> *).
AnnoBody body =>
Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcRn ()
checkArgs Name
fun_name MatchGroup GhcRn (LHsExpr GhcRn)
matches

        ; forall a.
SDoc
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys SDoc
herald UserTypeCtxt
ctxt Arity
arity ExpRhoType
exp_ty forall a b. (a -> b) -> a -> b
$ \ [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty ->
             -- NB: exp_type may be polymorphic, but
             --     matchExpectedFunTys can cope with that
          forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
Many forall a b. (a -> b) -> a -> b
$
          -- toplevel bindings and let bindings are, at the
          -- moment, always unrestricted. The value being bound
          -- must, accordingly, be unrestricted. Hence them
          -- being scaled by Many. When let binders come with a
          -- multiplicity, then @tcMatchesFun@ will have to take
          -- a multiplicity argument, and scale accordingly.
          forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
matches }
  where
    arity :: Arity
arity  = forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
matches
    herald :: SDoc
herald = String -> SDoc
text String
"The equation(s) for"
             SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
fun_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"have"
    ctxt :: UserTypeCtxt
ctxt   = UserTypeCtxt
GenSigCtxt  -- Was: FunSigCtxt fun_name True
                         -- But that's wrong for f :: Int -> forall a. blah
    what :: HsMatchContext GhcRn
what   = FunRhs { mc_fun :: LIdP GhcRn
mc_fun = GenLocated SrcSpanAnnN Name
fn, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
what, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
    strictness :: SrcStrictness
strictness
      | [L Anno (Match GhcRn (LocatedA (HsExpr GhcRn)))
_ Match GhcRn (LocatedA (HsExpr GhcRn))
match] <- forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts MatchGroup GhcRn (LHsExpr GhcRn)
matches
      , FunRhs{ mc_strictness :: forall p. HsMatchContext p -> SrcStrictness
mc_strictness = SrcStrictness
SrcStrict } <- forall p body. Match p body -> HsMatchContext (NoGhcTc p)
m_ctxt Match GhcRn (LocatedA (HsExpr GhcRn))
match
      = SrcStrictness
SrcStrict
      | Bool
otherwise
      = SrcStrictness
NoSrcStrict

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

tcMatchesCase :: (AnnoBody body) =>
                TcMatchCtxt body                         -- Case context
             -> Scaled TcSigmaType                       -- Type of scrutinee
             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives
             -> ExpRhoType                    -- Type of whole case expressions
             -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
                -- Translated alternatives
                -- wrapper goes from MatchGroup's ty to expected ty

tcMatchesCase :: forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled Mult
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatchesCase TcMatchCtxt body
ctxt (Scaled Mult
scrut_mult Mult
scrut_ty) MatchGroup GhcRn (LocatedA (body GhcRn))
matches ExpRhoType
res_ty
  = forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchCtxt body
ctxt [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

tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
              -> TcMatchCtxt HsExpr
              -> MatchGroup GhcRn (LHsExpr GhcRn)
              -> ExpRhoType
              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda :: SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
  = forall a.
SDoc
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys SDoc
herald UserTypeCtxt
GenSigCtxt Arity
n_pats ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$ \ [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty ->
    forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchCtxt HsExpr
match_ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
match
  where
    n_pats :: Arity
n_pats | forall (p :: Pass) body. MatchGroup (GhcPass p) body -> Bool
isEmptyMatchGroup MatchGroup GhcRn (LHsExpr GhcRn)
match = Arity
1   -- must be lambda-case
           | Bool
otherwise               = forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
match

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

tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
           -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-- Used for pattern bindings
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpRhoType
res_ty
  = forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
Many forall a b. (a -> b) -> a -> b
$
      -- Like in tcMatchesFun, this scaling happens because all
      -- let bindings are unrestricted. A difference, here, is
      -- that when this is not the case, any more, we will have to
      -- make sure that the pattern is strict, otherwise this will
      -- desugar to incorrect code.
    forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs TcMatchCtxt HsExpr
match_ctxt GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpRhoType
res_ty
  where
    match_ctxt :: TcMatchCtxt HsExpr -- AZ
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = forall p. HsMatchContext p
PatBindRhs,
                      mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }

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

data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
  = MC { forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is
         forall (body :: * -> *).
TcMatchCtxt body
-> LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of
                                           -- an alternative
                 -> 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))) ~ SrcSpan
    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
    , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
    )

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

tcMatches :: forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchCtxt body
ctxt [Scaled ExpRhoType]
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_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
  | 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Scaled ExpRhoType -> TcM (Scaled Mult)
scaledExpTypeToType [Scaled ExpRhoType]
pat_tys
       ; Mult
rhs_ty  <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
rhs_ty
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l []
                    , mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext = [Scaled Mult] -> Mult -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty
                    , mg_origin :: Origin
mg_origin = Origin
origin }) }

  | Bool
otherwise
  = do { [(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
umatches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchCtxt body
ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty) [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
       ; let ([UsageEnv]
usages,[LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
matches') = forall a b. [(a, b)] -> ([a], [b])
unzip [(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
umatches
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
       ; [Scaled Mult]
pat_tys  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Scaled ExpRhoType -> TcM (Scaled Mult)
readScaledExpType [Scaled ExpRhoType]
pat_tys
       ; Mult
rhs_ty   <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
rhs_ty
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts   = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
matches'
                    , mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext    = [Scaled Mult] -> Mult -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty
                    , mg_origin :: Origin
mg_origin = Origin
origin }) }

-------------
tcMatch :: (AnnoBody body) => TcMatchCtxt body
        -> [Scaled ExpSigmaType]        -- Expected pattern types
        -> ExpRhoType            -- Expected result-type of the Match.
        -> LMatch GhcRn (LocatedA (body GhcRn))
        -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))

tcMatch :: forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchCtxt body
ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty LMatch GhcRn (LocatedA (body GhcRn))
match
  = forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
tc_match TcMatchCtxt body
ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty) LMatch GhcRn (LocatedA (body GhcRn))
match
  where
    tc_match :: TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
tc_match TcMatchCtxt body
ctxt [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty
             match :: Match GhcRn (LocatedA (body GhcRn))
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LocatedA (body GhcRn))
grhss })
      = Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
add_match_ctxt Match GhcRn (LocatedA (body GhcRn))
match forall a b. (a -> b) -> a -> b
$
        do { ([GenLocated SrcSpanAnnA (Pat GhcTc)]
pats', GRHSs GhcTc (LocatedA (body GhcTc))
grhss') <- forall a.
HsMatchContext GhcRn
-> [LPat GhcRn]
-> [Scaled ExpRhoType]
-> TcM a
-> TcM ([LPat GhcTc], a)
tcPats (forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt) [LPat GhcRn]
pats [Scaled ExpRhoType]
pat_tys forall a b. (a -> b) -> a -> b
$
                                forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs TcMatchCtxt body
ctxt GRHSs GhcRn (LocatedA (body GhcRn))
grhss ExpRhoType
rhs_ty
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (Match { m_ext :: XCMatch GhcTc (LocatedA (body GhcTc))
m_ext = forall a. EpAnn a
noAnn
                           , m_ctxt :: HsMatchContext (NoGhcTc GhcTc)
m_ctxt = forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt, m_pats :: [LPat GhcTc]
m_pats = [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats'
                           , m_grhss :: GRHSs GhcTc (LocatedA (body GhcTc))
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
grhss' }) }

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

-------------
tcGRHSs :: AnnoBody body
        => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
        -> TcM (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 =>
TcMatchCtxt body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs TcMatchCtxt body
ctxt (GRHSs XCGRHSs GhcRn (LocatedA (body GhcRn))
_ [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss HsLocalBinds GhcRn
binds) ExpRhoType
res_ty
  = do  { (HsLocalBinds GhcTc
binds', [(UsageEnv, Located (GRHS GhcTc (LocatedA (body GhcTc))))]
ugrhss)
            <- forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds forall a b. (a -> b) -> a -> b
$
               forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt body
ctxt ExpRhoType
res_ty)) [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss
        ; let ([UsageEnv]
usages, [Located (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss') = forall a b. [(a, b)] -> ([a], [b])
unzip [(UsageEnv, Located (GRHS GhcTc (LocatedA (body GhcTc))))]
ugrhss
        ; UsageEnv -> TcRn ()
tcEmitBindingUsage forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [Located (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss' HsLocalBinds GhcTc
binds') }

-------------
tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
       -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))

tcGRHS :: forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt body
ctxt ExpRhoType
res_ty (GRHS XCGRHS GhcRn (LocatedA (body GhcRn))
_ [GuardLStmt GhcRn]
guards LocatedA (body GhcRn)
rhs)
  = do  { ([GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guards', LocatedA (body GhcTc)
rhs')
            <- forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
stmt_ctxt TcExprStmtChecker
tcGuardStmt [GuardLStmt GhcRn]
guards ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
               forall (body :: * -> *).
TcMatchCtxt body
-> LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
mc_body TcMatchCtxt body
ctxt LocatedA (body GhcRn)
rhs
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guards' LocatedA (body GhcTc)
rhs') }
  where
    stmt_ctxt :: HsStmtContext GhcRn
stmt_ctxt  = forall p. HsMatchContext p -> HsStmtContext p
PatGuard (forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcRn
mc_what TcMatchCtxt body
ctxt)

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

tcDoStmts :: HsStmtContext GhcRn
          -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
          -> ExpRhoType
          -> TcM (HsExpr GhcTc)          -- Returns a HsDo
tcDoStmts :: HsStmtContext GhcRn
-> LocatedL [GuardLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext GhcRn
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
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts forall p. HsStmtContext p
ListComp (TyCon -> TcExprStmtChecker
tcLcStmt TyCon
listTyCon) [GuardLStmt GhcRn]
stmts
                            (Mult -> ExpRhoType
mkCheckExpType Mult
elt_ty)
        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionN -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionN
co (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Mult
list_ty forall p. HsStmtContext p
ListComp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }

tcDoStmts doExpr :: HsStmtContext GhcRn
doExpr@(DoExpr Maybe ModuleName
_) (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContext GhcRn
doExpr TcExprStmtChecker
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Mult
res_ty HsStmtContext GhcRn
doExpr (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }

tcDoStmts mDoExpr :: HsStmtContext GhcRn
mDoExpr@(MDoExpr Maybe ModuleName
_) (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContext GhcRn
mDoExpr TcExprStmtChecker
tcDoStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Mult
res_ty HsStmtContext GhcRn
mDoExpr (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }

tcDoStmts HsStmtContext GhcRn
MonadComp (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do  { [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts forall p. HsStmtContext p
MonadComp TcExprStmtChecker
tcMcStmt [GuardLStmt GhcRn]
stmts ExpRhoType
res_ty
        ; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Mult
res_ty forall p. HsStmtContext p
MonadComp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }

tcDoStmts HsStmtContext GhcRn
ctxt LocatedL [GuardLStmt GhcRn]
_ ExpRhoType
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (forall p. (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc
pprStmtContext HsStmtContext GhcRn
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" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
        ; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
body ExpRhoType
res_ty
        }

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

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

type TcStmtChecker body rho_type
  =  forall thing. HsStmtContext GhcRn
                -> 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) => HsStmtContext GhcRn
        -> 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 =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContext GhcRn
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', ()
_) <- forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty forall a b. (a -> b) -> a -> b
$
                        forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ; forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts' }

tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn
               -> 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 =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
_ TcStmtChecker body rho_type
_ [] rho_type
res_ty rho_type -> TcM thing
thing_inside
  = do  { thing
thing <- rho_type -> TcM thing
thing_inside rho_type
res_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }

-- LetStmts are handled uniformly, regardless of context
tcStmtsAndThen HsStmtContext GhcRn
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', ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts',thing
thing)) <- forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds forall a b. (a -> b) -> a -> b
$
              forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty rho_type -> TcM thing
thing_inside
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (LocatedA (body GhcRn))
x HsLocalBinds GhcTc
binds') 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 HsStmtContext GhcRn
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)) <-
             TcStmtChecker body rho_type
stmt_chk HsStmtContext GhcRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
               forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty'  forall a b. (a -> b) -> a -> b
$
                 rho_type -> TcM thing
thing_inside
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' 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)) <-
                forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc                             forall a b. (a -> b) -> a -> b
$
                forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body,
 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext GhcRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt)        forall a b. (a -> b) -> a -> b
$
                TcStmtChecker body rho_type
stmt_chk HsStmtContext GhcRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty                   forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
                forall a. TcM a -> TcM a
popErrCtxt                                  forall a b. (a -> b) -> a -> b
$
                forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty'  forall a b. (a -> b) -> a -> b
$
                rho_type -> TcM thing
thing_inside
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }

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

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

tcGuardStmt HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_ LPat GhcRn
pat LocatedA (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.
          (LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty) <- forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
Many forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
tcInferRhoNC LocatedA (HsExpr GhcRn)
rhs
                                   -- Stmt has a context already
        ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing)  <- forall a.
HsMatchContext GhcRn
-> CtOrigin
-> LPat GhcRn
-> Scaled Mult
-> TcM a
-> TcM (LPat GhcTc, a)
tcCheckPat_O (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LocatedA (HsExpr GhcRn)
rhs)
                                         LPat GhcRn
pat (forall a. a -> Scaled a
unrestricted Mult
rhs_ty) forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
res_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }

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

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

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

-- A generator, pat <- rhs
tcLcStmt TyCon
m_tc HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_ LPat GhcRn
pat LocatedA (HsExpr GhcRn)
rhs) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
 = do   { Mult
pat_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
        ; LocatedA (HsExpr GhcTc)
rhs'   <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LocatedA (HsExpr GhcRn)
rhs (TyCon -> [Mult] -> Mult
mkTyConApp TyCon
m_tc [Mult
pat_ty])
        ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing)  <- forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat (forall a. a -> Scaled a
unrestricted Mult
pat_ty) forall a b. (a -> b) -> a -> b
$
                            ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }

-- A boolean guard
tcLcStmt TyCon
_ HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_ LocatedA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do  { LocatedA (HsExpr GhcTc)
rhs'  <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LocatedA (HsExpr GhcRn)
rhs Mult
boolTy
        ; thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt Mult
boolTy LocatedA (HsExpr GhcTc)
rhs' forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

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

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

tcLcStmt TyCon
m_tc HsStmtContext GhcRn
ctxt (TransStmt { trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form, trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts
                              , trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs =  [(IdP GhcRn, IdP GhcRn)]
bindersMap
                              , trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using }) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
  = do { let ([Name]
bndr_names, [Name]
n_bndr_names) = forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
bindersMap
             unused_ty :: ExpRhoType
unused_ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: inner ty" (forall a. Outputable a => a -> SDoc
ppr [(IdP GhcRn, IdP GhcRn)]
bindersMap)
             -- The inner 'stmts' lack a LastStmt, so the element type
             --  passed in to tcStmtsAndThen is never looked at
       ; ([GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (LocatedA (HsExpr GhcTc), Mult)
by'))
            <- forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcRn
ctxt) (TyCon -> TcExprStmtChecker
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
stmts ExpRhoType
unused_ty forall a b. (a -> b) -> a -> b
$ \ExpRhoType
_ -> do
               { Maybe (LocatedA (HsExpr GhcTc), Mult)
by' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
tcInferRho Maybe (LHsExpr GhcRn)
by
               ; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names
               ; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndr_ids, Maybe (LocatedA (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 (LocatedA (HsExpr GhcTc), Mult)
by' of
                          Maybe (LocatedA (HsExpr GhcTc), Mult)
Nothing       -> \Mult
ty -> Mult
ty
                          Just (LocatedA (HsExpr GhcTc)
_,Mult
e_ty) -> \Mult
ty -> (Mult
alphaTy Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
e_ty) Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
ty

             tup_ty :: Mult
tup_ty        = [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 forall a b. (a -> b) -> a -> b
$
                             Mult -> Mult
by_arrow forall a b. (a -> b) -> a -> b
$
                             Mult
poly_arg_ty Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
poly_res_ty

       ; LocatedA (HsExpr GhcTc)
using' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
using Mult
using_poly_ty
       ; let final_using :: LocatedA (HsExpr GhcTc)
final_using = 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)) LocatedA (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
mkLocalId Name
n_bndr_name Mult
Many (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 [GroupStmt binder map] in GHC.Hs.Expr
             n_bndr_ids :: [Id]
n_bndr_ids  = 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 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 <- forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
n_bndr_ids (ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty)

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

tcLcStmt TyCon
_ HsStmtContext GhcRn
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)


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

tcMcStmt :: TcExprStmtChecker

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

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

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

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; Maybe SyntaxExprTc
fail_op' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (LocatedA (HsExpr GhcRn))
xbsrn) 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) GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExprRn
fail Mult
new_res_ty

        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = 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 = Maybe SyntaxExprTc
fail_op'
                }
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmtTc
xbstc GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }

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

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

-- We type [ body | (stmts, group by e using f), ... ]
--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
--
-- We type the functions as follows:
--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
--
tcMcStmt HsStmtContext GhcRn
ctxt (TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcRn, IdP GhcRn)]
bindersMap
                         , trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using, trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form
                         , trS_ret :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_ret = SyntaxExpr GhcRn
return_op, trS_bind :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_bind = SyntaxExpr GhcRn
bind_op
                         , trS_fmap :: forall idL idR body. StmtLR idL idR body -> HsExpr idR
trS_fmap = HsExpr GhcRn
fmap_op }) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
  = do { 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (\Mult
ty -> Mult
ty)
                    TransForm
_        -> do { Mult
n_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
                                   ; forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
n_ty Mult -> Mult -> Mult
`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 Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
by_e_ty) 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 forall a b. (a -> b) -> a -> b
$
                             Mult -> Mult
by_arrow forall a b. (a -> b) -> a -> b
$
                             Mult
poly_arg_ty 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
bindersMap
       ; ([GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (LocatedA (HsExpr GhcTc))
by', SyntaxExprTc
return_op')) <-
            forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcRn
ctxt) TcExprStmtChecker
tcMcStmt [GuardLStmt GhcRn]
stmts
                           (Mult -> ExpRhoType
mkCheckExpType Mult
using_arg_ty) forall a b. (a -> b) -> a -> b
$ \ExpRhoType
res_ty' -> do
                { Maybe (LocatedA (HsExpr GhcTc))
by' <- case Maybe (LHsExpr GhcRn)
by of
                           Maybe (LHsExpr GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                           Just LHsExpr GhcRn
e  -> do { LocatedA (HsExpr GhcTc)
e' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
e Mult
by_e_ty
                                         ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just LocatedA (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') <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                       [Mult -> SyntaxOpType
synKnownType ([Id] -> Mult
mkBigCoreVarTupTy [Id]
bndr_ids)]
                                       ExpRhoType
res_ty' forall a b. (a -> b) -> a -> b
$ \ [Mult]
_ [Mult]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

                ; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndr_ids, Maybe (LocatedA (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')  <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
bind_op
                             [ Mult -> SyntaxOpType
synKnownType Mult
using_res_ty
                             , Mult -> SyntaxOpType
synKnownType (Mult -> Mult
n_app Mult
tup_ty Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
new_res_ty) ]
                             ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$ \ [Mult]
_ [Mult]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

       ; LocatedA (HsExpr GhcTc)
using' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
using Mult
using_poly_ty
       ; let final_using :: LocatedA (HsExpr GhcTc)
final_using = 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)) LocatedA (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
mkLocalId Name
n_bndr_name Mult
Many (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 [GroupStmt binder map] in GHC.Hs.Expr
             n_bndr_ids :: [Id]
n_bndr_ids = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"tcMcStmt" Name -> Id -> Id
mk_n_bndr [Name]
n_bndr_names [Id]
bndr_ids
             bindersMap' :: [(Id, Id)]
bindersMap' = [Id]
bndr_ids 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 <- forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
n_bndr_ids forall a b. (a -> b) -> a -> b
$
                  ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)

       ; forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt { trS_stmts :: [ExprLStmt GhcTc]
trS_stmts = [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(Id, Id)]
bindersMap'
                           , trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (LocatedA (HsExpr GhcTc))
by', trS_using :: LHsExpr GhcTc
trS_using = LocatedA (HsExpr GhcTc)
final_using
                           , trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExprTc
return_op', trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExprTc
bind_op'
                           , trS_ext :: XTransStmt GhcTc GhcTc (LocatedA (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 HsStmtContext GhcRn
ctxt (ParStmt XParStmt GhcRn GhcRn (LocatedA (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] forall a b. (a -> b) -> a -> b
$
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy)
                        Mult -> Mult -> Mult
`mkVisFunTyMany`
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
betaTy)
                        Mult -> Mult -> Mult
`mkVisFunTyMany`
                        (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` [Mult] -> Mult
mkBoxedTupleTy [Mult
alphaTy, Mult
betaTy])
       ; HsExpr GhcTc
mzip_op' <- forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
mzip_op) Mult
mzip_ty

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

       -- Typecheck bind:
       ; let tup_tys :: [Mult]
tup_tys  = [ [Mult] -> Mult
mkBigCoreTupTy [Mult]
id_tys | [Mult]
id_tys <- [[Mult]]
id_tys_s ]
             tuple_ty :: Mult
tuple_ty = 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')
           <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
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 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
                 ; forall (m :: * -> *) a. Monad m => a -> m a
return (([ParStmtBlock GhcTc GhcTc], thing)
stuff, Mult
inner_res_ty) }

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

  where
    mk_tuple_ty :: t Mult -> Mult
mk_tuple_ty t Mult
tys = 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
                                   ; 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
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing))
                <- forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcRn
ctxt TcExprStmtChecker
tcMcStmt [GuardLStmt GhcRn]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
m_tup_ty) forall a b. (a -> b) -> a -> b
$
                   \ExpRhoType
m_tup_ty' ->
                   do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
names
                      ; let tup_ty :: Mult
tup_ty = [Id] -> Mult
mkBigCoreVarTupTy [Id]
ids
                      ; (()
_, SyntaxExprTc
return_op') <-
                          forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
return_op
                                     [Mult -> SyntaxOpType
synKnownType Mult
tup_ty] ExpRhoType
m_tup_ty' forall a b. (a -> b) -> a -> b
$
                                     \ [Mult]
_ [Mult]
_ -> 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
                      ; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' [Id]
ids SyntaxExprTc
return_op' forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
    loop Mult
_ ExpRhoType
_ [Mult]
_ [ParStmtBlock GhcRn GhcRn]
_ = forall a. String -> a
panic String
"tcMcStmt.loop"

tcMcStmt HsStmtContext GhcRn
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)


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

tcDoStmt :: TcExprStmtChecker

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

tcDoStmt HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
xbsrn LPat GhcRn
pat LocatedA (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

          ((LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing), SyntaxExprTc
bind_op')
            <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
xbsrn) [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty 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 { LocatedA (HsExpr GhcTc)
rhs' <-forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LocatedA (HsExpr GhcRn)
rhs Mult
rhs_ty
                   ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult forall a b. (a -> b) -> a -> b
$ forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat (forall a. Mult -> a -> Scaled a
Scaled Mult
pat_mult Mult
pat_ty) forall a b. (a -> b) -> a -> b
$
                                      ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                   ; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing) }

        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
        ; Maybe SyntaxExprTc
fail_op' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (LocatedA (HsExpr GhcRn))
xbsrn) 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) GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExprRn
fail Mult
new_res_ty
        ; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
                { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = 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 = Maybe SyntaxExprTc
fail_op'
                }
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmtTc
xbstc GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }

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

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

tcDoStmt HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_ LocatedA (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
        ; ((LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, thing
thing), SyntaxExprTc
then_op')
            <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
               \ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult] ->
               do { LocatedA (HsExpr GhcTc)
rhs' <- forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LocatedA (HsExpr GhcRn)
rhs Mult
rhs_ty
                  ; thing
thing <- forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
                  ; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, thing
thing) }
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt Mult
rhs_ty LocatedA (HsExpr GhcTc)
rhs' SyntaxExprTc
then_op' forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcDoStmt HsStmtContext GhcRn
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 (LocatedA (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]
rec_names forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcRn]
rec_names) [IdP GhcRn]
later_names
        ; [Mult]
tup_elt_tys <- Arity -> Mult -> TcM [Mult]
newFlexiTyVarTys (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Name]
tup_names) Mult
liftedTypeKind
        ; let tup_ids :: [Id]
tup_ids = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Mult
t -> HasDebugCallStack => Name -> Mult -> Mult -> Id
mkLocalId Name
n Mult
Many Mult
t) [Name]
tup_names [Mult]
tup_elt_tys
                -- Many because it's a recursive definition
              tup_ty :: Mult
tup_ty  = [Mult] -> Mult
mkBigCoreTupTy [Mult]
tup_elt_tys

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

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

        ; ((thing
thing, Mult
new_res_ty), SyntaxExprTc
bind_op')
            <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
bind_op
                          [ Mult -> SyntaxOpType
synKnownType Mult
mfix_res_ty
                          , SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (Mult -> SyntaxOpType
synKnownType Mult
tup_ty) SyntaxOpType
SynRho ]
                          ExpRhoType
res_ty 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)
                  ; forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, Mult
new_res_ty) }

        ; let rec_ids :: [Id]
rec_ids = forall b a. [b] -> [a] -> [a]
takeList [IdP GhcRn]
rec_names [Id]
tup_ids
        ; [Id]
later_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
later_names
        ; String -> SDoc -> TcRn ()
traceTc String
"tcdo" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr [Id]
rec_ids SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
rec_ids),
                                 forall a. Outputable a => a -> SDoc
ppr [Id]
later_ids SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
later_ids)]
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (RecStmt { recS_stmts :: XRec GhcTc [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
recS_stmts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', recS_later_ids :: [IdP GhcTc]
recS_later_ids = [Id]
later_ids
                          , recS_rec_ids :: [IdP GhcTc]
recS_rec_ids = [Id]
rec_ids, recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExprTc
ret_op'
                          , recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExprTc
mfix_op', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExprTc
bind_op'
                          , recS_ext :: XRecStmt GhcTc GhcTc (LocatedA (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 HsStmtContext GhcRn
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    if forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcTc
pat
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
fail_op [Mult -> SyntaxOpType
synKnownType Mult
stringTy]
                            (Mult -> ExpRhoType
mkCheckExpType Mult
res_ty) forall a b. (a -> b) -> a -> b
$ \[Mult]
_ [Mult]
_ -> 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
-}

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

tcApplicativeStmts :: forall t.
HsStmtContext GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContext GhcRn
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 :: Arity
arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs
      ; [ExpRhoType]
ts <- forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM (Arity
arityforall a. Num a => a -> a -> a
-Arity
1) forall a b. (a -> b) -> a -> b
$ TcM ExpRhoType
newInferExpType
      ; [Mult]
exp_tys <- forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity forall a b. (a -> b) -> a -> b
$ Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
      ; [Mult]
pat_tys <- forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs
      ; [SyntaxExprTc]
ops' <- Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
fun_ty (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SyntaxExprRn]
ops ([ExpRhoType]
ts forall a. [a] -> [a] -> [a]
++ [ExpRhoType
rhs_ty]) [Mult]
exp_tys)

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

      ; forall (m :: * -> *) a. Monad m => a -> m a
return (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
_ [] = 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')
               <- 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 forall a b. (a -> b) -> a -> b
$
                   \ [Mult]
_ [Mult]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; Mult
t_i <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
t_i
           ; [SyntaxExprTc]
ops' <- Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
t_i [(SyntaxExprRn, ExpRhoType, Mult)]
ops
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExprTc
op' forall a. a -> [a] -> [a]
: [SyntaxExprTc]
ops') }

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

    goArg :: Mult
-> (ApplicativeArg GhcRn, Mult, Mult) -> TcM (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 :: forall idL. ApplicativeArg idL -> Bool
is_body_stmt :: Bool
..
                    }, Mult
pat_ty, Mult
exp_ty)
      = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LPat GhcRn
pat) (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcRn
rhs)) forall a b. (a -> b) -> a -> b
$
        forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable body,
 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext GhcRn
ctxt (forall (bodyR :: * -> *).
LPat GhcRn
-> LocatedA (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
mkRnBindStmt LPat GhcRn
pat LHsExpr GhcRn
rhs))   forall a b. (a -> b) -> a -> b
$
        do { LocatedA (HsExpr GhcTc)
rhs'      <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
rhs Mult
exp_ty
           ; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', ()
_) <- forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat (forall a. a -> Scaled a
unrestricted Mult
pat_ty) forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ; Maybe SyntaxExprTc
fail_op' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XApplicativeArgOne GhcRn
fail_op 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) GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExprRn
fail Mult
body_ty

           ; forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
                      { xarg_app_arg_one :: XApplicativeArgOne GhcTc
xarg_app_arg_one = Maybe SyntaxExprTc
fail_op'
                      , app_arg_pattern :: LPat GhcTc
app_arg_pattern = GenLocated SrcSpanAnnA (Pat GhcTc)
pat'
                      , arg_expr :: LHsExpr GhcTc
arg_expr        = LocatedA (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 HsStmtContext (ApplicativeArgStmCtxPass GhcRn)
ctxt, Mult
pat_ty, Mult
exp_ty)
      = do { ([GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', (HsExpr GhcTc
ret',GenLocated SrcSpanAnnA (Pat GhcTc)
pat')) <-
                forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext (ApplicativeArgStmCtxPass GhcRn)
ctxt TcExprStmtChecker
tcDoStmt [GuardLStmt GhcRn]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
exp_ty) 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', ()
_) <- forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext (ApplicativeArgStmCtxPass GhcRn)
ctxt) LPat GhcRn
pat (forall a. a -> Scaled a
unrestricted Mult
pat_ty) forall a b. (a -> b) -> a -> b
$
                                 forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
ret', GenLocated SrcSpanAnnA (Pat GhcTc)
pat')
                  }
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsStmtContext (ApplicativeArgStmCtxPass idL)
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcRn
x [GenLocated
   (Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
   (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' HsExpr GhcTc
ret' GenLocated SrcSpanAnnA (Pat GhcTc)
pat' HsStmtContext (ApplicativeArgStmCtxPass GhcRn)
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 }) = forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders 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 })    = forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders 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}
*                                                                      *
************************************************************************

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

checkArgs :: AnnoBody body
          => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
checkArgs :: forall (body :: * -> *).
AnnoBody body =>
Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcRn ()
checkArgs Name
_ (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [] })
    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkArgs Name
fun (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) })
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
bad_matches
    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise
    = forall a. SDoc -> TcM a
failWithTc ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Equations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
fun) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text String
"have different numbers of arguments"
                       , Arity -> SDoc -> SDoc
nest Arity
2 (forall a. Outputable a => a -> SDoc
ppr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1))
                       , Arity -> SDoc -> SDoc
nest Arity
2 (forall a. Outputable a => a -> SDoc
ppr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (forall a. [a] -> a
head [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
bad_matches)))])
  where
    n_args1 :: Arity
n_args1 = forall body1. LocatedA (Match GhcRn body1) -> Arity
args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1
    bad_matches :: [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
bad_matches = [LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m | LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m <- [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches, forall body1. LocatedA (Match GhcRn body1) -> Arity
args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m forall a. Eq a => a -> a -> Bool
/= Arity
n_args1]

    args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
    args_in_match :: forall body1. LocatedA (Match GhcRn body1) -> Arity
args_in_match (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats })) = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LPat GhcRn]
pats