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