{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
tcCheckMonoExpr, tcCheckMonoExprNC,
tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC,
tcPolyExpr, tcExpr,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket )
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Expr ( mkExpandedExpr )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion( mkSymCo )
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.Function
import Data.List (partition, sortBy, intersect)
import qualified Data.List.NonEmpty as NE
import GHC.Data.Bag ( unitBag )
tcCheckPolyExpr, tcCheckPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTc)
tcCheckPolyExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcPolyLExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcCheckMonoExpr, tcCheckMonoExprNC
:: LHsExpr GhcRn
-> TcRhoType
-> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcMonoExpr, tcMonoExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcMonoExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcMonoExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
expr', Type
rho) <- forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }
tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRhoNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
expr', Type
rho) <- forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; (HsWrapper
wrap, HsExpr GhcTc
expr') <- forall result.
UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseExpType UserTypeCtxt
GenSigCtxt ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
res_ty ->
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr' }
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr e :: HsExpr GhcRn
e@(HsVar {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsApp {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(OpApp {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRecSel {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(XExpr (HsExpanded {})) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit) ExpRhoType
res_ty
= do { Maybe (HsOverLit GhcTc)
mb_res <- HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit HsOverLit GhcRn
lit ExpRhoType
res_ty
; case Maybe (HsOverLit GhcTc)
mb_res of
Just HsOverLit GhcTc
lit' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit forall a. EpAnn a
noAnn HsOverLit GhcTc
lit')
Maybe (HsOverLit GhcTc)
Nothing -> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty }
tcExpr (HsUnboundVar XUnboundVar GhcRn
_ RdrName
occ) ExpRhoType
res_ty
= do { Type
ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; HoleExprRef
her <- RdrName -> Type -> TcM HoleExprRef
emitNewExprHole RdrName
occ Type
ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XUnboundVar p -> RdrName -> HsExpr p
HsUnboundVar HoleExprRef
her RdrName
occ) }
tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
= do { let lit_ty :: Type
lit_ty = forall (p :: Pass). HsLit (GhcPass p) -> Type
hsLitType HsLit GhcRn
lit
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
x (forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcRn
lit)) Type
lit_ty ExpRhoType
res_ty }
tcExpr (HsPar XPar GhcRn
x LHsToken "(" GhcRn
lpar LHsExpr GhcRn
expr LHsToken ")" GhcRn
rpar) ExpRhoType
res_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar XPar GhcRn
x LHsToken "(" GhcRn
lpar GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsToken ")" GhcRn
rpar) }
tcExpr (HsPragE XPragE GhcRn
x HsPragE GhcRn
prag LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcRn
x (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpRhoType
res_ty
= do { (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', SyntaxExprTc
neg_expr')
<- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
\[Type
arg_ty] [Type
arg_mult] ->
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
arg_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
arg_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' SyntaxExprTc
neg_expr') }
tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpRhoType
res_ty
= do { Type
ip_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; let ip_name :: Type
ip_name = FastString -> Type
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; TyCoVar
ip_var <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
origin (Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
ip_name, Type
ip_ty])
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
(Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
ip_name Type
ip_ty (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA TyCoVar
ip_var)))
Type
ip_ty ExpRhoType
res_ty }
where
fromDict :: Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
x Type
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR forall a b. (a -> b) -> a -> b
$
Type -> TcCoercionR
unwrapIP forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
x,Type
ty]
origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x
tcExpr (HsLam XLam GhcRn
_ MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpRhoType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
match') <- ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda ExpectedFunTyOrigin
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
match')) }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = forall p. HsMatchContext p
LambdaExpr, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
herald :: ExpectedFunTyOrigin
herald = MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
ExpectedFunTyLam MatchGroup GhcRn (LHsExpr GhcRn)
match
tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x LamCaseVariant
lc_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches')
<- ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda ExpectedFunTyOrigin
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$ forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
x LamCaseVariant
lc_variant MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
lc_variant, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
herald :: ExpectedFunTyOrigin
herald = LamCaseVariant -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTyLamCase LamCaseVariant
lc_variant HsExpr GhcRn
e
tcExpr (ExplicitList XExplicitList GhcRn
_ [LHsExpr GhcRn]
exprs) ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
; let tc_elt :: LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt LocatedA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LocatedA (HsExpr GhcRn)
expr Type
elt_ty
; [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt [LHsExpr GhcRn]
exprs
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi forall a b. (a -> b) -> a -> b
$ forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList Type
elt_ty [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' }
tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcRn]
tup_args Boxity
boxity) ExpRhoType
res_ty
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg GhcRn]
tup_args
= do { let arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args
tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
tup_tc Type
res_ty
; let arg_tys' :: [Type]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
Boxity
Boxed -> [Type]
arg_tys
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [Type]
arg_tys'
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity) }
| Bool
otherwise
=
do { let arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args
; [Type]
arg_tys <- case Boxity
boxity of
{ Boxity
Boxed -> Int -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
newFlexiTyVarTys Int
arity Type
liftedTypeKind
; Boxity
Unboxed -> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM Type
newOpenFlexiTyVarTy }
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [Type]
arg_tys
; let expr' :: HsExpr GhcTc
expr' = forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity
missing_tys :: [Scaled Type]
missing_tys = [forall a. Type -> a -> Scaled a
Scaled Type
mult Type
ty | (Missing (Scaled Type
mult Type
_), Type
ty) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg GhcTc]
tup_args1 [Type]
arg_tys]
act_res_ty :: Type
act_res_ty = HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
missing_tys (Boxity -> [Type] -> Type
mkTupleTy1 Boxity
boxity [Type]
arg_tys)
; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (forall a. Outputable a => a -> SDoc
ppr Type
act_res_ty forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
act_res_ty ExpRhoType
res_ty }
tcExpr (ExplicitSum XExplicitSum GhcRn
_ Int
alt Int
arity LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
sum_tc Type
res_ty
;
let arg_tys' :: [Type]
arg_tys' = forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
arg_ty :: Type
arg_ty = [Type]
arg_tys' forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt forall a. Num a => a -> a -> a
- Int
1)
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
; HasDebugCallStack => FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRUnboxedSum Type
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [Type]
arg_tys' Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' ) }
tcExpr (HsLet XLet GhcRn
x LHsToken "let" GhcRn
tkLet HsLocalBinds GhcRn
binds LHsToken "in" GhcRn
tkIn LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { (HsLocalBinds GhcTc
binds', GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet XLet GhcRn
x LHsToken "let" GhcRn
tkLet HsLocalBinds GhcTc
binds' LHsToken "in" GhcRn
tkIn GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do {
Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut', Type
scrut_ty) <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
scrut
; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty)
; HasDebugCallStack => FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRCase Type
scrut_ty
; MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches' <- forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled Type
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (forall a. Type -> a -> Scaled a
Scaled Type
mult Type
scrut_ty) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut' MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = forall p. HsMatchContext p
CaseAlt,
mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsIf XIf GhcRn
x LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpRhoType
res_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred Type
boolTy
; (UsageEnv
u1,GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1') <- forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
b1 ExpRhoType
res_ty
; (UsageEnv
u2,GenLocated SrcSpanAnnA (HsExpr GhcTc)
b2') <- forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
b2 ExpRhoType
res_ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> UsageEnv -> UsageEnv
supUE UsageEnv
u1 UsageEnv
u2)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred' GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
b2') }
tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpRhoType
res_ty
= do { ([UsageEnv]
ues, [GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts') <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (\GenLocated (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
alt -> forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage forall a b. (a -> b) -> a -> b
$ forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpRhoType
res_ty) GenLocated (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
alt) [LGRHS GhcRn (LHsExpr GhcRn)]
alts
; Type
res_ty <- ExpRhoType -> TcM Type
readExpType ExpRhoType
res_ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage ([UsageEnv] -> UsageEnv
supUEs [UsageEnv]
ues)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf Type
res_ty [GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts') }
where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = forall p. HsMatchContext p
IfAlt, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsDo XDo GhcRn
_ HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
= HsDoFlavour
-> LocatedL [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts ExpRhoType
res_ty
tcExpr (HsProc XProc GhcRn
x LPat GhcRn
pat LHsCmdTop GhcRn
cmd) ExpRhoType
res_ty
= do { (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)
cmd', TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
x GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)
cmd') }
tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
co, (Type
p_ty, Type
expr_ty)) <- Type -> TcM (TcCoercionR, (Type, Type))
matchExpectedAppTy Type
res_ty
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', WantedConstraints
lie) <- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In the body of a static form:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
expr_ty
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
checkClosedInStaticForm forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet XStatic GhcRn
fvs
; Class
typeableClass <- Name -> TcM Class
tcLookupClass Name
typeableClassName
; TyCoVar
typeable_ev <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
StaticOrigin forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
[Type
liftedTypeKind, Type
expr_ty]
; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie
; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
[Type
p_ty]
; let wrap :: HsWrapper
wrap = [TyCoVar] -> HsWrapper
mkWpEvVarApps [TyCoVar
typeable_ev] HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type
expr_ty]
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; TyCon
static_ptr_ty_con <- Name -> TcM TyCon
tcLookupTyCon Name
staticPtrTyConName
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
co forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments
(forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
(forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic (XStatic GhcRn
fvs, TyCon -> [Type] -> Type
mkTyConApp TyCon
static_ptr_ty_con [Type
expr_ty]) GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'))
}
tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L SrcSpanAnnN
loc Name
con_name
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) ExpRhoType
res_ty
= do { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
con_name
; (HsExpr GhcTc
con_expr, Type
con_sigma) <- Name -> TcM (HsExpr GhcTc, Type)
tcInferId Name
con_name
; (HsWrapper
con_wrap, Type
con_tau) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
con_sigma
; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
Right ([Scaled Type]
arg_tys, Type
actual_res_ty) = Int -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN Int
arity Type
con_tau
; Bool -> TcRnMessage -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con_like) forall a b. (a -> b) -> a -> b
$
Name -> TcRnMessage
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' <- ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) HsRecordBinds GhcRn
rbinds
; let rcon_tc :: HsExpr GhcTc
rcon_tc = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr
expr' :: HsExpr GhcTc
expr' = RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = HsExpr GhcTc
rcon_tc
, rcon_con :: XRec GhcTc (ConLikeP GhcTc)
rcon_con = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc ConLike
con_like
, rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' }
; HsExpr GhcTc
ret <- HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
actual_res_ty ExpRhoType
res_ty
; ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys
; forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
ret }
where
orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
con_name
tcExpr expr :: HsExpr GhcRn
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcRn]
rbnds }) ExpRhoType
res_ty
= forall a. HasCallStack => Bool -> a -> a
assert (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LHsRecUpdField GhcRn]
rbnds) forall a b. (a -> b) -> a -> b
$
do {
; (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt) <- LHsExpr GhcRn
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
desugarRecordUpd LHsExpr GhcRn
record_expr [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
; HsExpr GhcTc
expr' <- forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
expr HsExpr GhcRn
ds_expr) (Type -> ExpRhoType
Check Type
ds_res_ty)
; forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
ds_res_ty ExpRhoType
res_ty
}
tcExpr (RecordUpd {}) ExpRhoType
_ = forall a. HasCallStack => String -> a
panic String
"tcExpr: unexpected overloaded-dot RecordUpd"
tcExpr (ArithSeq XArithSeq GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq) ExpRhoType
res_ty
= Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpRhoType
res_ty
tcExpr (HsGetField XGetField GhcRn
_ LHsExpr GhcRn
_ XRec GhcRn (DotFieldOcc GhcRn)
_) ExpRhoType
_ = forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ NonEmpty (XRec GhcRn (DotFieldOcc GhcRn))
_) ExpRhoType
_ = forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
tcExpr (HsTypedSplice XTypedSplice GhcRn
ext LHsExpr GhcRn
splice) ExpRhoType
res_ty = Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedSplice XTypedSplice GhcRn
ext LHsExpr GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsTypedBracket XTypedBracket GhcRn
_ LHsExpr GhcRn
body) ExpRhoType
res_ty = HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e LHsExpr GhcRn
body ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUntypedBracket XUntypedBracket GhcRn
ps HsQuote GhcRn
body) ExpRhoType
res_ty = HsExpr GhcRn
-> HsQuote GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsQuote GhcRn
body XUntypedBracket GhcRn
ps ExpRhoType
res_ty
tcExpr (HsUntypedSplice XUntypedSplice GhcRn
splice HsUntypedSplice GhcRn
_) ExpRhoType
res_ty
= case XUntypedSplice GhcRn
splice of
HsUntypedSpliceTop ThModFinalizers
mod_finalizers HsExpr GhcRn
expr
-> do { ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
; HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty }
HsUntypedSpliceNested {} -> forall a. HasCallStack => String -> a
panic String
"tcExpr: invalid nested splice"
tcExpr (HsOverLabel {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsOverLabel" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionL {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionL" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionR {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionR" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <-forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
elt_ty
; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromName [Type
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
enum_from Maybe SyntaxExprTc
wit' (forall id. LHsExpr id -> ArithSeqInfo id
From GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenName [Type
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
enum_from_then Maybe SyntaxExprTc
wit' (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromToName [Type
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
enum_from_to Maybe SyntaxExprTc
wit' (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2 LHsExpr GhcRn
expr3) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3' <- forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 Type
elt_ty
; HsExpr GhcTc
eft <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenToName [Type
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap forall a b. (a -> b) -> a -> b
$
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
eft Maybe SyntaxExprTc
wit' (forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3') }
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, Type
OneTy, Type
elt_ty, forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpRhoType
res_ty
= do { ((Type
elt_mult, Type
elt_ty), SyntaxExprTc
fl')
<- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
fl [SyntaxOpType
SynList] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
\ [Type
elt_ty] [Type
elt_mult] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type
elt_mult, Type
elt_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, Type
elt_mult, Type
elt_ty, forall a. a -> Maybe a
Just SyntaxExprTc
fl') }
tcTupArgs :: [HsTupArg GhcRn]
-> [TcSigmaType]
-> TcM [HsTupArg GhcTc]
tcTupArgs :: [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
args [Type]
tys
= do forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (forall a b. [a] -> [b] -> Bool
equalLength [HsTupArg GhcRn]
args [Type]
tys)
Int -> TcRn ()
checkTupSize (forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M Int -> HsTupArg GhcRn -> Type -> TcM (HsTupArg GhcTc)
go [Int
1,Int
2..] [HsTupArg GhcRn]
args [Type]
tys
where
go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
go :: Int -> HsTupArg GhcRn -> Type -> TcM (HsTupArg GhcTc)
go Int
i (Missing {}) Type
arg_ty
= do { Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; HasDebugCallStack => FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (Int -> FixedRuntimeRepContext
FRRTupleSection Int
i) Type
arg_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XMissing id -> HsTupArg id
Missing (forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty)) }
go Int
i (Present XPresent GhcRn
x LHsExpr GhcRn
expr) Type
arg_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
; HasDebugCallStack => FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (Int -> FixedRuntimeRepContext
FRRTupleArg Int
i) Type
arg_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
= forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpRhoType -> SyntaxOpType
SynType ExpRhoType
res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (HsExpr GhcTc
expr, Type
sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, Type)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan) []
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Type
sigma)
; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
<- forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty forall a b. (a -> b) -> a -> b
$
[Type] -> [Type] -> TcM a
thing_inside
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Type
sigma )
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
expr_wrap HsExpr GhcTc
expr
, syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: HsWrapper
syn_res_wrap = HsWrapper
res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [Type] -> [Type] -> TcM a
_ = forall a. HasCallStack => String -> a
panic String
"tcSyntaxOpGen"
tcSynArgE :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty SyntaxOpType
syn_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
<- forall result.
UserTypeCtxt
-> Type -> (Type -> TcM result) -> TcM (HsWrapper, result)
tcTopSkolemise UserTypeCtxt
GenSigCtxt Type
sigma_ty
(\ Type
rho_ty -> Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
syn_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
skol_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
ty_wrapper) }
where
go :: Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
SynAny
= do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynRho
= do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynList
= do { (TcCoercionR
list_co, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
; a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
elt_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
list_co) }
go Type
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
= do { ( HsWrapper
match_wrapper
, ( ( (a
result, Type
arg_ty, Type
res_ty, Type
op_mult)
, HsWrapper
res_wrapper )
, HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )
<- forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
GenSigCtxt Int
1 (Type -> ExpRhoType
mkCheckExpType Type
rho_ty) forall a b. (a -> b) -> a -> b
$
\ [Scaled ExpRhoType
arg_ty] ExpRhoType
res_ty ->
do { Type
arg_tc_ty <- ExpRhoType -> TcM Type
expTypeToType (forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
; Type
res_tc_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (case SyntaxOpType
arg_shape of
SynFun {} -> Bool
False;
SyntaxOpType
_ -> Bool
True)
(forall doc. IsLine doc => String -> doc
text String
"Too many nested arrows in SyntaxOpType" forall doc. IsDoc doc => doc -> doc -> doc
$$
CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig)
; let arg_mult :: Type
arg_mult = forall a. Scaled a -> Type
scaledMult Scaled ExpRhoType
arg_ty
; forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
arg_tc_ty [] SyntaxOpType
arg_shape forall a b. (a -> b) -> a -> b
$
\ [Type]
arg_results [Type]
arg_res_mults ->
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
res_tc_ty SyntaxOpType
res_shape forall a b. (a -> b) -> a -> b
$
\ [Type]
res_results [Type]
res_res_mults ->
do { a
result <- [Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results forall a. [a] -> [a] -> [a]
++ [Type]
res_results) ([Type
arg_mult] forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults forall a. [a] -> [a] -> [a]
++ [Type]
res_res_mults)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Type
arg_tc_ty, Type
res_tc_ty, Type
arg_mult) }}
; let fun_wrap :: HsWrapper
fun_wrap = HsWrapper -> HsWrapper -> Scaled Type -> Type -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
(forall a. Type -> a -> Scaled a
Scaled Type
op_mult Type
arg_ty) Type
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
fun_wrap) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op
go Type
rho_ty (SynType ExpRhoType
the_ty)
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> Type -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty Type
rho_ty
; a
result <- [Type] -> [Type] -> TcM a
thing_inside [] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
tcSynArgA :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [Type] -> [Type] -> TcM a
thing_inside
= do { (HsWrapper
match_wrapper, [Scaled Type]
arg_tys, Type
res_ty)
<- ExpectedFunTyOrigin
-> CtOrigin
-> Maybe TypedThing
-> Int
-> Type
-> TcM (HsWrapper, [Scaled Type], Type)
matchActualFunTysRho ExpectedFunTyOrigin
herald CtOrigin
orig forall a. Maybe a
Nothing
(forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) Type
sigma_ty
; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
<- forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [SyntaxOpType]
arg_shapes forall a b. (a -> b) -> a -> b
$ \ [Type]
arg_results [Type]
arg_res_mults ->
forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg Type
res_ty SyntaxOpType
res_shape forall a b. (a -> b) -> a -> b
$ \ [Type]
res_results ->
[Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results forall a. [a] -> [a] -> [a]
++ [Type]
res_results) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> Type
scaledMult [Scaled Type]
arg_tys forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op
tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e :: forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (Type
arg_ty : [Type]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [Type] -> [Type] -> TcM a
thing_inside
= do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
<- forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
arg_ty SyntaxOpType
arg_shape forall a b. (a -> b) -> a -> b
$ \ [Type]
arg1_results [Type]
arg1_mults ->
forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [Type]
arg_tys [SyntaxOpType]
arg_shapes forall a b. (a -> b) -> a -> b
$ \ [Type]
args_results [Type]
args_mults ->
[Type] -> [Type] -> TcM a
thing_inside ([Type]
arg1_results forall a. [a] -> [a] -> [a]
++ [Type]
args_results) ([Type]
arg1_mults forall a. [a] -> [a] -> [a]
++ [Type]
args_mults)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
arg_wrap forall a. a -> [a] -> [a]
: [HsWrapper]
arg_wraps) }
tc_syn_args_e [Type]
_ [SyntaxOpType]
_ [Type] -> [Type] -> TcM a
thing_inside = (, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> TcM a
thing_inside [] []
tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType
-> ([TcSigmaTypeFRR] -> TcM a)
-> TcM (a, HsWrapper)
tc_syn_arg :: forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg Type
res_ty SyntaxOpType
SynAny [Type] -> TcM a
thing_inside
= do { a
result <- [Type] -> TcM a
thing_inside [Type
res_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
tc_syn_arg Type
res_ty SyntaxOpType
SynRho [Type] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; a
result <- [Type] -> TcM a
thing_inside [Type
rho_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
tc_syn_arg Type
res_ty SyntaxOpType
SynList [Type] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; (TcCoercionR
list_co, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
; a
result <- [Type] -> TcM a
thing_inside [Type
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
tc_syn_arg Type
_ (SynFun {}) [Type] -> TcM a
_
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSynArgA hits a SynFun" (forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
tc_syn_arg Type
res_ty (SynType ExpRhoType
the_ty) [Type] -> TcM a
thing_inside
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> Type -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt Type
res_ty ExpRhoType
the_ty
; a
result <- [Type] -> TcM a
thing_inside []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
desugarRecordUpd :: LHsExpr GhcRn
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM ( HsExpr GhcRn
, TcType
, SDoc
)
desugarRecordUpd :: LHsExpr GhcRn
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
desugarRecordUpd LHsExpr GhcRn
record_expr [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
= do {
; ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
_, Type
record_rho), WantedConstraints
_lie) <- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints forall a b. (a -> b) -> a -> b
$
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
ManyTy forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
record_expr
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds <- LHsExpr GhcRn
-> Type
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds
upd_fld_occs :: [FieldLabelString]
upd_fld_occs = forall a b. (a -> b) -> [a] -> [b]
map (FastString -> FieldLabelString
FieldLabelString forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTc]
upd_flds
sel_ids :: [TyCoVar]
sel_ids = forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> TyCoVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
upd_fld_names :: [Name]
upd_fld_names = forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Name
idName [TyCoVar]
sel_ids
; let bad_guys :: [TcRn ()]
bad_guys = [ forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErrTc (Name -> TcRnMessage
notSelector Name
fld_name)
| GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
fld <- [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds,
let L SrcSpan
loc TyCoVar
sel_id = forall arg.
HsFieldBind (LAmbiguousFieldOcc GhcTc) arg
-> GenLocated SrcSpan TyCoVar
hsRecUpdFieldId (forall l e. GenLocated l e -> e
unLoc GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
fld),
Bool -> Bool
not (TyCoVar -> Bool
isRecordSelector TyCoVar
sel_id),
let fld_name :: Name
fld_name = TyCoVar -> Name
idName TyCoVar
sel_id ]
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRn ()]
bad_guys) (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TcRn ()]
bad_guys forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall env a. IOEnv env a
failM)
; let ([TyCoVar]
data_sels, [TyCoVar]
pat_syn_sels) =
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCoVar -> Bool
isDataConRecordSelector [TyCoVar]
sel_ids
; forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyCoVar -> Bool
isPatSynRecordSelector [TyCoVar]
pat_syn_sels)
; Bool -> TcRnMessage -> TcRn ()
checkTc ( forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
data_sels Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
pat_syn_sels )
( [TyCoVar] -> [TyCoVar] -> TcRnMessage
mixedSelectors [TyCoVar]
data_sels [TyCoVar]
pat_syn_sels )
; let
TyCoVar
sel_id : [TyCoVar]
_ = [TyCoVar]
sel_ids
con_likes :: [ConLike]
con_likes :: [ConLike]
con_likes = case TyCoVar -> IdDetails
idDetails TyCoVar
sel_id of
RecSelId (RecSelData TyCon
tc) Bool
_
-> forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
RecSelId (RecSelPatSyn PatSyn
ps) Bool
_
-> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
IdDetails
_ -> forall a. HasCallStack => String -> a
panic String
"tcRecordUpd"
relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
upd_fld_occs
; case [ConLike]
relevant_cons of
{ [] -> forall a. TcRnMessage -> TcM a
failWithTc ([LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> TcRnMessage
badFieldsUpd [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds [ConLike]
con_likes)
; ConLike
relevant_con : [ConLike]
_ ->
do {
; let ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
_, [Type]
_, [Scaled Type]
arg_tys, Type
con_res_ty) = ConLike
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Type], [Scaled Type],
Type)
conLikeFullSig ConLike
relevant_con
; (Subst
subst, [TyCoVar]
tc_tvs) <- [TyCoVar] -> TcM (Subst, [TyCoVar])
newMetaTyVars ([TyCoVar]
univ_tvs forall a. [a] -> [a] -> [a]
++ [TyCoVar]
ex_tvs)
; let ([Type]
actual_univ_tys, [Type]
_actual_ex_tys) = forall b a. [b] -> [a] -> ([a], [a])
splitAtList [TyCoVar]
univ_tvs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Type
mkTyVarTy [TyCoVar]
tc_tvs
ds_res_ty :: Type
ds_res_ty = case ConLike
relevant_con of
RealDataCon DataCon
con
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec)
-> TyCon -> [Type] -> Type
mkFamilyTyConApp (DataCon -> TyCon
dataConTyCon DataCon
con) [Type]
actual_univ_tys
ConLike
_ -> HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
con_res_ty
; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn))
mk_upd_id :: forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id Name
fld_nm (L SrcSpanAnnA
_ HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind)
= do { let Scaled Type
m Type
arg_ty = forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv (Scaled Type)
arg_ty_env Name
fld_nm
nm_occ :: OccName
nm_occ = RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$ Name
fld_nm
actual_arg_ty :: Type
actual_arg_ty = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
arg_ty
rhs :: LocatedA (HsExpr GhcRn)
rhs = forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind
; (TcCoercionR
_co, Type
actual_arg_ty) <- HasDebugCallStack =>
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
hasFixedRuntimeRep (Name -> HsExpr GhcRn -> FixedRuntimeRepContext
FRRRecordUpdate Name
fld_nm (forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr GhcRn)
rhs)) Type
actual_arg_ty
; Name
nm <- OccName -> SrcSpan -> TcM Name
newNameAt OccName
nm_occ SrcSpan
generatedSrcSpan
; let id :: TyCoVar
id = HasDebugCallStack => Name -> Type -> Type -> TyCoVar
mkLocalId Name
nm Type
m Type
actual_arg_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fld_nm, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs))
}
arg_ty_env :: NameEnv (Scaled Type)
arg_ty_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ FieldLabel
lbl Scaled Type
arg_ty -> (FieldLabel -> Name
flSelector FieldLabel
lbl, Scaled Type
arg_ty))
(ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
relevant_con)
[Scaled Type]
arg_tys
; [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id [Name]
upd_fld_names [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds
; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)
updEnv :: UniqMap Name (TyCoVar, LHsExpr GhcRn)
updEnv = forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap forall a b. (a -> b) -> a -> b
$ [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat ConLike
conLike = forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
CaseAlt [LPat GhcRn
pat] LocatedA (HsExpr GhcRn)
rhs
where
([GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats, [LocatedA (HsExpr GhcRn)]
rhs_con_args)
= forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
mk_con_arg [Int
1..] [FieldLabel]
con_fields
pat :: LPat GhcRn
pat = Name -> [LPat GhcRn] -> LPat GhcRn
genSimpleConPat Name
con [GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats
rhs :: LocatedA (HsExpr GhcRn)
rhs = forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$ Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps Name
con [LocatedA (HsExpr GhcRn)]
rhs_con_args
con :: Name
con = ConLike -> Name
conLikeName ConLike
conLike
con_fields :: [FieldLabel]
con_fields = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
conLike
mk_con_arg :: Int
-> FieldLabel
-> ( LPat GhcRn
, LHsExpr GhcRn )
mk_con_arg :: Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
mk_con_arg Int
i FieldLabel
fld_lbl =
case forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name (TyCoVar, LHsExpr GhcRn)
updEnv forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
flSelector FieldLabel
fld_lbl of
Just (TyCoVar
upd_id, LocatedA (HsExpr GhcRn)
_) -> (LPat GhcRn
genWildPat, Name -> LHsExpr GhcRn
genLHsVar (TyCoVar -> Name
idName TyCoVar
upd_id))
Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
_ -> let fld_nm :: Name
fld_nm = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
i)
(FastString -> OccName
mkVarOccFS (FieldLabelString -> FastString
field_label forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fld_lbl))
SrcSpan
generatedSrcSpan
in (Name -> LPat GhcRn
genVarPat Name
fld_nm, Name -> LHsExpr GhcRn
genLHsVar Name
fld_nm)
; let ds_expr :: HsExpr GhcRn
ds_expr :: HsExpr GhcRn
ds_expr = forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet NoExtField
noExtField forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok HsLocalBinds GhcRn
let_binds forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok (forall l e. l -> e -> GenLocated l e
L forall {ann}. SrcAnn ann
gen HsExpr GhcRn
case_expr)
case_expr :: HsExpr GhcRn
case_expr :: HsExpr GhcRn
case_expr = forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase NoExtField
noExtField LHsExpr GhcRn
record_expr (forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
Generated (forall a an. a -> LocatedAn an a
wrapGenSpan [LMatch GhcRn (LHsExpr GhcRn)]
matches))
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = forall a b. (a -> b) -> [a] -> [b]
map ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat [ConLike]
relevant_cons
let_binds :: HsLocalBindsLR GhcRn GhcRn
let_binds :: HsLocalBinds GhcRn
let_binds = forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
forall a b. (a -> b) -> a -> b
$ forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs (forall a b. (a -> b) -> [a] -> [b]
map (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids)
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs = [ (RecFlag
NonRecursive, forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ Name -> [LPat GhcRn] -> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind (TyCoVar -> Name
idName TyCoVar
id) [] LocatedA (HsExpr GhcRn)
rhs)
| (Name
_, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs)) <- [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids ]
mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig :: (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig (Name
_, (TyCoVar
id, LHsExpr GhcRn
_)) = forall l e. l -> e -> GenLocated l e
L forall {ann}. SrcAnn ann
gen forall a b. (a -> b) -> a -> b
$ forall pass. XXSig pass -> Sig pass
XSig forall a b. (a -> b) -> a -> b
$ TyCoVar -> IdSig
IdSig TyCoVar
id
gen :: SrcAnn ann
gen = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
generatedSrcSpan
; String -> SDoc -> TcRn ()
traceTc String
"desugarRecordUpd" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"relevant_con:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ConLike
relevant_con
, forall doc. IsLine doc => String -> doc
text String
"res_ty:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty
, forall doc. IsLine doc => String -> doc
text String
"ds_res_ty:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ds_res_ty
]
; let cons :: SDoc
cons = forall a. Outputable a => [a] -> SDoc
pprQuotedList [ConLike]
relevant_cons
err_lines :: [SDoc]
err_lines =
(forall doc. IsLine doc => String -> doc
text String
"In a record update at field" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. [a] -> SDoc
plural [Name]
upd_fld_names forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => [a] -> SDoc
pprQuotedList [Name]
upd_fld_names forall a. a -> [a] -> [a]
:)
forall a b. (a -> b) -> a -> b
$ case ConLike
relevant_con of
RealDataCon DataCon
con ->
[ forall doc. IsLine doc => String -> doc
text String
"with type constructor" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (DataCon -> TyCon
dataConTyCon DataCon
con))
, forall doc. IsLine doc => String -> doc
text String
"data constructor" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. [a] -> SDoc
plural [ConLike]
relevant_cons forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
PatSynCon {} ->
[ forall doc. IsLine doc => String -> doc
text String
"with pattern synonym" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. [a] -> SDoc
plural [ConLike]
relevant_cons forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ex_tvs
then []
else [ forall doc. IsLine doc => String -> doc
text String
"existential variable" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. [a] -> SDoc
plural [TyCoVar]
ex_tvs forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
ex_tvs ]
err_ctxt :: SDoc
err_ctxt = [SDoc] -> SDoc
make_lines_msg [SDoc]
err_lines
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt) } } }
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg [] = forall doc. IsOutput doc => doc
empty
make_lines_msg [SDoc
last] = forall a. Outputable a => a -> SDoc
ppr SDoc
last forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
dot
make_lines_msg [SDoc
l1,SDoc
l2] = SDoc
l1 forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsLine doc => String -> doc
text String
"and" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
l2 forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
dot
make_lines_msg (SDoc
l:[SDoc]
ls) = SDoc
l forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
make_lines_msg [SDoc]
ls
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> Type
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
= case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [LHsRecUpdField GhcRn]
rbnds of
Just [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
rbnds' -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
rbnds'
Maybe
[(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
Nothing ->
do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
; let possible_parents :: [[RecSelParent]]
possible_parents = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents
; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
; forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
(LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents }
where
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous LHsRecUpdField GhcRn
x = case forall l e. GenLocated l e -> e
unLoc (forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
x)) of
Unambiguous XUnambiguous GhcRn
sel_name XRec GhcRn RdrName
_ -> forall a. a -> Maybe a
Just (LHsRecUpdField GhcRn
x, XUnambiguous GhcRn
sel_name)
Ambiguous{} -> forall a. Maybe a
Nothing
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [a] -> [b] -> [(a, b)]
zip [LHsRecUpdField GhcRn]
rbnds) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(Bool
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
[LHsRecUpdField GhcRn]
rbnds
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
= case forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Eq a => [a] -> [a] -> [a]
intersect [[RecSelParent]]
possible_parents of
[] -> forall a. TcRnMessage -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> TcRnMessage
TcRnNoPossibleParentForFields [LHsRecUpdField GhcRn]
rbnds)
[RecSelParent
p] -> forall (m :: * -> *) a. Monad m => a -> m a
return RecSelParent
p
RecSelParent
_:[RecSelParent]
_ | Just TyCon
p <- FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
res_ty ->
do { TyCon -> TcRn ()
reportAmbiguousField TyCon
p
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
p) }
| Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
record_expr)
, Just TyCon
tc <- FamInstEnvs -> Type -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs Type
record_rho
-> do { TyCon -> TcRn ()
reportAmbiguousField TyCon
tc
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc) }
[RecSelParent]
_ -> forall a. TcRnMessage -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> TcRnMessage
TcRnBadOverloadedRecordUpdate [LHsRecUpdField GhcRn]
rbnds)
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
(LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p (LHsRecUpdField GhcRn
upd, [(RecSelParent, GlobalRdrElt)]
xs)
= case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
Just GlobalRdrElt
gre -> do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) forall a b. (a -> b) -> a -> b
$ do
let L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcRn
_ = forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) }
Maybe GlobalRdrElt
Nothing -> do { TcRnMessage -> TcRn ()
addErrTc (RecSelParent -> RdrName -> TcRnMessage
fieldNotInType RecSelParent
p
(forall l e. GenLocated l e -> e
unLoc (forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd))))
; (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName (forall a b. (a, b) -> b
snd (forall a. [a] -> a
head [(RecSelParent, GlobalRdrElt)]
xs))) }
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpanAnnA
l HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd, Name
n)
= do { TyCoVar
i <- Name -> TcM TyCoVar
tcLookupId Name
n
; let L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcRn
af = forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
lbl :: RdrName
lbl = forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsFieldBind
{ hfbAnn :: XHsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
hfbAnn = forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
hfbLHS
= forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) (forall pass.
XUnambiguous pass -> XRec pass RdrName -> AmbiguousFieldOcc pass
Unambiguous TyCoVar
i (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) RdrName
lbl))
, hfbRHS :: LocatedA (HsExpr GhcRn)
hfbRHS = forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbPun :: Bool
hfbPun = forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
}
}
reportAmbiguousField :: TyCon -> TcM ()
reportAmbiguousField :: TyCon -> TcRn ()
reportAmbiguousField TyCon
parent_type =
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnostic forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TyCon -> TcRnMessage
TcRnAmbiguousField HsExpr GhcRn
rupd TyCon
parent_type
where
rupd :: HsExpr GhcRn
rupd = RecordUpd { rupd_expr :: LHsExpr GhcRn
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: Either [LHsRecUpdField GhcRn] [LHsRecUpdProj GhcRn]
rupd_flds = forall a b. a -> Either a b
Left [LHsRecUpdField GhcRn]
rbnds, rupd_ext :: XRecordUpd GhcRn
rupd_ext = NoExtField
noExtField }
loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (forall a. [a] -> a
head [LHsRecUpdField GhcRn]
rbnds)
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds :: ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [Type]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (XRec GhcRn RecFieldsDotDot)
dd)
= do { [Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields (forall a. [Maybe a] -> [a]
catMaybes [Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds) Maybe (XRec GhcRn RecFieldsDotDot)
dd) }
where
fields :: [Name]
fields = forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, Type)]
flds_w_tys = forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [Type]
arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L SrcSpanAnnA
l fld :: HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
fld@(HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
f
, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = LocatedA (HsExpr GhcRn)
rhs }))
= do { Maybe
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
f LocatedA (HsExpr GhcRn)
rhs
; case Maybe
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
Maybe
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
f', GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs') -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
hfbAnn = forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
fld
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
hfbLHS = GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
f'
, hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
, hfbPun :: Bool
hfbPun = forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
fld}))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys (L SrcAnn NoEpAnns
loc (FieldOcc XCFieldOcc GhcRn
sel_name XRec GhcRn RdrName
lbl)) LHsExpr GhcRn
rhs
| Just Type
field_ty <- forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, Type)]
flds_w_tys XCFieldOcc GhcRn
sel_name
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_lbl) forall a b. (a -> b) -> a -> b
$
do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs Type
field_ty
; HasDebugCallStack => FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (RdrName -> HsExpr GhcTc -> FixedRuntimeRepContext
FRRRecordCon (forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
lbl) (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'))
Type
field_ty
; let field_id :: TyCoVar
field_id = OccName -> Unique -> Type -> Type -> SrcSpan -> TyCoVar
mkUserLocal (Name -> OccName
nameOccName XCFieldOcc GhcRn
sel_name)
(Name -> Unique
nameUnique XCFieldOcc GhcRn
sel_name)
Type
ManyTy Type
field_ty (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc (forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc TyCoVar
field_id XRec GhcRn RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs')) }
| Bool
otherwise
= do { TcRnMessage -> TcRn ()
addErrTc (Name -> FieldLabelString -> TcRnMessage
badFieldConErr (forall a. NamedThing a => a -> Name
getName ConLike
con_like) FieldLabelString
field_lbl)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
where
field_lbl :: FieldLabelString
field_lbl = FastString -> FieldLabelString
FieldLabelString forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels
= if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [])
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels) forall a b. (a -> b) -> a -> b
$ do
let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like []
(Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg)
| Bool
otherwise = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
missing_s_fields) forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, Type)]
fs <- forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_s_fields
TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [(FieldLabelString, Type)]
fs)
Bool
warn <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(FieldLabelString, Type)]
missing_ns_fields) forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, Type)]
fs <- forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_ns_fields
let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like [(FieldLabelString, Type)]
fs
Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg
where
zonk_fields :: t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields t (a, Type)
fs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (a, Type)
fs forall a b. (a -> b) -> a -> b
$ \(a
str,Type
ty) -> do
Type
ty' <- Type -> TcM Type
zonkTcType Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (a
str,Type
ty')
missing_s_fields :: [(FieldLabelString, Type)]
missing_s_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
HsImplBang -> Bool
isBanged HsImplBang
str,
Bool -> Bool
not (FieldLabel
fl forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
field_names_used)
]
missing_ns_fields :: [(FieldLabelString, Type)]
missing_ns_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
Bool -> Bool
not (FieldLabel
fl forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
field_names_used)
]
field_names_used :: [XCFieldOcc GhcRn]
field_names_used = forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
rbinds
field_labels :: [FieldLabel]
field_labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
field_info :: [(FieldLabel, HsImplBang, Scaled Type)]
field_info = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled Type]
arg_tys
field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like
FieldLabel
fl elemField :: FieldLabel -> t Name -> Bool
`elemField` t Name
flds = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Name
fl' -> FieldLabel -> Name
flSelector FieldLabel
fl forall a. Eq a => a -> a -> Bool
== Name
fl') t Name
flds
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_name
= forall doc. IsLine doc => String -> doc
text String
"In the" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"field of a record"
badFieldsUpd
:: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> TcRnMessage
badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> TcRnMessage
badFieldsUpd [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
= [FieldLabelString] -> TcRnMessage
TcRnNoConstructorHasAllFields [FieldLabelString]
conflictingFields
where
conflictingFields :: [FieldLabelString]
conflictingFields = case [(FieldLabelString, [Bool])]
nonMembers of
(FieldLabelString
nonMember, [Bool]
_) : [(FieldLabelString, [Bool])]
_ -> [FieldLabelString
aMember, FieldLabelString
nonMember]
[] -> let
growingSets :: [(FieldLabelString, [Bool])]
growingSets :: [(FieldLabelString, [Bool])]
growingSets = forall a. (a -> a -> a) -> [a] -> [a]
scanl1 forall {a} {a}. (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine [(FieldLabelString, [Bool])]
membership
combine :: (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine (a
_, [Bool]
setMem) (a
field, [Bool]
fldMem)
= (a
field, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
setMem [Bool]
fldMem)
in
forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NE.groupWith forall a b. (a, b) -> b
snd [(FieldLabelString, [Bool])]
growingSets
aMember :: FieldLabelString
aMember = forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, [Bool])]
members) ) forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(FieldLabelString, [Bool])]
members)
([(FieldLabelString, [Bool])]
members, [(FieldLabelString, [Bool])]
nonMembers) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
membership
membership :: [(FieldLabelString, [Bool])]
membership :: [(FieldLabelString, [Bool])]
membership = forall {a}. [(a, [Bool])] -> [(a, [Bool])]
sortMembership forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\FieldLabelString
fld -> (FieldLabelString
fld, forall a b. (a -> b) -> [a] -> [b]
map (FieldLabelString
fld forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet`) [UniqSet FieldLabelString]
fieldLabelSets)) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> FieldLabelString
FieldLabelString forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
fieldLabelSets :: [UniqSet FieldLabelString]
fieldLabelSets :: [UniqSet FieldLabelString]
fieldLabelSets = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FieldLabelString
flLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLabel]
conLikeFieldLabels) [ConLike]
data_cons
sortMembership :: [(a, [Bool])] -> [(a, [Bool])]
sortMembership =
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> [a] -> [b]
map (\ item :: (a, [Bool])
item@(a
_, [Bool]
membershipRow) -> ([Bool] -> Int
countTrue [Bool]
membershipRow, (a, [Bool])
item))
countTrue :: [Bool] -> Int
countTrue = forall a. (a -> Bool) -> [a] -> Int
count forall a. a -> a
id
mixedSelectors :: [Id] -> [Id] -> TcRnMessage
mixedSelectors :: [TyCoVar] -> [TyCoVar] -> TcRnMessage
mixedSelectors data_sels :: [TyCoVar]
data_sels@(TyCoVar
dc_rep_id:[TyCoVar]
_) pat_syn_sels :: [TyCoVar]
pat_syn_sels@(TyCoVar
ps_rep_id:[TyCoVar]
_)
= Name -> [TyCoVar] -> Name -> [TyCoVar] -> TcRnMessage
TcRnMixedSelectors (TyCon -> Name
tyConName TyCon
rep_dc) [TyCoVar]
data_sels (PatSyn -> Name
patSynName PatSyn
rep_ps) [TyCoVar]
pat_syn_sels
where
RecSelPatSyn PatSyn
rep_ps = TyCoVar -> RecSelParent
recordSelectorTyCon TyCoVar
ps_rep_id
RecSelData TyCon
rep_dc = TyCoVar -> RecSelParent
recordSelectorTyCon TyCoVar
dc_rep_id
mixedSelectors [TyCoVar]
_ [TyCoVar]
_ = forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm :: Name -> TcRn ()
checkClosedInStaticForm Name
name = do
TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
Maybe NotClosedReason
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just NotClosedReason
reason -> TcRnMessage -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> TcRnMessage
explain Name
name NotClosedReason
reason
where
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
n = TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> NameSet
unitNameSet Name
n) Name
n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env NameSet
visited Name
n =
case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
n of
Just (ATcId { tct_id :: TcTyThing -> TyCoVar
tct_id = TyCoVar
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
IdBindingInfo
ClosedLet -> forall a. Maybe a
Nothing
IdBindingInfo
NotLetBound -> forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
NonClosedLet NameSet
fvs Bool
type_closed -> forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
[ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
| Name
n' <- NameSet -> [Name]
nameSetElemsStable NameSet
fvs
, Bool -> Bool
not (Name -> NameSet -> Bool
elemNameSet Name
n' NameSet
visited)
, Just NotClosedReason
reason <- [TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (NameSet -> Name -> NameSet
extendNameSet NameSet
visited Name
n') Name
n']
] forall a. [a] -> [a] -> [a]
++
if Bool
type_closed then
[]
else
[ VarSet -> NotClosedReason
NotTypeClosed forall a b. (a -> b) -> a -> b
$ Type -> VarSet
tyCoVarsOfType (TyCoVar -> Type
idType TyCoVar
tcid) ]
Maybe TcTyThing
_ -> forall a. Maybe a
Nothing
explain :: Name -> NotClosedReason -> TcRnMessage
explain :: Name -> NotClosedReason -> TcRnMessage
explain = Name -> NotClosedReason -> TcRnMessage
TcRnStaticFormNotClosed