{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Match
( tcMatchesFun
, tcGRHS
, tcGRHSsPat
, tcMatchesCase
, tcMatchLambda
, TcMatchCtxt(..)
, TcStmtChecker
, TcExprStmtChecker
, TcCmdStmtChecker
, tcStmts
, tcStmtsAndThen
, tcDoStmts
, tcBody
, tcDoStmt
, tcGuardStmt
, checkArgCounts
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcMonoExpr, tcMonoExprNC, tcExpr
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr )
import GHC.Tc.Errors.Types
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.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCon
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 )
import qualified Data.List.NonEmpty as NE
tcMatchesFun :: LocatedN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun :: LocatedN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun LocatedN Name
fun_name MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
exp_ty
= do {
String -> SDoc -> TcRn ()
traceTc String
"tcMatchesFun" (LocatedN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN Name
fun_name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_ty)
; HsMatchContext GhcTc
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn)) -> TcRn ()
forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcTc
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcRn ()
checkArgCounts HsMatchContext GhcTc
what MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches
; ExpectedFunTyOrigin
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
ctxt Arity
arity ExpRhoType
exp_ty (([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> ([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty ->
Mult
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
TcMatchCtxt HsExpr
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
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)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches }
where
arity :: Arity
arity = MatchGroup GhcRn (LocatedA (HsExpr GhcRn)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches
herald :: ExpectedFunTyOrigin
herald = TypedThing
-> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
ExpectedFunTyMatches (Name -> TypedThing
NameThing (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN Name
fun_name)) MatchGroup GhcRn (LHsExpr GhcRn)
matches
ctxt :: UserTypeCtxt
ctxt = UserTypeCtxt
GenSigCtxt
what :: HsMatchContext GhcTc
what = FunRhs { mc_fun :: LIdP (NoGhcTc GhcTc)
mc_fun = LIdP (NoGhcTc GhcTc)
LocatedN Name
fun_name, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = HsMatchContext GhcTc
what, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
tcBody }
strictness :: SrcStrictness
strictness
| [L Anno (Match GhcRn (LocatedA (HsExpr GhcRn)))
_ Match GhcRn (LocatedA (HsExpr GhcRn))
match] <- GenLocated
(Anno
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))])
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> [GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall l e. GenLocated l e -> e
unLoc (GenLocated
(Anno
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))])
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> [GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))])
-> GenLocated
(Anno
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))])
[GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> [GenLocated
(Anno (Match GhcRn (LocatedA (HsExpr GhcRn))))
(Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> XRec GhcRn [LMatch GhcRn (LocatedA (HsExpr GhcRn))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches
, FunRhs{ mc_strictness :: forall p. HsMatchContext p -> SrcStrictness
mc_strictness = SrcStrictness
SrcStrict } <- Match GhcRn (LocatedA (HsExpr GhcRn)) -> HsMatchContext GhcRn
forall p body. Match p body -> HsMatchContext p
m_ctxt Match GhcRn (LocatedA (HsExpr GhcRn))
match
= SrcStrictness
SrcStrict
| Bool
otherwise
= SrcStrictness
NoSrcStrict
tcMatchesCase :: (AnnoBody body) =>
TcMatchCtxt body
-> Scaled TcSigmaTypeFRR
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
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
= TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchCtxt body
ctxt [Mult -> ExpRhoType -> Scaled ExpRhoType
forall a. Mult -> a -> Scaled a
Scaled Mult
scrut_mult (Mult -> ExpRhoType
mkCheckExpType Mult
scrut_ty)] ExpRhoType
res_ty MatchGroup GhcRn (LocatedA (body GhcRn))
matches
tcMatchLambda :: ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda :: ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda ExpectedFunTyOrigin
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
= do { HsMatchContext GhcTc
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn)) -> TcRn ()
forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcTc
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcRn ()
checkArgCounts (TcMatchCtxt HsExpr -> HsMatchContext GhcTc
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what TcMatchCtxt HsExpr
match_ctxt) MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
match
; ExpectedFunTyOrigin
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> Arity
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
GenSigCtxt Arity
n_pats ExpRhoType
res_ty (([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> ([Scaled ExpRhoType]
-> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ [Scaled ExpRhoType]
pat_tys ExpRhoType
rhs_ty -> do
TcMatchCtxt HsExpr
-> [Scaled ExpRhoType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
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)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
match }
where
n_pats :: Arity
n_pats | MatchGroup GhcRn (LocatedA (HsExpr GhcRn)) -> Bool
forall (p :: Pass) body. MatchGroup (GhcPass p) body -> Bool
isEmptyMatchGroup MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
match = Arity
1
| Bool
otherwise = MatchGroup GhcRn (LocatedA (HsExpr GhcRn)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
match
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpRhoType
res_ty
= Mult
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
TcMatchCtxt HsExpr
-> GRHSs GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (HsExpr GhcTc)))
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 GhcRn (LocatedA (HsExpr GhcRn))
grhss ExpRhoType
res_ty
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = HsMatchContext GhcTc
forall p. HsMatchContext p
PatBindRhs,
mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (LocatedA (HsExpr GhcTc))
tcBody }
data TcMatchCtxt body
= MC { forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what :: HsMatchContext GhcTc,
forall (body :: * -> *).
TcMatchCtxt body
-> LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
mc_body :: LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc)) }
type AnnoBody body
= ( Outputable (body GhcRn)
, Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
, Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
, Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
, Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
, Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
)
tcMatches :: (AnnoBody body ) => TcMatchCtxt body
-> [Scaled ExpSigmaTypeFRR]
-> ExpRhoType
-> 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_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcRn (LocatedA (body GhcRn))
origin })
| [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
= do { UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; [Scaled Mult]
pat_tys <- (Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> [Scaled ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
scaledExpTypeToType [Scaled ExpRhoType]
pat_tys
; Mult
rhs_ty <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
rhs_ty
; MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts = SrcSpanAnnL
-> [LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
-> GenLocated
SrcSpanAnnL [LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l []
, mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext = [Scaled Mult] -> Mult -> Origin -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty XMG GhcRn (LocatedA (body GhcRn))
Origin
origin
}) }
| Bool
otherwise
= do { [(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
umatches <- (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc)))))
-> [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcM (LocatedA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LocatedA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc)))))
-> (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> TcM (LocatedA (Match GhcTc (LocatedA (body GhcTc)))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcMatchCtxt body
-> [Scaled ExpRhoType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
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') = [(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
-> ([UsageEnv], [LocatedA (Match GhcTc (LocatedA (body GhcTc)))])
forall a b. [(a, b)] -> ([a], [b])
unzip [(UsageEnv, LocatedA (Match GhcTc (LocatedA (body GhcTc))))]
umatches
; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
; [Scaled Mult]
pat_tys <- (Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> [Scaled ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
readScaledExpType [Scaled ExpRhoType]
pat_tys
; Mult
rhs_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
rhs_ty
; MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts = SrcSpanAnnL
-> [LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
-> GenLocated
SrcSpanAnnL [LocatedA (Match GhcTc (LocatedA (body GhcTc)))]
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 -> Origin -> MatchGroupTc
MatchGroupTc [Scaled Mult]
pat_tys Mult
rhs_ty XMG GhcRn (LocatedA (body GhcRn))
Origin
origin
}) }
tcMatch :: (AnnoBody body) => TcMatchCtxt body
-> [Scaled ExpSigmaType]
-> ExpRhoType
-> 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
= (Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> TcRn (LocatedA (Match GhcTc (LocatedA (body GhcTc))))
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))
LocatedA (Match 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 (TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc))))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { ([GenLocated SrcSpanAnnA (Pat GhcTc)]
pats', GRHSs GhcTc (LocatedA (body GhcTc))
grhss') <- HsMatchContext GhcTc
-> [LPat GhcRn]
-> [Scaled ExpRhoType]
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc)))
forall a.
HsMatchContext GhcTc
-> [LPat GhcRn]
-> [Scaled ExpRhoType]
-> TcM a
-> TcM ([LPat GhcTc], a)
tcPats (TcMatchCtxt body -> HsMatchContext GhcTc
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what TcMatchCtxt body
ctxt) [LPat GhcRn]
pats [Scaled ExpRhoType]
pat_tys (TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc))))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
TcMatchCtxt body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
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
; Match GhcTc (LocatedA (body GhcTc))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match { m_ext :: XCMatch GhcTc (LocatedA (body GhcTc))
m_ext = XCMatch GhcTc (LocatedA (body GhcTc))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, m_ctxt :: HsMatchContext GhcTc
m_ctxt = TcMatchCtxt body -> HsMatchContext GhcTc
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what TcMatchCtxt body
ctxt, m_pats :: [LPat GhcTc]
m_pats = [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats'
, m_grhss :: GRHSs GhcTc (LocatedA (body GhcTc))
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
grhss' }) }
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 TcMatchCtxt body -> HsMatchContext GhcTc
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what TcMatchCtxt body
ctxt of
HsMatchContext GhcTc
LambdaExpr -> TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside
HsMatchContext GhcTc
_ -> SDoc
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatchInCtxt Match GhcRn (LocatedA (body GhcRn))
match) TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside
tcGRHSs :: AnnoBody body
=> TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
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,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
ugrhss)
<- HsLocalBinds GhcRn
-> TcM
[(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
-> TcM
(HsLocalBinds GhcTc,
[(UsageEnv,
GenLocated
(SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))])
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM
[(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
-> TcM
(HsLocalBinds GhcTc,
[(UsageEnv,
GenLocated
(SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]))
-> TcM
[(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
-> TcM
(HsLocalBinds GhcTc,
[(UsageEnv,
GenLocated
(SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))])
forall a b. (a -> b) -> a -> b
$
(GenLocated (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc)))))
-> [GenLocated
(SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))]
-> TcM
[(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcM
(GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM
(GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc)))))
-> (GenLocated
(SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))
-> TcM
(GenLocated
(SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc)))))
-> GenLocated
(SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc))))
-> GenLocated
(SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))
-> TcM
(GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
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))]
[GenLocated (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (body GhcRn)))]
grhss
; let ([UsageEnv]
usages, [GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc)))]
grhss') = [(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
-> ([UsageEnv],
[GenLocated
(SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc)))])
forall a b. [(a, b)] -> ([a], [b])
unzip [(UsageEnv,
GenLocated (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (body GhcTc))))]
ugrhss
; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
usages
; GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHSs GhcTc (LocatedA (body GhcTc))
-> [LGRHS GhcTc (LocatedA (body GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (LocatedA (body GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LocatedA (body GhcTc))
EpAnnComments
emptyComments [LGRHS GhcTc (LocatedA (body GhcTc))]
[GenLocated (SrcAnn NoEpAnns) (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
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guards', LocatedA (body GhcTc)
rhs')
<- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
stmt_ctxt HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc)))
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc))
forall a b. (a -> b) -> a -> b
$
TcMatchCtxt body
-> LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
forall (body :: * -> *).
TcMatchCtxt body
-> LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
mc_body TcMatchCtxt body
ctxt LocatedA (body GhcRn)
rhs
; GRHS GhcTc (LocatedA (body GhcTc))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHS GhcTc (LocatedA (body GhcTc))
-> [GuardLStmt GhcTc]
-> LocatedA (body GhcTc)
-> GRHS GhcTc (LocatedA (body GhcTc))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
EpAnn GrhsAnn
forall a. EpAnn a
noAnn [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guards' LocatedA (body GhcTc)
rhs') }
where
stmt_ctxt :: HsStmtContext GhcTc
stmt_ctxt = HsMatchContext GhcTc -> HsStmtContext GhcTc
forall p. HsMatchContext p -> HsStmtContext p
PatGuard (TcMatchCtxt body -> HsMatchContext GhcTc
forall (body :: * -> *). TcMatchCtxt body -> HsMatchContext GhcTc
mc_what TcMatchCtxt body
ctxt)
tcDoStmts :: HsDoFlavour
-> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcDoStmts :: HsDoFlavour
-> LocatedL [GuardLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
ListComp (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { Mult
res_ty <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
res_ty
; (TcCoercionN
co, Mult
elt_ty) <- Mult -> TcM (TcCoercionN, Mult)
matchExpectedListTy Mult
res_ty
; let list_ty :: Mult
list_ty = Mult -> Mult
mkListTy Mult
elt_ty
; [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ListComp) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
listTyCon) [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts
(Mult -> ExpRhoType
mkCheckExpType Mult
elt_ty)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionN -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionN
co (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
list_ty HsDoFlavour
ListComp (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }
tcDoStmts doExpr :: HsDoFlavour
doExpr@(DoExpr Maybe ModuleName
_) (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
doExpr) HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
res_ty HsDoFlavour
doExpr (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }
tcDoStmts mDoExpr :: HsDoFlavour
mDoExpr@(MDoExpr Maybe ModuleName
_) (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
mDoExpr) HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
res_ty HsDoFlavour
mDoExpr (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }
tcDoStmts HsDoFlavour
MonadComp (L SrcSpanAnnL
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' <- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
MonadComp) HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
; Mult
res_ty <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [GuardLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Mult
res_ty HsDoFlavour
MonadComp (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts')) }
tcDoStmts ctxt :: HsDoFlavour
ctxt@HsDoFlavour
GhciStmtCtxt LocatedL [GuardLStmt GhcRn]
_ ExpRhoType
_ = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (HsDoFlavour -> SDoc
pprHsDoFlavour HsDoFlavour
ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody LHsExpr GhcRn
body ExpRhoType
res_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcBody" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
body ExpRhoType
res_ty
}
type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
= forall thing. HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts :: forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContext GhcTc
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', ()
_) <- HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ())
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty ((rho_type -> TcRn ())
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ()))
-> (rho_type -> TcRn ())
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], ())
forall a b. (a -> b) -> a -> b
$
TcRn () -> rho_type -> TcRn ()
forall a b. a -> b -> a
const (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
; [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts' }
tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen :: forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
_ TcStmtChecker body rho_type
_ [] rho_type
res_ty rho_type -> TcM thing
thing_inside
= do { thing
thing <- rho_type -> TcM thing
thing_inside rho_type
res_ty
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }
tcStmtsAndThen HsStmtContext GhcTc
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)) <- HsLocalBinds GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty rho_type -> TcM thing
thing_inside
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
-> HsLocalBinds GhcTc -> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (LocatedA (body GhcRn))
XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
x HsLocalBinds GhcTc
binds') GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }
tcStmtsAndThen HsStmtContext GhcTc
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)) <-
HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContext GhcTc
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty ((rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty' ((rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall a b. (a -> b) -> a -> b
$
rho_type -> TcM thing
thing_inside
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }
| Bool
otherwise
= do { (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt', ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing)) <-
SrcSpanAnnA
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) (ctx :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, OutputableBndrId ctx,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext (GhcPass ctx)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext GhcTc
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt) (TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContext GhcTc
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty ((rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. TcM a -> TcM a
popErrCtxt (IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a b. (a -> b) -> a -> b
$
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty' ((rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing))
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
forall a b. (a -> b) -> a -> b
$
rho_type -> TcM thing
thing_inside
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
stmt' GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
stmts', thing
thing) }
tcGuardStmt :: TcExprStmtChecker
tcGuardStmt :: TcStmtChecker HsExpr ExpRhoType
tcGuardStmt HsStmtContext GhcTc
_ (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' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
guard Mult
boolTy
; thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
res_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
boolTy LocatedA (HsExpr GhcTc)
guard' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcGuardStmt HsStmtContext GhcTc
ctxt (BindStmt XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_ LPat GhcRn
pat LocatedA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do {
(LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty) <- Mult -> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult))
-> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
tcInferRhoNC LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRBindStmtGuard Mult
rhs_ty
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- HsMatchContext GhcTc
-> CtOrigin
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContext GhcTc
-> CtOrigin
-> LPat GhcRn
-> Scaled Mult
-> TcM a
-> TcM (LPat GhcTc, a)
tcCheckPat_O (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcTc
ctxt) (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs)
LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
rhs_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside ExpRhoType
res_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }
tcGuardStmt HsStmtContext GhcTc
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcGuardStmt: unexpected Stmt" (Stmt GhcRn (LocatedA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)
tcLcStmt :: TyCon
-> TcExprStmtChecker
tcLcStmt :: TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
_ HsStmtContext GhcTc
_ (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 LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
body ExpRhoType
elt_ty
; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcLcStmt: thing_inside")
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
x LocatedA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcLcStmt TyCon
m_tc HsStmtContext GhcTc
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 LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs (TyCon -> [Mult] -> Mult
mkTyConApp TyCon
m_tc [Mult
pat_ty])
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- HsMatchContext GhcTc
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcTc
ctxt) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (bodyR :: * -> *).
LPat GhcTc
-> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
mkTcBindStmt LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }
tcLcStmt TyCon
_ HsStmtContext GhcTc
_ (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 LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs Mult
boolTy
; thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
boolTy LocatedA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcLcStmt TyCon
m_tc HsStmtContext GhcTc
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
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
unitTy [ParStmtBlock GhcTc GhcTc]
pairs' HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
where
loop :: [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop [] = do { thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
; ([ParStmtBlock GhcTc GhcTc], thing)
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }
loop (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
_ : [ParStmtBlock GhcRn GhcRn]
pairs)
= do { ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
ids, [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing))
<- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts ExpRhoType
elt_ty ((ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
_elt_ty' ->
do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
; ([ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) <- [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop [ParStmtBlock GhcRn GhcRn]
pairs
; ([Id], [ParStmtBlock GhcTc GhcTc], thing)
-> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
; ([ParStmtBlock GhcTc GhcTc], thing)
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XParStmtBlock GhcTc GhcTc
-> [GuardLStmt GhcTc]
-> [IdP GhcTc]
-> SyntaxExpr GhcTc
-> ParStmtBlock GhcTc GhcTc
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' [IdP GhcTc]
[Id]
ids SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr ParStmtBlock GhcTc GhcTc
-> [ParStmtBlock GhcTc GhcTc] -> [ParStmtBlock GhcTc GhcTc]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing ) }
tcLcStmt TyCon
m_tc HsStmtContext GhcTc
ctxt (TransStmt { trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form, trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts
, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcRn, IdP GhcRn)]
bindersMap
, trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using }) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= do { let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap
unused_ty :: ExpRhoType
unused_ty = String -> SDoc -> ExpRhoType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: inner ty" ([(Name, Name)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap)
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (LocatedA (HsExpr GhcTc), Mult)
by'))
<- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsStmtContext GhcTc -> HsStmtContext GhcTc
forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcTc
ctxt) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts ExpRhoType
unused_ty ((ExpRhoType -> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult))))
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
_ -> do
{ Maybe (LocatedA (HsExpr GhcTc), Mult)
by' <- (LocatedA (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> Maybe (LocatedA (HsExpr GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (LocatedA (HsExpr GhcTc), Mult))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
LocatedA (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult)
tcInferRho Maybe (LHsExpr GhcRn)
Maybe (LocatedA (HsExpr GhcRn))
by
; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names
; ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult))
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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]
; 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
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 (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
e_ty) (() :: Constraint) => Mult -> Mult -> Mult
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 (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult
poly_arg_ty (() :: Constraint) => Mult -> Mult -> Mult
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 = (HsExpr GhcTc -> HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) LocatedA (HsExpr GhcTc)
using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr :: Name -> Id -> Id
mk_n_bndr Name
n_bndr_name Id
bndr_id = (() :: Constraint) => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
idType Id
bndr_id))
n_bndr_ids :: [Id]
n_bndr_ids = (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Id -> Id
mk_n_bndr [Name]
n_bndr_names [Id]
bndr_ids
bindersMap' :: [(Id, Id)]
bindersMap' = [Id]
bndr_ids [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
n_bndr_ids
; thing
thing <- [Id] -> TcM thing -> TcM thing
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
n_bndr_ids (ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty)
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt { trS_stmts :: [GuardLStmt GhcTc]
trS_stmts = [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(IdP GhcTc, IdP GhcTc)]
[(Id, Id)]
bindersMap'
, trS_by :: Maybe (LHsExpr GhcTc)
trS_by = ((LocatedA (HsExpr GhcTc), Mult) -> LocatedA (HsExpr GhcTc))
-> Maybe (LocatedA (HsExpr GhcTc), Mult)
-> Maybe (LocatedA (HsExpr GhcTc))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LocatedA (HsExpr GhcTc), Mult) -> LocatedA (HsExpr GhcTc)
forall a b. (a, b) -> a
fst Maybe (LocatedA (HsExpr GhcTc), Mult)
by', trS_using :: LHsExpr GhcTc
trS_using = LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
final_using
, trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
, trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
, trS_fmap :: HsExpr GhcTc
trS_fmap = HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
, trS_ext :: XTransStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
trS_ext = XTransStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
unitTy
, trS_form :: TransForm
trS_form = TransForm
form }, thing
thing) }
tcLcStmt TyCon
_ HsStmtContext GhcTc
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (Stmt GhcRn (LocatedA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)
tcMcStmt :: TcExprStmtChecker
tcMcStmt :: TcStmtChecker HsExpr ExpRhoType
tcMcStmt HsStmtContext GhcTc
_ (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')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM (LocatedA (HsExpr GhcTc)))
-> TcM (LocatedA (HsExpr GhcTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult] -> [Mult] -> TcM (LocatedA (HsExpr GhcTc)))
-> TcM (LocatedA (HsExpr GhcTc), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcM (LocatedA (HsExpr GhcTc)))
-> TcM (LocatedA (HsExpr GhcTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
a_ty] [Mult
mult]->
Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
body Mult
a_ty
; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcMcStmt: thing_inside")
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
x LocatedA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
SyntaxExprTc
return_op', thing
thing) }
tcMcStmt HsStmtContext GhcTc
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 { ((Mult
rhs_ty, LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing, Mult
new_res_ty), SyntaxExprTc
bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XBindStmtRn
xbsrn)
[SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult, Mult
pat_mult] ->
do { LocatedA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs Mult
rhs_ty
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- Mult
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing))
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcTc
ctxt) LPat GhcRn
pat (Mult -> Mult -> Scaled Mult
forall a. Mult -> a -> Scaled a
Scaled Mult
pat_mult Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult)
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
rhs_ty, LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing, Mult
new_res_ty) }
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> FixedRuntimeRepContext
FRRBindStmt StmtOrigin
MonadComprehension) Mult
rhs_ty
; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XBindStmtRn
xbsrn) ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
MCompPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty
; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
, xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
, xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
}
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbstc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }
tcMcStmt HsStmtContext GhcTc
_ (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 {
; ((thing
thing, LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, Mult
test_ty, SyntaxExprTc
guard_op'), SyntaxExprTc
then_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult] ->
do { ((LocatedA (HsExpr GhcTc)
rhs', Mult
test_ty), SyntaxExprTc
guard_op')
<- Mult
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
guard_op [SyntaxOpType
SynAny]
(Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty) (([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
test_ty] [Mult
test_mult] -> do
LocatedA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
test_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs Mult
test_ty
(LocatedA (HsExpr GhcTc), Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedA (HsExpr GhcTc), Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> (LocatedA (HsExpr GhcTc), Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult)
forall a b. (a -> b) -> a -> b
$ (LocatedA (HsExpr GhcTc)
rhs', Mult
test_ty)
; thing
thing <- Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc)
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, Mult
test_ty, SyntaxExprTc
guard_op') }
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRBodyStmtGuard Mult
test_ty
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> Arity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
MonadComprehension Arity
1) Mult
rhs_ty
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> Arity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
MonadComprehension Arity
2) Mult
new_res_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
rhs_ty LocatedA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
SyntaxExprTc
then_op' SyntaxExpr GhcTc
SyntaxExprTc
guard_op', thing
thing) }
tcMcStmt HsStmtContext GhcTc
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
; Mult -> Mult
n_app <- case TransForm
form of
TransForm
ThenForm -> (Mult -> Mult) -> IOEnv (Env TcGblEnv TcLclEnv) (Mult -> Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (\Mult
ty -> Mult
ty)
TransForm
_ -> do { Mult
n_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
; (Mult -> Mult) -> IOEnv (Env TcGblEnv TcLclEnv) (Mult -> Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
n_ty Mult -> Mult -> Mult
`mkAppTy`) }
; let by_arrow :: Type -> Type
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 (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
by_e_ty) (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
res
poly_arg_ty :: Mult
poly_arg_ty = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy
using_arg_ty :: Mult
using_arg_ty = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tup_ty
poly_res_ty :: Mult
poly_res_ty = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
alphaTy
using_res_ty :: Mult
using_res_ty = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
tup_ty
using_poly_ty :: Mult
using_poly_ty = Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult
poly_arg_ty (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
poly_res_ty
; let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
bndr_ids, Maybe (LocatedA (HsExpr GhcTc))
by', SyntaxExprTc
return_op')) <-
HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsStmtContext GhcTc -> HsStmtContext GhcTc
forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcTc
ctxt) HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts
(Mult -> ExpRhoType
mkCheckExpType Mult
using_arg_ty) ((ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc)))
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc))
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 -> Maybe (LocatedA (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LocatedA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LocatedA (HsExpr GhcTc))
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
; Maybe (LocatedA (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LocatedA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr GhcTc) -> Maybe (LocatedA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LocatedA (HsExpr GhcTc)
e') }
; [Id]
bndr_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [Name]
bndr_names
; (()
_, SyntaxExprTc
return_op') <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op
[Mult -> SyntaxOpType
synKnownType ([Id] -> Mult
mkBigCoreVarTupTy [Id]
bndr_ids)]
ExpRhoType
res_ty' (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; ([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc)
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc)), SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndr_ids, Maybe (LocatedA (HsExpr GhcTc))
by', SyntaxExprTc
return_op') }
; Mult
new_res_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
; (()
_, SyntaxExprTc
bind_op') <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
bind_op
[ Mult -> SyntaxOpType
synKnownType Mult
using_res_ty
, Mult -> SyntaxOpType
synKnownType (Mult -> Mult
n_app Mult
tup_ty (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
new_res_ty) ]
ExpRhoType
res_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; HsExpr GhcTc
fmap_op' <- case TransForm
form of
TransForm
ThenForm -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
TransForm
_ -> (LocatedA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TcM (LocatedA (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocatedA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (TcM (LocatedA (HsExpr GhcTc)) -> TcM (HsExpr GhcTc))
-> (Mult -> TcM (LocatedA (HsExpr GhcTc)))
-> Mult
-> TcM (HsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
fmap_op) (Mult -> TcM (HsExpr GhcTc)) -> Mult -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Id -> Mult -> Mult
mkInfForAllTy Id
betaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
(Mult
alphaTy (() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
betaTy)
(() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
alphaTy)
(() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
betaTy)
; 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 = (HsExpr GhcTc -> HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) LocatedA (HsExpr GhcTc)
using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr :: Name -> Id -> Id
mk_n_bndr Name
n_bndr_name Id
bndr_id = (() :: Constraint) => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
idType Id
bndr_id))
n_bndr_ids :: [Id]
n_bndr_ids = String -> (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c.
(() :: Constraint) =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"tcMcStmt" Name -> Id -> Id
mk_n_bndr [Name]
n_bndr_names [Id]
bndr_ids
bindersMap' :: [(Id, Id)]
bindersMap' = [Id]
bndr_ids [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
n_bndr_ids
; thing
thing <- [Id] -> TcM thing -> TcM thing
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
n_bndr_ids (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransStmt { trS_stmts :: [GuardLStmt GhcTc]
trS_stmts = [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(IdP GhcTc, IdP GhcTc)]
[(Id, Id)]
bindersMap'
, trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (LHsExpr GhcTc)
Maybe (LocatedA (HsExpr GhcTc))
by', trS_using :: LHsExpr GhcTc
trS_using = LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
final_using
, trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExpr GhcTc
SyntaxExprTc
return_op', trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, trS_ext :: XTransStmt GhcTc GhcTc (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) }
tcMcStmt HsStmtContext GhcTc
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] (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy)
(() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
betaTy)
(() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` [Mult] -> Mult
mkBoxedTupleTy [Mult
alphaTy, Mult
betaTy])
; HsExpr GhcTc
mzip_op' <- LocatedA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (LocatedA (HsExpr GhcTc) -> HsExpr GhcTc)
-> TcM (LocatedA (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
mzip_op) Mult
mzip_ty
; [[Mult]]
id_tys_s <- (([Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> [[Name]] -> IOEnv (Env TcGblEnv TcLclEnv) [[Mult]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> [[Name]] -> IOEnv (Env TcGblEnv TcLclEnv) [[Mult]])
-> ((Name -> TcM Mult)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> (Name -> TcM Mult)
-> [[Name]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[Mult]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> TcM Mult)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM) (TcM Mult -> Name -> TcM Mult
forall a b. a -> b -> a
const (Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind))
[ [IdP GhcRn]
[Name]
names | ParStmtBlock XParStmtBlock GhcRn GhcRn
_ [GuardLStmt GhcRn]
_ [IdP GhcRn]
names SyntaxExpr GhcRn
_ <- [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s ]
; let tup_tys :: [Mult]
tup_tys = [ [Mult] -> Mult
mkBigCoreTupTy [Mult]
id_tys | [Mult]
id_tys <- [[Mult]]
id_tys_s ]
tuple_ty :: Mult
tuple_ty = [Mult] -> Mult
forall {t :: * -> *}. Foldable t => t Mult -> Mult
mk_tuple_ty [Mult]
tup_tys
; ((([ParStmtBlock GhcTc GhcTc]
blocks', thing
thing), Mult
inner_res_ty), SyntaxExprTc
bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult] -> TcM (([ParStmtBlock GhcTc GhcTc], thing), Mult))
-> TcM ((([ParStmtBlock GhcTc GhcTc], thing), Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
bind_op
[ Mult -> SyntaxOpType
synKnownType (Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tuple_ty)
, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (Mult -> SyntaxOpType
synKnownType Mult
tuple_ty) SyntaxOpType
SynRho ] ExpRhoType
res_ty (([Mult]
-> [Mult] -> TcM (([ParStmtBlock GhcTc GhcTc], thing), Mult))
-> TcM ((([ParStmtBlock GhcTc GhcTc], thing), Mult), SyntaxExprTc))
-> ([Mult]
-> [Mult] -> TcM (([ParStmtBlock GhcTc GhcTc], thing), Mult))
-> TcM ((([ParStmtBlock GhcTc GhcTc], thing), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
inner_res_ty] [Mult]
_ ->
do { ([ParStmtBlock GhcTc GhcTc], thing)
stuff <- Mult
-> ExpRhoType
-> [Mult]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop Mult
m_ty (Mult -> ExpRhoType
mkCheckExpType Mult
inner_res_ty)
[Mult]
tup_tys [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s
; (([ParStmtBlock GhcTc GhcTc], thing), Mult)
-> TcM (([ParStmtBlock GhcTc GhcTc], thing), Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (([ParStmtBlock GhcTc GhcTc], thing)
stuff, Mult
inner_res_ty) }
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [ParStmtBlock GhcTc GhcTc]
-> HsExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
inner_res_ty [ParStmtBlock GhcTc GhcTc]
blocks' HsExpr GhcTc
mzip_op' SyntaxExpr GhcTc
SyntaxExprTc
bind_op', thing
thing) }
where
mk_tuple_ty :: t Mult -> Mult
mk_tuple_ty t Mult
tys = (Mult -> Mult -> Mult) -> t Mult -> Mult
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Mult
tn Mult
tm -> [Mult] -> Mult
mkBoxedTupleTy [Mult
tn, Mult
tm]) t Mult
tys
loop :: Mult
-> ExpRhoType
-> [Mult]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop Mult
_ ExpRhoType
inner_res_ty [] [] = do { thing
thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
inner_res_ty
; ([ParStmtBlock GhcTc GhcTc], thing)
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }
loop Mult
m_ty ExpRhoType
inner_res_ty (Mult
tup_ty_in : [Mult]
tup_tys_in)
(ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
return_op : [ParStmtBlock GhcRn GhcRn]
pairs)
= do { let m_tup_ty :: Mult
m_tup_ty = Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tup_ty_in
; ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing))
<- HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
m_tup_ty) ((ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$
\ExpRhoType
m_tup_ty' ->
do { [Id]
ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
; let tup_ty :: Mult
tup_ty = [Id] -> Mult
mkBigCoreVarTupTy [Id]
ids
; (()
_, SyntaxExprTc
return_op') <-
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op
[Mult -> SyntaxOpType
synKnownType Mult
tup_ty] ExpRhoType
m_tup_ty' (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; ([ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) <- Mult
-> ExpRhoType
-> [Mult]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop Mult
m_ty ExpRhoType
inner_res_ty [Mult]
tup_tys_in [ParStmtBlock GhcRn GhcRn]
pairs
; ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, SyntaxExprTc
return_op', [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
; ([ParStmtBlock GhcTc GhcTc], thing)
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmtBlock GhcTc GhcTc
-> [GuardLStmt GhcTc]
-> [IdP GhcTc]
-> SyntaxExpr GhcTc
-> ParStmtBlock GhcTc GhcTc
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcRn GhcRn
XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' [IdP GhcTc]
[Id]
ids SyntaxExpr GhcTc
SyntaxExprTc
return_op' ParStmtBlock GhcTc GhcTc
-> [ParStmtBlock GhcTc GhcTc] -> [ParStmtBlock GhcTc GhcTc]
forall a. a -> [a] -> [a]
: [ParStmtBlock GhcTc GhcTc]
pairs', thing
thing) }
loop Mult
_ ExpRhoType
_ [Mult]
_ [ParStmtBlock GhcRn GhcRn]
_ = String
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. HasCallStack => String -> a
panic String
"tcMcStmt.loop"
tcMcStmt HsStmtContext GhcTc
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (Stmt GhcRn (LocatedA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)
tcDoStmt :: TcExprStmtChecker
tcDoStmt :: TcStmtChecker HsExpr ExpRhoType
tcDoStmt HsStmtContext GhcTc
_ (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 LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
body ExpRhoType
res_ty
; thing
thing <- ExpRhoType -> TcM thing
thing_inside (String -> ExpRhoType
forall a. HasCallStack => String -> a
panic String
"tcDoStmt: thing_inside")
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> Maybe Bool
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
x LocatedA (HsExpr GhcTc)
body' Maybe Bool
noret SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcDoStmt HsStmtContext GhcTc
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 {
((Mult
rhs_ty, LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing), SyntaxExprTc
bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XBindStmtRn
xbsrn) [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult,Mult
pat_mult] ->
do { LocatedA (HsExpr GhcTc)
rhs' <-Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs Mult
rhs_ty
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', thing
thing) <- Mult
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing))
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), thing)
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc
-> LPat GhcRn
-> Scaled Mult
-> TcM thing
-> TcM (LPat GhcTc, thing)
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcTc
ctxt) LPat GhcRn
pat (Mult -> Mult -> Scaled Mult
forall a. Mult -> a -> Scaled a
Scaled Mult
pat_mult Mult
pat_ty) (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing)
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Mult
rhs_ty, LocatedA (HsExpr GhcTc)
rhs', Mult
pat_mult, GenLocated SrcSpanAnnA (Pat GhcTc)
pat', Mult
new_res_ty, thing
thing) }
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> FixedRuntimeRepContext
FRRBindStmt StmtOrigin
DoNotation) Mult
rhs_ty
; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (LocatedA (HsExpr GhcRn))
XBindStmtRn
xbsrn) ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty
; let xbstc :: XBindStmtTc
xbstc = XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
, xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
, xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
}
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbstc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LocatedA (HsExpr GhcTc)
rhs', thing
thing) }
tcDoStmt HsStmtContext GhcTc
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 = HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall t.
HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContext GhcTc
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
ty ((Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside (ExpRhoType -> TcM thing)
-> (Mult -> ExpRhoType) -> Mult -> TcM thing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mult -> ExpRhoType
mkCheckExpType
; (([(SyntaxExprTc, ApplicativeArg GhcTc)]
pairs', Mult
body_ty, thing
thing), Maybe SyntaxExprTc
mb_join') <- case FailOperator GhcRn
mb_join of
FailOperator GhcRn
Nothing -> (, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts ExpRhoType
res_ty
Just SyntaxExpr GhcRn
join_op ->
(SyntaxExprTc -> Maybe SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just ((([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
join_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty] [Mult
rhs_mult] -> Mult
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$ ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts (Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty))
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
-> FailOperator GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
pairs' FailOperator GhcTc
Maybe SyntaxExprTc
mb_join', thing
thing) }
tcDoStmt HsStmtContext GhcTc
_ (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 {
; ((LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, thing
thing), SyntaxExprTc
then_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM ((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM
((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc))
-> ([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM ((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult] ->
do { LocatedA (HsExpr GhcTc)
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs Mult
rhs_ty
; thing
thing <- Mult -> TcM thing -> TcM thing
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
fun_mult (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (LocatedA (HsExpr GhcTc), Mult, Mult, thing)
-> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr GhcTc)
rhs', Mult
rhs_ty, Mult
new_res_ty, thing
thing) }
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> Arity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
DoNotation Arity
1) Mult
rhs_ty
; (() :: Constraint) => FixedRuntimeRepContext -> Mult -> TcRn ()
FixedRuntimeRepContext -> Mult -> TcRn ()
hasFixedRuntimeRep_syntactic (StmtOrigin -> Arity -> FixedRuntimeRepContext
FRRBodyStmt StmtOrigin
DoNotation Arity
2) Mult
new_res_ty
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc)
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Mult
rhs_ty LocatedA (HsExpr GhcTc)
rhs' SyntaxExpr GhcTc
SyntaxExprTc
then_op' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }
tcDoStmt HsStmtContext GhcTc
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]
[Name]
rec_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcRn -> [IdP GhcRn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcRn]
rec_names) [IdP GhcRn]
[Name]
later_names
; [Mult]
tup_elt_tys <- Arity -> Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
newFlexiTyVarTys ([Name] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Name]
tup_names) Mult
liftedTypeKind
; let tup_ids :: [Id]
tup_ids = (Name -> Mult -> Id) -> [Name] -> [Mult] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Mult
t -> (() :: Constraint) => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n Mult
ManyTy Mult
t) [Name]
tup_names [Mult]
tup_elt_tys
tup_ty :: Mult
tup_ty = [Mult] -> Mult
mkBigCoreTupTy [Mult]
tup_elt_tys
; [Id]
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
tup_ids (TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing))
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$ do
{ (([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', (SyntaxExprTc
ret_op', [HsExpr GhcTc]
tup_rets)), Mult
stmts_ty)
<- (ExpRhoType
-> TcM
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])))
-> TcM
(([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])),
Mult)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Mult)
tcInfer ((ExpRhoType
-> TcM
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])))
-> TcM
(([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])),
Mult))
-> (ExpRhoType
-> TcM
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])))
-> TcM
(([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))],
(SyntaxExprTc, [HsExpr GhcTc])),
Mult)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc]))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContext GhcTc
ctxt HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
[GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (HsExpr GhcRn)))]
stmts ExpRhoType
exp_ty ((ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc])))
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
inner_res_ty ->
do { [HsExpr GhcTc]
tup_rets <- (Name -> ExpRhoType -> TcM (HsExpr GhcTc))
-> [Name]
-> [ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExpr GhcTc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId [Name]
tup_names
((Mult -> ExpRhoType) -> [Mult] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map Mult -> ExpRhoType
mkCheckExpType [Mult]
tup_elt_tys)
; (()
_, SyntaxExprTc
ret_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
ret_op [Mult -> SyntaxOpType
synKnownType Mult
tup_ty]
ExpRhoType
inner_res_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (SyntaxExprTc, [HsExpr GhcTc])
-> TcM (SyntaxExprTc, [HsExpr GhcTc])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExprTc
ret_op', [HsExpr GhcTc]
tup_rets) }
; ((()
_, SyntaxExprTc
mfix_op'), Mult
mfix_res_ty)
<- (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), Mult)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Mult)
tcInfer ((ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), Mult))
-> (ExpRhoType -> TcM ((), SyntaxExprTc))
-> TcM (((), SyntaxExprTc), Mult)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
exp_ty ->
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
mfix_op
[Mult -> SyntaxOpType
synKnownType ((() :: Constraint) => Mult -> Mult -> Mult
Mult -> Mult -> Mult
mkVisFunTyMany Mult
tup_ty Mult
stmts_ty)] ExpRhoType
exp_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; ((thing
thing, Mult
new_res_ty), SyntaxExprTc
bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM (thing, Mult))
-> TcM ((thing, Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
bind_op
[ Mult -> SyntaxOpType
synKnownType Mult
mfix_res_ty
, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (Mult -> SyntaxOpType
synKnownType Mult
tup_ty) SyntaxOpType
SynRho ]
ExpRhoType
res_ty (([Mult] -> [Mult] -> TcM (thing, Mult))
-> TcM ((thing, Mult), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcM (thing, Mult))
-> TcM ((thing, Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
new_res_ty] [Mult]
_ ->
do { thing
thing <- ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; (thing, Mult) -> TcM (thing, Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
thing, Mult
new_res_ty) }
; let rec_ids :: [Id]
rec_ids = [Name] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
takeList [IdP GhcRn]
[Name]
rec_names [Id]
tup_ids
; [Id]
later_ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
later_names
; String -> SDoc -> TcRn ()
traceTc String
"tcdo" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [[Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rec_ids SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Mult] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Id -> Mult) -> [Id] -> [Mult]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
rec_ids),
[Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
later_ids SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Mult] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Id -> Mult) -> [Id] -> [Mult]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Mult
idType [Id]
later_ids)]
; (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecStmt { recS_stmts :: XRec GhcTc [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
recS_stmts = SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', recS_later_ids :: [IdP GhcTc]
recS_later_ids = [IdP GhcTc]
[Id]
later_ids
, recS_rec_ids :: [IdP GhcTc]
recS_rec_ids = [IdP GhcTc]
[Id]
rec_ids, recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExpr GhcTc
SyntaxExprTc
ret_op'
, recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExpr GhcTc
SyntaxExprTc
mfix_op', recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, recS_ext :: XRecStmt GhcTc GhcTc (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 GhcTc
_ Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (Stmt GhcRn (LocatedA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (LocatedA (HsExpr GhcRn))
stmt)
tcMonadFailOp :: CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> TcType
-> TcRn (FailOperator GhcTc)
tcMonadFailOp :: CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp CtOrigin
orig LPat GhcTc
pat SyntaxExpr GhcRn
fail_op Mult
res_ty = do
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if DynFlags -> LPat GhcTc -> Bool
forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcTc
pat
then Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
else SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (SyntaxExprTc -> Maybe SyntaxExprTc)
-> (((), SyntaxExprTc) -> SyntaxExprTc)
-> ((), SyntaxExprTc)
-> Maybe SyntaxExprTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), SyntaxExprTc) -> SyntaxExprTc
forall a b. (a, b) -> b
snd (((), SyntaxExprTc) -> Maybe SyntaxExprTc)
-> TcM ((), SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
SyntaxExprRn
fail_op [Mult -> SyntaxOpType
synKnownType Mult
stringTy]
(Mult -> ExpRhoType
mkCheckExpType Mult
res_ty) (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
tcApplicativeStmts
:: HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcRhoType -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
tcApplicativeStmts :: forall t.
HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContext GhcTc
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 = [(SyntaxExprRn, ApplicativeArg GhcRn)] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
; [ExpRhoType]
ts <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM (Arity
arityArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) (IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType])
-> IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) [ExpRhoType]
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) ExpRhoType
newInferExpType
; [Mult]
exp_tys <- Arity -> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity (TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall a b. (a -> b) -> a -> b
$ Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
; [Mult]
pat_tys <- Arity -> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity (TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult])
-> TcM Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
forall a b. (a -> b) -> a -> b
$ Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
; let fun_ty :: Mult
fun_ty = [Mult] -> Mult -> Mult
mkVisFunTysMany [Mult]
pat_tys Mult
body_ty
; let ([SyntaxExprRn]
ops, [ApplicativeArg GhcRn]
args) = [(SyntaxExprRn, ApplicativeArg GhcRn)]
-> ([SyntaxExprRn], [ApplicativeArg GhcRn])
forall a b. [(a, b)] -> ([a], [b])
unzip [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
; [SyntaxExprTc]
ops' <- Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
fun_ty ([SyntaxExprRn]
-> [ExpRhoType] -> [Mult] -> [(SyntaxExprRn, ExpRhoType, Mult)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SyntaxExprRn]
ops ([ExpRhoType]
ts [ExpRhoType] -> [ExpRhoType] -> [ExpRhoType]
forall a. [a] -> [a] -> [a]
++ [ExpRhoType
rhs_ty]) [Mult]
exp_tys)
; [ApplicativeArg GhcTc]
args' <- ((ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> [(ApplicativeArg GhcRn, Mult, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [ApplicativeArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Mult
-> (ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
goArg Mult
body_ty) ([ApplicativeArg GhcRn]
-> [Mult] -> [Mult] -> [(ApplicativeArg GhcRn, Mult, Mult)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ApplicativeArg GhcRn]
args [Mult]
pat_tys [Mult]
exp_tys)
; t
res <- [Id] -> TcM t -> TcM t
forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv ((ApplicativeArg GhcTc -> [Id]) -> [ApplicativeArg GhcTc] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ApplicativeArg GhcTc -> [Id]
get_arg_bndrs [ApplicativeArg GhcTc]
args') (TcM t -> TcM t) -> TcM t -> TcM t
forall a b. (a -> b) -> a -> b
$
Mult -> TcM t
thing_inside Mult
body_ty
; ([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, t)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, t)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxExprTc]
-> [ApplicativeArg GhcTc] -> [(SyntaxExprTc, ApplicativeArg GhcTc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SyntaxExprTc]
ops' [ApplicativeArg GhcTc]
args', Mult
body_ty, t
res) }
where
goOps :: Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
_ [] = [SyntaxExprTc] -> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
goOps Mult
t_left ((SyntaxExprRn
op,ExpRhoType
t_i,Mult
exp_ty) : [(SyntaxExprRn, ExpRhoType, Mult)]
ops)
= do { (()
_, SyntaxExprTc
op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExprRn
op
[Mult -> SyntaxOpType
synKnownType Mult
t_left, Mult -> SyntaxOpType
synKnownType Mult
exp_ty] ExpRhoType
t_i (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Mult
t_i <- ExpRhoType -> TcM Mult
readExpType ExpRhoType
t_i
; [SyntaxExprTc]
ops' <- Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
t_i [(SyntaxExprRn, ExpRhoType, Mult)]
ops
; [SyntaxExprTc] -> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExprTc
op' SyntaxExprTc -> [SyntaxExprTc] -> [SyntaxExprTc]
forall a. a -> [a] -> [a]
: [SyntaxExprTc]
ops') }
goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-> TcM (ApplicativeArg GhcTc)
goArg :: Mult
-> (ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
goArg Mult
body_ty (ApplicativeArgOne
{ xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
xarg_app_arg_one = XApplicativeArgOne GhcRn
fail_op
, app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: forall idL. ApplicativeArg idL -> LHsExpr idL
arg_expr = LHsExpr GhcRn
rhs
, Bool
is_body_stmt :: Bool
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
..
}, Mult
pat_ty, Mult
exp_ty)
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat) (LocatedA (HsExpr GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext GhcTc -> Stmt GhcRn (LocatedA (HsExpr GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) (ctx :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR, OutputableBndrId ctx,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext (GhcPass ctx)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContext GhcTc
ctxt (LPat GhcRn
-> LocatedA (HsExpr GhcRn) -> Stmt GhcRn (LocatedA (HsExpr GhcRn))
forall (bodyR :: * -> *).
LPat GhcRn
-> LocatedA (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
mkRnBindStmt LPat GhcRn
pat LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
do { LocatedA (HsExpr GhcTc)
rhs' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
rhs Mult
exp_ty
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', ()
_) <- HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcRn () -> TcM (LPat GhcTc, ())
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcTc
ctxt) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcRn () -> TcM (LPat GhcTc, ()))
-> TcRn () -> TcM (LPat GhcTc, ())
forall a b. (a -> b) -> a -> b
$
() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Maybe SyntaxExprTc
fail_op' <- (Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe SyntaxExprTc) -> Maybe SyntaxExprTc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc)))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SyntaxExprRn
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Maybe SyntaxExprTc))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe SyntaxExprRn
XApplicativeArgOne GhcRn
fail_op ((SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> (SyntaxExprRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
body_ty
; ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcTc
xarg_app_arg_one = Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
fail_op'
, app_arg_pattern :: LPat GhcTc
app_arg_pattern = LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat'
, arg_expr :: LHsExpr GhcTc
arg_expr = LHsExpr GhcTc
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 HsDoFlavour
ctxt, Mult
pat_ty, Mult
exp_ty)
= do { ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', (HsExpr GhcTc
ret',GenLocated SrcSpanAnnA (Pat GhcTc)
pat')) <-
HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctxt) HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (LocatedA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
exp_ty) ((ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))))
-> (ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$
\ExpRhoType
res_ty -> do
{ HsExpr GhcTc
ret' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
ret ExpRhoType
res_ty
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', ()
_) <- HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcRn () -> TcM (LPat GhcTc, ())
forall a.
HsMatchContext GhcTc
-> LPat GhcRn -> Scaled Mult -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctxt)) LPat GhcRn
pat (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
pat_ty) (TcRn () -> TcM (LPat GhcTc, ()))
-> TcRn () -> TcM (LPat GhcTc, ())
forall a b. (a -> b) -> a -> b
$
() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
ret', GenLocated SrcSpanAnnA (Pat GhcTc)
pat')
}
; ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XApplicativeArgMany GhcTc
-> [GuardLStmt GhcTc]
-> HsExpr GhcTc
-> LPat GhcTc
-> HsDoFlavour
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsDoFlavour
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcRn
XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts' HsExpr GhcTc
ret' LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' HsDoFlavour
ctxt) }
get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcTc
pat }) = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat
get_arg_bndrs (ApplicativeArgMany { bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern = LPat GhcTc
pat }) = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat
checkArgCounts :: AnnoBody body
=> HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM ()
checkArgCounts :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcTc
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcRn ()
checkArgCounts HsMatchContext GhcTc
_ (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [] })
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkArgCounts HsMatchContext GhcTc
matchContext (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) })
| Just NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches <- Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches
= TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc -> MatchArgBadMatches -> TcRnMessage
TcRnMatchesHaveDiffNumArgs HsMatchContext GhcTc
matchContext
(MatchArgBadMatches -> TcRnMessage)
-> MatchArgBadMatches -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
-> MatchArgBadMatches
forall body.
LocatedA (Match GhcRn body)
-> NonEmpty (LocatedA (Match GhcRn body)) -> MatchArgBadMatches
MatchArgMatches LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1 NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
n_args1 :: Arity
n_args1 = LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> Arity
forall body1. LocatedA (Match GhcRn body1) -> Arity
args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1
mb_bad_matches :: Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches = [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> Maybe
(NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m | LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m <- [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches, LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> Arity
forall body1. LocatedA (Match GhcRn body1) -> Arity
args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m Arity -> Arity -> Bool
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 })) = [GenLocated SrcSpanAnnA (Pat GhcRn)] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats