{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Match
( tcFunBindMatches
, tcCaseMatches
, tcLambdaMatches
, tcGRHSList
, tcGRHSsPat
, TcStmtChecker
, TcExprStmtChecker
, TcCmdStmtChecker
, tcStmts
, tcStmtsAndThen
, tcDoStmts
, tcBody
, tcDoStmt
, tcGuardStmt
, checkArgCounts
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcMonoExprNC, tcExpr
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr, tcPolyLExpr )
import GHC.Rename.Utils ( bindLocalNames )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Gen.Bind
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
import GHC.Rename.Env ( irrefutableConLikeTc )
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.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import qualified GHC.LanguageExtensions as LangExt
tcFunBindMatches :: UserTypeCtxt
-> Name
-> Mult
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches :: UserTypeCtxt
-> Name
-> Mult
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches UserTypeCtxt
ctxt Name
fun_name Mult
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys ExpRhoType
exp_ty
= Bool
-> SDoc
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition MatchGroup GhcRn (LHsExpr GhcRn)
matches) (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches) (TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do {
arity <- MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM VisArity
forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches
; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
; (wrap_fun, r)
<- matchExpectedFunTys herald ctxt arity exp_ty $ \ [ExpPatType]
pat_tys ExpRhoType
rhs_ty ->
Mult
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcFunBindMatches 2" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt, [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
invis_pat_tys
, [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
pat_tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
rhs_ty ])
; TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody ([ExpPatType]
invis_pat_tys [ExpPatType] -> [ExpPatType] -> [ExpPatType]
forall a. [a] -> [a] -> [a]
++ [ExpPatType]
pat_tys) ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches }
; return (wrap_fun, r) }
where
herald :: ExpectedFunTyOrigin
herald = TypedThing
-> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
ExpectedFunTyMatches (Name -> TypedThing
NameThing Name
fun_name) MatchGroup GhcRn (LHsExpr GhcRn)
matches
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts })
= Bool -> Bool
not ([GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts) Bool -> Bool -> Bool
&& (GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Bool)
-> [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Bool
forall {l} {p} {body}. GenLocated l (Match p body) -> Bool
is_fun_rhs [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts
where
is_fun_rhs :: GenLocated l (Match p body) -> Bool
is_fun_rhs (L l
_ (Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt = FunRhs {} })) = Bool
True
is_fun_rhs GenLocated l (Match p body)
_ = Bool
False
tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches :: HsExpr GhcRn
-> HsLamVariant
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr GhcRn
e HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys ExpRhoType
res_ty
= do { arity <- MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM VisArity
forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches
; (wrapper, r)
<- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ [ExpPatType]
pat_tys ExpRhoType
rhs_ty ->
TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tc_body ([ExpPatType]
invis_pat_tys [ExpPatType] -> [ExpPatType] -> [ExpPatType]
forall a. [a] -> [a] -> [a]
++ [ExpPatType]
pat_tys) ExpRhoType
rhs_ty MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches
; return (wrapper, r) }
where
herald :: ExpectedFunTyOrigin
herald = HsLamVariant -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTyLam HsLamVariant
lam_variant HsExpr GhcRn
e
tc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tc_body | Origin -> Bool
isDoExpansionGenerated (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> XMG GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall p body. MatchGroup p body -> XMG p body
mg_ext MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches)
= LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC
| Bool
otherwise
= LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody
tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))
=> TcMatchAltChecker body
-> Scaled TcSigmaTypeFRR
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> Scaled Mult
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches TcMatchAltChecker body
tc_body (Scaled Mult
scrut_mult Mult
scrut_ty) MatchGroup GhcRn (LocatedA (body GhcRn))
matches ExpRhoType
res_ty
= TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchAltChecker body
tc_body [Scaled ExpRhoType -> ExpPatType
ExpFunPatTy (Mult -> ExpRhoType -> Scaled ExpRhoType
forall a. Mult -> a -> Scaled a
Scaled Mult
scrut_mult (Mult -> ExpRhoType
mkCheckExpType Mult
scrut_ty))] ExpRhoType
res_ty MatchGroup GhcRn (LocatedA (body GhcRn))
matches
tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat :: Mult
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Mult
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpRhoType
res_ty
= Mult
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatBindRhs LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody GRHSs GhcRn (LHsExpr GhcRn)
GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss ExpRhoType
res_ty
type TcMatchAltChecker 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)))] ~ SrcSpanAnnLW
, Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnLW
, Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO
, Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
)
tcMatches :: (AnnoBody body, Outputable (body GhcTc))
=> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
l [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcRn (LocatedA (body GhcRn))
origin })
| [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
= do { UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; pat_tys <- (Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> [Scaled ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled Mult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
scaledExpTypeToType ([ExpPatType] -> [Scaled ExpRhoType]
filter_out_forall_pat_tys [ExpPatType]
pat_tys)
; rhs_ty <- expTypeToType rhs_ty
; return (MG { mg_alts = L l []
, mg_ext = MatchGroupTc pat_tys rhs_ty origin
}) }
| Bool
otherwise
= do { umatches <- (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
-> [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(UsageEnv,
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcM (GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
-> (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> TcM
(GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc)))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated SrcSpanAnnA (Match GhcTc (LocatedA (body GhcTc))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty) [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
; let (usages, matches') = unzip umatches
; tcEmitBindingUsage $ supUEs usages
; pat_tys <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys)
; rhs_ty <- readExpType rhs_ty
; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty)
; return (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc pat_tys rhs_ty origin
}) }
where
filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR]
filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpRhoType]
filter_out_forall_pat_tys = (ExpPatType -> Maybe (Scaled ExpRhoType))
-> [ExpPatType] -> [Scaled ExpRhoType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ExpPatType -> Maybe (Scaled ExpRhoType)
match_fun_pat_ty
where
match_fun_pat_ty :: ExpPatType -> Maybe (Scaled ExpRhoType)
match_fun_pat_ty (ExpFunPatTy Scaled ExpRhoType
t) = Scaled ExpRhoType -> Maybe (Scaled ExpRhoType)
forall a. a -> Maybe a
Just Scaled ExpRhoType
t
match_fun_pat_ty ExpForAllPatTy{} = Maybe (Scaled ExpRhoType)
forall a. Maybe a
Nothing
tcMatch :: (AnnoBody body)
=> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch :: forall (body :: * -> *).
AnnoBody body =>
TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
tcMatch TcMatchAltChecker body
tc_body [ExpPatType]
pat_tys ExpRhoType
rhs_ty LMatch GhcRn (LocatedA (body GhcRn))
match
= do { (L loc r) <- (Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc))))
-> LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> TcRn (LocatedA (Match GhcTc (LocatedA (body GhcTc))))
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA ([ExpPatType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
tc_match [ExpPatType]
pat_tys ExpRhoType
rhs_ty) LMatch GhcRn (LocatedA (body GhcRn))
LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match
; return (L loc r) }
where
tc_match :: [ExpPatType]
-> ExpRhoType
-> Match GhcRn (LocatedA (body GhcRn))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
tc_match [ExpPatType]
pat_tys ExpRhoType
rhs_ty
match :: Match GhcRn (LocatedA (body GhcRn))
match@(Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcRn))
ctxt, m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
l [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LocatedA (body GhcRn))
grhss })
= TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
add_match_ctxt (TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc))))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { (pats', (grhss')) <- HsMatchContextRn
-> [LPat GhcRn]
-> [ExpPatType]
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc)))
forall a.
HsMatchContextRn
-> [LPat GhcRn] -> [ExpPatType] -> TcM a -> TcM ([LPat GhcTc], a)
tcMatchPats HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContextRn
ctxt [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats [ExpPatType]
pat_tys (TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc))))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body GRHSs GhcRn (LocatedA (body GhcRn))
grhss ExpRhoType
rhs_ty
; return (Match { m_ext = noExtField
, m_ctxt = ctxt
, m_pats = L l pats'
, m_grhss = grhss' }) }
where
add_match_ctxt :: TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
add_match_ctxt TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside = case HsMatchContext (LIdP (NoGhcTc GhcRn))
ctxt of
LamAlt HsLamVariant
LamSingle -> TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside
StmtCtxt (HsDoStmt{}) -> TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside
HsMatchContext (LIdP (NoGhcTc GhcRn))
_ -> SDoc
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatchInCtxt Match GhcRn (LocatedA (body GhcRn))
match) TcM (Match GhcTc (LocatedA (body GhcTc)))
thing_inside
tcGRHSs :: AnnoBody body
=> HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
tcGRHSs HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body (GRHSs XCGRHSs GhcRn (LocatedA (body GhcRn))
_ [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss HsLocalBinds GhcRn
binds) ExpRhoType
res_ty
= do { (binds', grhss') <- HsLocalBinds GhcRn
-> TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> TcM
(HsLocalBinds GhcTc,
[GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> TcM
(HsLocalBinds GhcTc,
[GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]))
-> TcM [GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))]
-> TcM
(HsLocalBinds GhcTc,
[GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall a b. (a -> b) -> a -> b
$ do
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss ExpRhoType
res_ty
; return (GRHSs emptyComments grhss' binds') }
tcGRHSList :: forall body. AnnoBody body
=> HsMatchContextRn -> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))] -> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body [LGRHS GhcRn (LocatedA (body GhcRn))]
grhss ExpRhoType
res_ty
= do { (usages, grhss') <- (GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> [GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([UsageEnv],
[GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))))
-> GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv, GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
tc_alt) [LGRHS GhcRn (LocatedA (body GhcRn))]
[GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))]
grhss
; tcEmitBindingUsage $ supUEs usages
; return grhss' }
where
stmt_ctxt :: HsStmtContext (GenLocated SrcSpanAnnN Name)
stmt_ctxt = HsMatchContext (GenLocated SrcSpanAnnN Name)
-> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn -> HsStmtContext fn
PatGuard HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt
tc_alt :: GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
tc_alt :: GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
tc_alt (GRHS XCGRHS GhcRn (LocatedA (body GhcRn))
_ [GuardLStmt GhcRn]
guards LocatedA (body GhcRn)
rhs)
= TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { (guards', rhs')
<- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
stmt_ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc)))
-> (ExpRhoType -> TcM (LocatedA (body GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))], LocatedA (body GhcTc))
forall a b. (a -> b) -> a -> b
$
TcMatchAltChecker body
tc_body LocatedA (body GhcRn)
rhs
; return (GRHS noAnn guards' rhs') }
tcDoStmts :: HsDoFlavour
-> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcDoStmts :: HsDoFlavour
-> LocatedLW [GuardLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
ListComp (L SrcSpanAnnLW
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { res_ty <- ExpRhoType -> TcM Mult
expTypeToType ExpRhoType
res_ty
; (co, elt_ty) <- matchExpectedListTy res_ty
; let list_ty = Mult -> Mult
mkListTy Mult
elt_ty
; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts doExpr :: HsDoFlavour
doExpr@(DoExpr Maybe ModuleName
_) ss :: LocatedLW [GuardLStmt GhcRn]
ss@(L SrcSpanAnnLW
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { isApplicativeDo <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ApplicativeDo
; if isApplicativeDo
then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty doExpr (L l stmts')) }
else do { expanded_expr <- expandDoStmts doExpr stmts
; mkExpandedExprTc (HsDo noExtField doExpr ss) <$>
tcExpr (unLoc expanded_expr) res_ty }
}
tcDoStmts mDoExpr :: HsDoFlavour
mDoExpr@(MDoExpr Maybe ModuleName
_) ss :: LocatedLW [GuardLStmt GhcRn]
ss@(L SrcSpanAnnLW
_ [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { expanded_expr <- HsDoFlavour -> [GuardLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts HsDoFlavour
mDoExpr [GuardLStmt GhcRn]
stmts
; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$>
tcExpr (unLoc expanded_expr) res_ty }
tcDoStmts HsDoFlavour
MonadComp (L SrcSpanAnnLW
l [GuardLStmt GhcRn]
stmts) ExpRhoType
res_ty
= do { stmts' <- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
MonadComp) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MonadComp (L l stmts')) }
tcDoStmts ctxt :: HsDoFlavour
ctxt@HsDoFlavour
GhciStmtCtxt LocatedLW [GuardLStmt GhcRn]
_ ExpRhoType
_ = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmts" (HsDoFlavour -> SDoc
pprHsDoFlavour HsDoFlavour
ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody LHsExpr GhcRn
body ExpRhoType
res_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcBody" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr LHsExpr GhcRn
body ExpRhoType
res_ty
}
tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBodyNC LHsExpr GhcRn
body ExpRhoType
res_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcBodyNC" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
body ExpRhoType
res_ty
}
type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
= forall thing. HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
tcStmts :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts :: forall (body :: * -> *) rho_type.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
tcStmts HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty
= do { (stmts', _) <- HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcRn ())
-> TcM
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], ())
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty ((rho_type -> TcRn ())
-> TcM
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], ()))
-> (rho_type -> TcRn ())
-> TcM
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], ())
forall a b. (a -> b) -> a -> b
$
TcRn () -> rho_type -> TcRn ()
forall a b. a -> b -> a
const (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
; return stmts' }
tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen :: forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
_ TcStmtChecker body rho_type
_ [] rho_type
res_ty rho_type -> TcM thing
thing_inside
= do { thing <- rho_type -> TcM thing
thing_inside rho_type
res_ty
; return ([], thing) }
tcStmtsAndThen HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpanAnnA
loc (LetStmt XLetStmt GhcRn GhcRn (LocatedA (body GhcRn))
x HsLocalBinds GhcRn
binds) : [LStmt GhcRn (LocatedA (body GhcRn))]
stmts)
rho_type
res_ty rho_type -> TcM thing
thing_inside
= do { (binds', (stmts',thing)) <- HsLocalBinds GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> TcM
(HsLocalBinds GhcTc,
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty rho_type -> TcM thing
thing_inside
; return (L loc (LetStmt x binds') : stmts', thing) }
tcStmtsAndThen HsStmtContextRn
ctxt TcStmtChecker body rho_type
stmt_chk (L SrcSpanAnnA
loc StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt : [LStmt GhcRn (LocatedA (body GhcRn))]
stmts) rho_type
res_ty rho_type -> TcM thing
thing_inside
| XStmtLR ApplicativeStmt{} <- StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt
= do { (stmt', (stmts', thing)) <-
HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContextRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty ((rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty' ((rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing))
-> (rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing)
forall a b. (a -> b) -> a -> b
$
rho_type -> TcM thing
thing_inside
; return (L loc stmt' : stmts', thing) }
| Bool
otherwise
= do { (stmt', (stmts', thing)) <-
SrcSpanAnnA
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) fn body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable fn,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext fn -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt) (TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
TcStmtChecker body rho_type
stmt_chk HsStmtContextRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
stmt rho_type
res_ty ((rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)))
-> (rho_type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> TcM
(StmtLR GhcTc GhcTc (LocatedA (body GhcTc)),
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$ \ rho_type
res_ty' ->
IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a. TcM a -> TcM a
popErrCtxt (IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))],
thing)
forall a b. (a -> b) -> a -> b
$
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing)
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)), thing)
TcStmtChecker body rho_type
stmt_chk [LStmt GhcRn (LocatedA (body GhcRn))]
stmts rho_type
res_ty' ((rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing))
-> (rho_type -> TcM thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([XRec GhcTc (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))], thing)
forall a b. (a -> b) -> a -> b
$
rho_type -> TcM thing
thing_inside
; return (L loc stmt' : stmts', thing) }
tcGuardStmt :: TcExprStmtChecker
tcGuardStmt :: TcStmtChecker HsExpr ExpRhoType
tcGuardStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
guard SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { guard' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
guard Mult
boolTy
; thing <- thing_inside res_ty
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do {
(rhs', rhs_ty) <- Mult -> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult))
-> TcM (LHsExpr GhcTc, Mult) -> TcM (LHsExpr GhcTc, Mult)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
tcInferRhoNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty
; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (unrestricted rhs_ty) $
thing_inside res_ty
; return (mkTcBindStmt pat' rhs', thing) }
tcGuardStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcGuardStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)
tcLcStmt :: TyCon
-> TcExprStmtChecker
tcLcStmt :: TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
_ HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= do { body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body ExpRhoType
elt_ty
; thing <- thing_inside (panic "tcLcStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
tcLcStmt TyCon
m_tc HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= do { pat_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
tcScalingUsage ManyTy $
thing_inside elt_ty
; return (mkTcBindStmt pat' rhs', thing) }
tcLcStmt TyCon
_ HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= do { rhs' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
boolTy
; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty
; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcLcStmt TyCon
m_tc HsStmtContextRn
ctxt (ParStmt XParStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
_ SyntaxExpr GhcRn
_) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= Mult
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$
do { env <- RnM LocalRdrEnv
getLocalRdrEnv
; (pairs', thing) <- loop env [] bndr_stmts_s
; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
where
loop :: LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop LocalRdrEnv
_ [Name]
allBinds [] = do { thing <- [Name] -> TcM thing -> TcM thing
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
allBinds (TcM thing -> TcM thing) -> TcM thing -> TcM thing
forall a b. (a -> b) -> a -> b
$ ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty
; return ([], thing) }
loop LocalRdrEnv
origEnv [Name]
priorBinds (ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
_ : [ParStmtBlock GhcRn GhcRn]
pairs)
= do { (stmts', (ids, pairs', thing))
<- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
elt_ty ((ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType -> TcM ([Id], [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
_elt_ty' ->
do { ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
; (pairs', thing) <- setLocalRdrEnv origEnv $
loop origEnv (names ++ priorBinds) pairs
; return (ids, pairs', thing) }
; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
tcLcStmt TyCon
m_tc HsStmtContextRn
ctxt (TransStmt { trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form, trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts
, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcRn, IdP GhcRn)]
bindersMap
, trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using }) ExpRhoType
elt_ty ExpRhoType -> TcM thing
thing_inside
= Mult
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
ManyTy (IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a b. (a -> b) -> a -> b
$
do { let ([Name]
bndr_names, [Name]
n_bndr_names) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap
unused_ty :: ExpRhoType
unused_ty = String -> SDoc -> ExpRhoType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: inner ty" ([(Name, Name)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(IdP GhcRn, IdP GhcRn)]
[(Name, Name)]
bindersMap)
; (stmts', (bndr_ids, by'))
<- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn -> HsStmtContext fn
TransStmtCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt) (TyCon -> TcStmtChecker HsExpr ExpRhoType
tcLcStmt TyCon
m_tc) [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts ExpRhoType
unused_ty ((ExpRhoType -> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult))))
-> (ExpRhoType
-> TcM ([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], Maybe (LocatedA (HsExpr GhcTc), Mult)))
forall a b. (a -> b) -> a -> b
$ \ExpRhoType
_ -> do
{ by' <- (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (LocatedA (HsExpr GhcTc), Mult))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Mult)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult)
tcInferRho Maybe (LHsExpr GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by
; bndr_ids <- tcLookupLocalIds bndr_names
; return (bndr_ids, by') }
; let m_app Mult
ty = TyCon -> [Mult] -> Mult
mkTyConApp TyCon
m_tc [Mult
ty]
; let n_app = case TransForm
form of
TransForm
ThenForm -> (\Mult
ty -> Mult
ty)
TransForm
_ -> Mult -> Mult
m_app
by_arrow :: Type -> Type
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 HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
e_ty) HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
ty
tup_ty = [Id] -> Mult
HasDebugCallStack => [Id] -> Mult
mkBigCoreVarTupTy [Id]
bndr_ids
poly_arg_ty = Mult -> Mult
m_app Mult
alphaTy
poly_res_ty = Mult -> Mult
m_app (Mult -> Mult
n_app Mult
alphaTy)
using_poly_ty = Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult
poly_arg_ty HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
poly_res_ty
; using' <- tcCheckPolyExpr using using_poly_ty
; let final_using = (HsExpr GhcTc -> HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) LocatedA (HsExpr GhcTc)
using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr Name
n_bndr_name Id
bndr_id = HasDebugCallStack => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
idType Id
bndr_id))
n_bndr_ids = (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Id -> Id
mk_n_bndr [Name]
n_bndr_names [Id]
bndr_ids
bindersMap' = [Id]
bndr_ids [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
n_bndr_ids
; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = fmap fst by', trS_using = final_using
, trS_ret = noSyntaxExpr
, trS_bind = noSyntaxExpr
, trS_fmap = noExpr
, trS_ext = unitTy
, trS_form = form }, thing) }
tcLcStmt TyCon
_ HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLcStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)
tcMcStmt :: TcExprStmtChecker
tcMcStmt :: TcStmtChecker HsExpr ExpRhoType
tcMcStmt HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
return_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { (body', return_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
return_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult] -> [Mult] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
a_ty] [Mult
mult]->
Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Mult
a_ty
; thing <- thing_inside (panic "tcMcStmt: thing_inside")
; return (LastStmt x body' noret return_op', thing) }
tcMcStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbsrn LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbsrn)
[SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), thing, Mult),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult, Mult
pat_mult] ->
do { rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) }
; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty
; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
MCompPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty
; let xbstc = XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
, xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
, xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
}
; return (BindStmt xbstc pat' rhs', thing) }
tcMcStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
guard_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do {
; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc))
-> TcM
((thing, LocatedA (HsExpr GhcTc), Mult, Mult, Mult, SyntaxExprTc),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult, Mult
fun_mult] ->
do { ((rhs', test_ty), guard_op')
<- Mult
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
MCompOrigin SyntaxExpr GhcRn
SyntaxExprRn
guard_op [SyntaxOpType
SynAny]
(Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty) (([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc), Mult))
-> TcM ((LocatedA (HsExpr GhcTc), Mult), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
test_ty] [Mult
test_mult] -> do
rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
test_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
test_ty
return $ (rhs', test_ty)
; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }
; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty
; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty
; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty
; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
tcMcStmt HsStmtContextRn
ctxt (TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcRn]
stmts, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcRn, IdP GhcRn)]
bindersMap
, trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcRn)
by, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcRn
using, trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form
, trS_ret :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_ret = SyntaxExpr GhcRn
return_op, trS_bind :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_bind = SyntaxExpr GhcRn
bind_op
, trS_fmap :: forall idL idR body. StmtLR idL idR body -> HsExpr idR
trS_fmap = HsExpr GhcRn
fmap_op }) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { m1_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
; m2_ty <- newFlexiTyVarTy typeToTypeKind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
; by_e_ty <- newFlexiTyVarTy liftedTypeKind
; n_app <- case form of
TransForm
ThenForm -> (Mult -> Mult) -> IOEnv (Env TcGblEnv TcLclEnv) (Mult -> Mult)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (\Mult
ty -> Mult
ty)
TransForm
_ -> do { n_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
; return (n_ty `mkAppTy`) }
; let by_arrow :: Type -> Type
by_arrow = case Maybe (LHsExpr GhcRn)
by of
Maybe (LHsExpr GhcRn)
Nothing -> \Mult
res -> Mult
res
Just {} -> \Mult
res -> (Mult
alphaTy HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
by_e_ty) HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
res
poly_arg_ty = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy
using_arg_ty = Mult
m1_ty Mult -> Mult -> Mult
`mkAppTy` Mult
tup_ty
poly_res_ty = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
alphaTy
using_res_ty = Mult
m2_ty Mult -> Mult -> Mult
`mkAppTy` Mult -> Mult
n_app Mult
tup_ty
using_poly_ty = Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult -> Mult
by_arrow (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Mult
poly_arg_ty HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
poly_res_ty
; let (bndr_names, n_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', return_op')) <-
tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
(mkCheckExpType using_arg_ty) $ \ExpRhoType
res_ty' -> do
{ by' <- case Maybe (LHsExpr GhcRn)
by of
Maybe (LHsExpr GhcRn)
Nothing -> Maybe (LocatedA (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LocatedA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LocatedA (HsExpr GhcTc))
forall a. Maybe a
Nothing
Just LHsExpr GhcRn
e -> do { e' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
e Mult
by_e_ty
; return (Just e') }
; bndr_ids <- tcLookupLocalIds bndr_names
; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
[synKnownType (mkBigCoreVarTupTy bndr_ids)]
res_ty' $ \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; return (bndr_ids, by', return_op') }
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
[ synKnownType using_res_ty
, synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ]
res_ty $ \ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; fmap_op' <- case form of
TransForm
ThenForm -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
forall (p :: Pass). HsExpr (GhcPass p)
noExpr
TransForm
_ -> (LocatedA (HsExpr GhcTc) -> HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocatedA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc (IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc))
-> TcM (HsExpr GhcTc))
-> (Mult
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsExpr GhcTc)))
-> Mult
-> TcM (HsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcRn
fmap_op) (Mult -> TcM (HsExpr GhcTc)) -> Mult -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
Id -> Mult -> Mult
mkInfForAllTy Id
alphaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
Id -> Mult -> Mult
mkInfForAllTy Id
betaTyVar (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
(Mult
alphaTy HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
betaTy)
HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
alphaTy)
HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany` (Mult -> Mult
n_app Mult
betaTy)
; using' <- tcCheckPolyExpr using using_poly_ty
; let final_using = (HsExpr GhcTc -> HsExpr GhcTc)
-> LocatedA (HsExpr GhcTc) -> LocatedA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (Mult -> HsWrapper
WpTyApp Mult
tup_ty)) LocatedA (HsExpr GhcTc)
using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr Name
n_bndr_name Id
bndr_id = HasDebugCallStack => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n_bndr_name Mult
ManyTy (Mult -> Mult
n_app (Id -> Mult
idType Id
bndr_id))
n_bndr_ids = String -> (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"tcMcStmt" Name -> Id -> Id
mk_n_bndr [Name]
n_bndr_names [Id]
bndr_ids
bindersMap' = [Id]
bndr_ids [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
n_bndr_ids
; thing <- tcExtendIdEnv n_bndr_ids $
thing_inside (mkCheckExpType new_res_ty)
; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = by', trS_using = final_using
, trS_ret = return_op', trS_bind = bind_op'
, trS_ext = n_app tup_ty
, trS_fmap = fmap_op', trS_form = form }, thing) }
tcMcStmt HsStmtContextRn
ctxt (ParStmt XParStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [ParStmtBlock GhcRn GhcRn]
bndr_stmts_s HsExpr GhcRn
mzip_op SyntaxExpr GhcRn
bind_op) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { m_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
typeToTypeKind
; let mzip_ty = [Id] -> Mult -> Mult
mkInfForAllTys [Id
alphaTyVar, Id
betaTyVar] (Mult -> Mult) -> Mult -> Mult
forall a b. (a -> b) -> a -> b
$
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
alphaTy)
HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` Mult
betaTy)
HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
`mkVisFunTyMany`
(Mult
m_ty Mult -> Mult -> Mult
`mkAppTy` [Mult] -> Mult
mkBoxedTupleTy [Mult
alphaTy, Mult
betaTy])
; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty
; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
[ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
; let tup_tys = [ [Mult] -> Mult
HasDebugCallStack => [Mult] -> Mult
mkBigCoreTupTy [Mult]
id_tys | [Mult]
id_tys <- [[Mult]]
id_tys_s ]
tuple_ty = [Mult] -> Mult
forall {t :: * -> *}. Foldable t => t Mult -> Mult
mk_tuple_ty [Mult]
tup_tys
; (((blocks', thing), inner_res_ty), bind_op')
<- tcSyntaxOp MCompOrigin bind_op
[ synKnownType (m_ty `mkAppTy` tuple_ty)
, SynFun (synKnownType tuple_ty) SynRho ] res_ty $
\ [Mult
inner_res_ty] [Mult]
_ ->
do { 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
; return (stuff, inner_res_ty) }
; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
where
mk_tuple_ty :: t Mult -> Mult
mk_tuple_ty t Mult
tys = (Mult -> Mult -> Mult) -> t Mult -> Mult
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Mult
tn Mult
tm -> [Mult] -> Mult
mkBoxedTupleTy [Mult
tn, Mult
tm]) t Mult
tys
loop :: Mult
-> ExpRhoType
-> [Mult]
-> [ParStmtBlock GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
loop Mult
_ ExpRhoType
inner_res_ty [] [] = do { thing <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
inner_res_ty
; return ([], 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
; (stmts', (ids, return_op', pairs', thing))
<- HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcMcStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
m_tup_ty) ((ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing)))
-> (ExpRhoType
-> TcM ([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
([Id], SyntaxExprTc, [ParStmtBlock GhcTc GhcTc], thing))
forall a b. (a -> b) -> a -> b
$
\ExpRhoType
m_tup_ty' ->
do { ids <- [Name] -> TcM [Id]
tcLookupLocalIds [IdP GhcRn]
[Name]
names
; let tup_ty = [Id] -> Mult
HasDebugCallStack => [Id] -> Mult
mkBigCoreVarTupTy [Id]
ids
; (_, return_op') <-
tcSyntaxOp MCompOrigin return_op
[synKnownType tup_ty] m_tup_ty' $
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
; return (ids, return_op', pairs', thing) }
; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
loop Mult
_ ExpRhoType
_ [Mult]
_ [ParStmtBlock GhcRn GhcRn]
_ = String
-> IOEnv
(Env TcGblEnv TcLclEnv) ([ParStmtBlock GhcTc GhcTc], thing)
forall a. HasCallStack => String -> a
panic String
"tcMcStmt.loop"
tcMcStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMcStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)
tcDoStmt :: TcExprStmtChecker
tcDoStmt :: TcStmtChecker HsExpr ExpRhoType
tcDoStmt HsStmtContextRn
_ (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
body Maybe Bool
noret SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { body' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
body ExpRhoType
res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
tcDoStmt HsStmtContextRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbsrn LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do {
((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin (XBindStmtRn -> SyntaxExpr GhcRn
xbsrn_bindOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbsrn) [SyntaxOpType
SynRho, SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun SyntaxOpType
SynAny SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM
(Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing))
-> TcM
((Mult, LocatedA (HsExpr GhcTc), Mult,
GenLocated SrcSpanAnnA (Pat GhcTc), Mult, thing),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
pat_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult,Mult
pat_mult] ->
do { rhs' <-Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) }
; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty
; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
new_res_ty
; let xbstc = XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
SyntaxExprTc
bind_op'
, xbstc_boundResultType :: Mult
xbstc_boundResultType = Mult
new_res_ty
, xbstc_boundResultMult :: Mult
xbstc_boundResultMult = Mult
pat_mult
, xbstc_failOp :: FailOperator GhcTc
xbstc_failOp = FailOperator GhcTc
Maybe SyntaxExprTc
fail_op'
}
; return (BindStmt xbstc pat' rhs', thing) }
tcDoStmt HsStmtContextRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
_) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do {
; ((rhs', rhs_ty, new_res_ty, thing), then_op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM ((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
then_op [SyntaxOpType
SynRho, SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM
((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc))
-> ([Mult]
-> [Mult] -> TcM (LocatedA (HsExpr GhcTc), Mult, Mult, thing))
-> TcM ((LocatedA (HsExpr GhcTc), Mult, Mult, thing), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty, Mult
new_res_ty] [Mult
rhs_mult,Mult
fun_mult] ->
do { rhs' <- Mult -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs Mult
rhs_ty
; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
; return (rhs', rhs_ty, new_res_ty, thing) }
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty
; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
tcDoStmt HsStmtContextRn
ctxt (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnLW
l [GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcRn]
later_names
, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcRn]
rec_names, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcRn
ret_op
, recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcRn
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcRn
bind_op })
ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { let tup_names :: [IdP GhcRn]
tup_names = [IdP GhcRn]
rec_names [IdP GhcRn] -> [IdP GhcRn] -> [IdP GhcRn]
forall a. [a] -> [a] -> [a]
++ (IdP GhcRn -> Bool) -> [IdP GhcRn] -> [IdP GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcRn -> [IdP GhcRn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcRn]
rec_names) [IdP GhcRn]
later_names
; tup_elt_tys <- VisArity -> Mult -> IOEnv (Env TcGblEnv TcLclEnv) [Mult]
newFlexiTyVarTys ([Name] -> VisArity
forall a. [a] -> VisArity
forall (t :: * -> *) a. Foldable t => t a -> VisArity
length [IdP GhcRn]
[Name]
tup_names) Mult
liftedTypeKind
; let tup_ids = (Name -> Mult -> Id) -> [Name] -> [Mult] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Mult
t -> HasDebugCallStack => Name -> Mult -> Mult -> Id
Name -> Mult -> Mult -> Id
mkLocalId Name
n Mult
ManyTy Mult
t) [IdP GhcRn]
[Name]
tup_names [Mult]
tup_elt_tys
tup_ty = [Mult] -> Mult
HasDebugCallStack => [Mult] -> Mult
mkBigCoreTupTy [Mult]
tup_elt_tys
; tcExtendIdEnv tup_ids $ do
{ ((stmts', (ret_op', tup_rets)), stmts_ty)
<- tcInfer $ \ ExpRhoType
exp_ty ->
HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc]))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen HsStmtContextRn
ctxt HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
[GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts ExpRhoType
exp_ty ((ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc])))
-> (ExpRhoType -> TcM (SyntaxExprTc, [HsExpr GhcTc]))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(SyntaxExprTc, [HsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
inner_res_ty ->
do { tup_rets <- (Name -> ExpRhoType -> TcM (HsExpr GhcTc))
-> [Name]
-> [ExpRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExpr GhcTc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId [IdP GhcRn]
[Name]
tup_names
((Mult -> ExpRhoType) -> [Mult] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map Mult -> ExpRhoType
mkCheckExpType [Mult]
tup_elt_tys)
; (_, ret_op')
<- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
inner_res_ty $ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; return (ret_op', tup_rets) }
; ((_, mfix_op'), mfix_res_ty)
<- tcInfer $ \ ExpRhoType
exp_ty ->
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
mfix_op
[Mult -> SyntaxOpType
synKnownType (HasDebugCallStack => Mult -> Mult -> Mult
Mult -> Mult -> Mult
mkVisFunTyMany Mult
tup_ty Mult
stmts_ty)] ExpRhoType
exp_ty (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; ((thing, new_res_ty), bind_op')
<- tcSyntaxOp DoOrigin bind_op
[ synKnownType mfix_res_ty
, SynFun (synKnownType tup_ty) SynRho ]
res_ty $
\ [Mult
new_res_ty] [Mult]
_ ->
do { thing <- ExpRhoType -> TcM thing
thing_inside (Mult -> ExpRhoType
mkCheckExpType Mult
new_res_ty)
; return (thing, new_res_ty) }
; let rec_ids = [Name] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
takeList [IdP GhcRn]
[Name]
rec_names [Id]
tup_ids
; later_ids <- tcLookupLocalIds later_names
; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
ppr later_ids <+> ppr (map idType later_ids)]
; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
, recS_ext = RecStmtTc
{ recS_bind_ty = new_res_ty
, recS_later_rets = []
, recS_rec_rets = tup_rets
, recS_ret_ty = stmts_ty} }, thing)
}}
tcDoStmt HsStmtContextRn
ctxt (XStmtLR (ApplicativeStmt XApplicativeStmt GhcRn GhcRn
_ [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs FailOperator GhcRn
mb_join)) ExpRhoType
res_ty ExpRhoType -> TcM thing
thing_inside
= do { let tc_app_stmts :: ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts ExpRhoType
ty = HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall t.
HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContextRn
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
ty ((Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> (Mult -> TcM thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$
ExpRhoType -> TcM thing
thing_inside (ExpRhoType -> TcM thing)
-> (Mult -> ExpRhoType) -> Mult -> TcM thing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mult -> ExpRhoType
mkCheckExpType
; ((pairs', body_ty, thing), mb_join') <- case FailOperator GhcRn
mb_join of
FailOperator GhcRn
Nothing -> (, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts ExpRhoType
res_ty
Just SyntaxExpr GhcRn
join_op ->
(SyntaxExprTc -> Maybe SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just ((([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> (([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(SyntaxExprTc, ApplicativeArg GhcTc)], Mult, thing),
Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult]
-> [Mult]
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM
(([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExpr GhcRn
SyntaxExprRn
join_op [SyntaxOpType
SynRho] ExpRhoType
res_ty (([Mult]
-> [Mult]
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM
(([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc))
-> ([Mult]
-> [Mult]
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM
(([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult
rhs_ty] [Mult
rhs_mult] -> Mult
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
rhs_mult (TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing))
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
forall a b. (a -> b) -> a -> b
$ ExpRhoType
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, thing)
tc_app_stmts (Mult -> ExpRhoType
mkCheckExpType Mult
rhs_ty))
; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) }
tcDoStmt HsStmtContextRn
_ Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt ExpRhoType
_ ExpRhoType -> TcM thing
_
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDoStmt: unexpected Stmt" (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
stmt)
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
is_strict <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.Strict
comps <- getCompleteMatchesTcM
if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) pat
then return Nothing
else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
(mkCheckExpType res_ty) $ \[Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
tcApplicativeStmts
:: HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcRhoType -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
tcApplicativeStmts :: forall t.
HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (Mult -> TcM t)
-> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Mult, t)
tcApplicativeStmts HsStmtContextRn
ctxt [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs ExpRhoType
rhs_ty Mult -> TcM t
thing_inside
= do { body_ty <- Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind
; let arity = [(SyntaxExprRn, ApplicativeArg GhcRn)] -> VisArity
forall a. [a] -> VisArity
forall (t :: * -> *) a. Foldable t => t a -> VisArity
length [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
[(SyntaxExprRn, ApplicativeArg GhcRn)]
pairs
; ts <- replicateM (arity-1) $ newInferExpType
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = [Mult] -> Mult -> Mult
mkVisFunTysMany [Mult]
pat_tys Mult
body_ty
; let (ops, args) = unzip pairs
; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
thing_inside body_ty
; return (zip ops' args', body_ty, res) }
where
goOps :: Mult
-> [(SyntaxExprRn, ExpRhoType, Mult)]
-> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
goOps Mult
_ [] = [SyntaxExprTc] -> IOEnv (Env TcGblEnv TcLclEnv) [SyntaxExprTc]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
goOps Mult
t_left ((SyntaxExprRn
op,ExpRhoType
t_i,Mult
exp_ty) : [(SyntaxExprRn, ExpRhoType, Mult)]
ops)
= do { (_, op')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Mult] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
DoOrigin SyntaxExprRn
op
[Mult -> SyntaxOpType
synKnownType Mult
t_left, Mult -> SyntaxOpType
synKnownType Mult
exp_ty] ExpRhoType
t_i (([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([Mult] -> [Mult] -> TcRn ()) -> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Mult]
_ [Mult]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; t_i <- readExpType t_i
; ops' <- goOps t_i ops
; return (op' : ops') }
goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-> TcM (ApplicativeArg GhcTc)
goArg :: Mult
-> (ApplicativeArg GhcRn, Mult, Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
goArg Mult
body_ty (ApplicativeArgOne
{ xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
xarg_app_arg_one = XApplicativeArgOne GhcRn
fail_op
, app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: forall idL. ApplicativeArg idL -> LHsExpr idL
arg_expr = LHsExpr GhcRn
rhs
, Bool
is_body_stmt :: Bool
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
..
}, Mult
pat_ty, Mult
exp_ty)
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (GenLocated SrcSpanAnnA (Pat GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat) (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsStmtContext (GenLocated SrcSpanAnnN Name)
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idL :: Pass) (idR :: Pass) fn body.
(OutputableBndrId idL, OutputableBndrId idR, Outputable fn,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) =>
HsStmtContext fn -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt (LPat GhcRn
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (bodyR :: * -> *).
LPat GhcRn
-> LocatedA (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
mkRnBindStmt LPat GhcRn
pat LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs)) (IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$
do { rhs' <- LHsExpr GhcRn -> Mult -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
rhs Mult
exp_ty
; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
return ()
; fail_op' <- fmap join . forM fail_op $ \SyntaxExprRn
fail ->
CtOrigin
-> LPat GhcTc
-> SyntaxExpr GhcRn
-> Mult
-> TcRn (FailOperator GhcTc)
tcMonadFailOp (LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
pat) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SyntaxExpr GhcRn
SyntaxExprRn
fail Mult
body_ty
; return (ApplicativeArgOne
{ xarg_app_arg_one = fail_op'
, app_arg_pattern = pat'
, arg_expr = rhs'
, .. }
) }
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 { (stmts', (ret',pat')) <-
HsStmtContextRn
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> ExpRhoType
-> (ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContextRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt) HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> (ExpRhoType -> TcM thing)
-> TcM (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpRhoType
tcDoStmt [GuardLStmt GhcRn]
[LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
stmts (Mult -> ExpRhoType
mkCheckExpType Mult
exp_ty) ((ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc))))
-> (ExpRhoType
-> TcM (HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> TcM
([LStmt GhcTc (LocatedA (HsExpr GhcTc))],
(HsExpr GhcTc, GenLocated SrcSpanAnnA (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$
\ExpRhoType
res_ty -> do
{ ret' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
ret ExpRhoType
res_ty
; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
return ()
; return (ret', pat')
}
; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcTc
pat }) = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat
get_arg_bndrs (ApplicativeArgMany { bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern = LPat GhcTc
pat }) = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat
checkArgCounts :: AnnoBody body
=> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM VisArity
checkArgCounts :: forall (body :: * -> *).
AnnoBody body =>
MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM VisArity
checkArgCounts (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
_ [] })
= VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
1
checkArgCounts (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
_ (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1:[LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches) })
| [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches
= VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
n_args1
| Just NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches <- Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches
= TcRnMessage -> TcM VisArity
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM VisArity) -> TcRnMessage -> TcM VisArity
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> MatchArgBadMatches -> TcRnMessage
TcRnMatchesHaveDiffNumArgs (Match GhcRn (LocatedA (body GhcRn))
-> HsMatchContext (LIdP (NoGhcTc GhcRn))
forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt (LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> Match GhcRn (LocatedA (body GhcRn))
forall l e. GenLocated l e -> e
unLoc LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1))
(MatchArgBadMatches -> TcRnMessage)
-> MatchArgBadMatches -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ LocatedA (Match GhcRn (LocatedA (body GhcRn)))
-> NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
-> MatchArgBadMatches
forall body.
LocatedA (Match GhcRn body)
-> NonEmpty (LocatedA (Match GhcRn body)) -> MatchArgBadMatches
MatchArgMatches LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1 NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn))))
bad_matches
| Bool
otherwise
= VisArity -> TcM VisArity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return VisArity
n_args1
where
n_args1 :: VisArity
n_args1 = LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> VisArity
forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
match1
mb_bad_matches :: Maybe (NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
mb_bad_matches = [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
-> Maybe
(NonEmpty (LocatedA (Match GhcRn (LocatedA (body GhcRn)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m | LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m <- [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
matches, LocatedA (Match GhcRn (LocatedA (body GhcRn))) -> VisArity
forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match LocatedA (Match GhcRn (LocatedA (body GhcRn)))
m VisArity -> VisArity -> Bool
forall a. Eq a => a -> a -> Bool
/= VisArity
n_args1]
reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match :: forall body1. LocatedA (Match GhcRn body1) -> VisArity
reqd_args_in_match (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats })) = (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)] -> VisArity
forall a. (a -> Bool) -> [a] -> VisArity
count (Pat GhcRn -> Bool
forall p. Pat p -> Bool
isVisArgPat (Pat GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats