{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Match
( tcFunBindMatches
, tcCaseMatches
, tcLambdaMatches
, tcGRHSNE
, 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.Name.Reader (LocalRdrEnv)
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
import qualified GHC.Data.List.NonEmpty as NE
import Control.Monad
import Control.Arrow ( second )
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty (..))
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 -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ctxt:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arity:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VisArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr VisArity
arity
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"invis_pat_tys:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
invis_pat_tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pat_tys:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ExpPatType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExpPatType]
pat_tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rhs_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
rhs_ty ]
; HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
mctxt 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
mctxt :: HsMatchContext (GenLocated SrcSpanAnnN Name)
mctxt = GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
fun_name) AnnFunRhs
forall a. NoAnn a => a
noAnn
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 ->
HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt 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
ctxt :: HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt = HsLamVariant -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
lam_variant
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))
=> HsMatchContextRn
-> TcMatchAltChecker body
-> Scaled TcSigmaTypeFRR
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
HsMatchContextRn
-> TcMatchAltChecker body
-> Scaled Mult
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body (Scaled Mult
scrut_mult Mult
scrut_ty) MatchGroup GhcRn (LocatedA (body GhcRn))
matches ExpRhoType
res_ty
= HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches HsMatchContextRn
ctxt 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))
=> HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches :: forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [ExpPatType]
-> ExpRhoType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches HsMatchContextRn
ctxt 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_ty <- case [ExpPatType]
pat_tys of
[ExpFunPatTy Scaled ExpRhoType
t] -> Scaled ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
scaledExpTypeToType Scaled ExpRhoType
t
[ExpForAllPatTy ForAllTyBinder
tvb] -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult))
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> BadEmptyCaseReason -> TcRnMessage
TcRnEmptyCase HsMatchContextRn
ctxt (ForAllTyBinder -> BadEmptyCaseReason
EmptyCaseForall ForAllTyBinder
tvb)
[] -> String -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
forall a. HasCallStack => String -> a
panic String
"tcMatches: no arguments in EmptyCase"
ExpPatType
_t1:(ExpPatType
_t2:[ExpPatType]
_ts) -> String -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Mult)
forall a. HasCallStack => String -> a
panic String
"tcMatches: multiple arguments in EmptyCase"
; rhs_ty <- expTypeToType rhs_ty
; return (MG { mg_alts = L l []
, mg_ext = MatchGroupTc [pat_ty] 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))
_ -> ErrCtxtMsg
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
-> TcM (Match GhcTc (LocatedA (body GhcTc)))
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LocatedA (body GhcRn)) -> ErrCtxtMsg
forall body. Outputable body => Match GhcRn body -> ErrCtxtMsg
MatchInCtxt 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))
_ NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
grhss HsLocalBinds GhcRn
binds) ExpRhoType
res_ty
= do { (binds', grhss') <- HsLocalBinds GhcRn
-> TcM
(NonEmpty
(GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> TcM
(HsLocalBinds GhcTc,
NonEmpty (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM
(NonEmpty
(GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> TcM
(HsLocalBinds GhcTc,
NonEmpty
(GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))))
-> TcM
(NonEmpty
(GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> TcM
(HsLocalBinds GhcTc,
NonEmpty (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
forall a b. (a -> b) -> a -> b
$ do
HsMatchContextRn
-> TcMatchAltChecker body
-> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
-> ExpRhoType
-> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
-> ExpRhoType
-> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))
tcGRHSNE HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
grhss ExpRhoType
res_ty
; return (GRHSs emptyComments grhss' binds') }
tcGRHSNE :: forall body. AnnoBody body
=> HsMatchContextRn -> TcMatchAltChecker body
-> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn))) -> ExpRhoType
-> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))
tcGRHSNE :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
-> ExpRhoType
-> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))
tcGRHSNE HsMatchContextRn
ctxt TcMatchAltChecker body
tc_body NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
grhss ExpRhoType
res_ty
= do { (usages, grhss') <- NonEmpty
(UsageEnv, GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
-> (NonEmpty UsageEnv,
NonEmpty (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip (NonEmpty
(UsageEnv, GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
-> (NonEmpty UsageEnv,
NonEmpty
(GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NonEmpty
(UsageEnv,
GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NonEmpty UsageEnv,
NonEmpty (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UsageEnv,
GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> NonEmpty
(GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NonEmpty
(UsageEnv,
GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
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) -> NonEmpty a -> f (NonEmpty b)
traverse ((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) NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn)))
NonEmpty (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
$
ErrCtxtMsg
-> 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. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (HsStmtContextRn
-> StmtLR GhcRn GhcRn (LocatedA (body GhcRn)) -> ErrCtxtMsg
forall body.
(Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA, Outputable body) =>
HsStmtContextRn -> StmtLR GhcRn GhcRn body -> ErrCtxtMsg
StmtErrCtxt HsStmtContextRn
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))
_ NonEmpty (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] -> NonEmpty (ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)
loop :: LocalRdrEnv
-> [Name]
-> NonEmpty (ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), 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 $
loop1 origEnv (names ++ priorBinds) pairs
; return (ids, pairs', thing) }
; return ( ParStmtBlock x stmts' ids noSyntaxExpr :| pairs', thing ) }
loop1
:: LocalRdrEnv -> [Name] -> [ParStmtBlock GhcRn GhcRn]
-> TcM ([ParStmtBlock GhcTc GhcTc], _)
loop1 :: LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcRn GhcRn]
-> RnM ([ParStmtBlock GhcTc GhcTc], thing)
loop1 LocalRdrEnv
_ [Name]
binds [] = [ ([], thing
a) | thing
a <- [Name] -> TcM thing -> TcM thing
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
binds (ExpRhoType -> TcM thing
thing_inside ExpRhoType
elt_ty) ]
loop1 LocalRdrEnv
env [Name]
binds (ParStmtBlock GhcRn GhcRn
x:[ParStmtBlock GhcRn GhcRn]
xs) = [ (NonEmpty (ParStmtBlock GhcTc GhcTc) -> [ParStmtBlock GhcTc GhcTc]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ParStmtBlock GhcTc GhcTc)
ys, thing
a) | (NonEmpty (ParStmtBlock GhcTc GhcTc)
ys, thing
a) <- LocalRdrEnv
-> [Name]
-> NonEmpty (ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), thing)
loop LocalRdrEnv
env [Name]
binds (ParStmtBlock GhcRn GhcRn
xParStmtBlock GhcRn GhcRn
-> [ParStmtBlock GhcRn GhcRn]
-> NonEmpty (ParStmtBlock GhcRn GhcRn)
forall a. a -> [a] -> NonEmpty a
:|[ParStmtBlock GhcRn GhcRn]
xs) ]
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 (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f 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 = (Name -> Id -> Id) -> [Name] -> [Id] -> [Id]
forall a b c.
HasDebugCallStack =>
(a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual 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))
_ NonEmpty (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
; tup_tys_and_bndr_stmts_s <- traverse (\ bndr_stmts :: ParStmtBlock GhcRn GhcRn
bndr_stmts@(ParStmtBlock XParStmtBlock GhcRn GhcRn
_ [GuardLStmt GhcRn]
_ [IdP GhcRn]
names SyntaxExpr GhcRn
_) ->
[ (Mult
tup_tys, ParStmtBlock GhcRn GhcRn
bndr_stmts)
| Mult
tup_tys <- [Mult] -> Mult
HasDebugCallStack => [Mult] -> Mult
mkBigCoreTupTy ([Mult] -> Mult)
-> IOEnv (Env TcGblEnv TcLclEnv) [Mult] -> TcM Mult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> TcM Mult)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [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) -> [a] -> f [b]
traverse (TcM Mult -> Name -> TcM Mult
forall a b. a -> b -> a
const (Mult -> TcM Mult
newFlexiTyVarTy Mult
liftedTypeKind)) [IdP GhcRn]
[Name]
names ]) bndr_stmts_s
; let tuple_ty = NonEmpty Mult -> Mult
forall {t :: * -> *}. Foldable1 t => t Mult -> Mult
mk_tuple_ty (((Mult, ParStmtBlock GhcRn GhcRn) -> Mult)
-> NonEmpty (Mult, ParStmtBlock GhcRn GhcRn) -> NonEmpty Mult
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Mult, ParStmtBlock GhcRn GhcRn) -> Mult
forall a b. (a, b) -> a
fst NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
tup_tys_and_bndr_stmts_s)
; (((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
-> NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), thing)
loop Mult
m_ty (Mult -> ExpRhoType
mkCheckExpType Mult
inner_res_ty) NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
tup_tys_and_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 (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
foldr1 (\Mult
tn Mult
tm -> [Mult] -> Mult
mkBoxedTupleTy [Mult
tn, Mult
tm]) t Mult
tys
loop
:: Type -> ExpRhoType -> NonEmpty (Type, ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)
loop :: Mult
-> ExpRhoType
-> NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), thing)
loop Mult
m_ty ExpRhoType
inner_res_ty ((Mult
tup_ty_in, ParStmtBlock XParStmtBlock GhcRn GhcRn
x [GuardLStmt GhcRn]
stmts [IdP GhcRn]
names SyntaxExpr GhcRn
return_op) :| [(Mult, ParStmtBlock GhcRn GhcRn)]
xs)
= 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) <- loop1 m_ty inner_res_ty xs
; return (ids, return_op', pairs', thing) }
; return (ParStmtBlock x stmts' ids return_op' :| pairs', thing) }
loop1
:: Type -> ExpRhoType -> [(Type, ParStmtBlock GhcRn GhcRn)]
-> TcM ([ParStmtBlock GhcTc GhcTc], _)
loop1 :: Mult
-> ExpRhoType
-> [(Mult, ParStmtBlock GhcRn GhcRn)]
-> TcM ([ParStmtBlock GhcTc GhcTc], thing)
loop1 Mult
_ ExpRhoType
r [] = [ ([], thing
a) | thing
a <- ExpRhoType -> TcM thing
thing_inside ExpRhoType
r ]
loop1 Mult
m ExpRhoType
r ((Mult, ParStmtBlock GhcRn GhcRn)
x:[(Mult, ParStmtBlock GhcRn GhcRn)]
xs) = [ (NonEmpty (ParStmtBlock GhcTc GhcTc) -> [ParStmtBlock GhcTc GhcTc]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ParStmtBlock GhcTc GhcTc)
ys, thing
a) | (NonEmpty (ParStmtBlock GhcTc GhcTc)
ys, thing
a) <- Mult
-> ExpRhoType
-> NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
-> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), thing)
loop Mult
m ExpRhoType
r ((Mult, ParStmtBlock GhcRn GhcRn)
x(Mult, ParStmtBlock GhcRn GhcRn)
-> [(Mult, ParStmtBlock GhcRn GhcRn)]
-> NonEmpty (Mult, ParStmtBlock GhcRn GhcRn)
forall a. a -> [a] -> NonEmpty a
:|[(Mult, ParStmtBlock GhcRn GhcRn)]
xs) ]
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
$
ErrCtxtMsg
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (HsStmtContextRn
-> Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> ErrCtxtMsg
forall body.
(Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA, Outputable body) =>
HsStmtContextRn -> StmtLR GhcRn GhcRn body -> ErrCtxtMsg
StmtErrCtxt HsStmtContextRn
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