{-# LANGUAGE CPP #-}
{-# 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,
addAmbiguousNameErr,
getFixedTyVars ) where
#include "HsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Hs
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.Core.Multiplicity
import GHC.Core.UsageEnv
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.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.Gen.Pat
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.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.Names
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.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
tcCheckPolyExpr, tcCheckPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTc)
tcCheckPolyExpr :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
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, TcType)
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', TcType
rho) <- forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
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', TcType
rho) }
tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
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', TcType
rho) <- forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
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', TcType
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@(HsRecFld {}) 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
_ OccName
occ) ExpRhoType
res_ty
= do { TcType
ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; HoleExprRef
her <- OccName -> TcType -> TcM HoleExprRef
emitNewExprHole OccName
occ TcType
ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar HoleExprRef
her OccName
occ) }
tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
= do { let lit_ty :: TcType
lit_ty = forall (p :: Pass). HsLit (GhcPass p) -> TcType
hsLitType HsLit GhcRn
lit
; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> 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)) TcType
lit_ty ExpRhoType
res_ty }
tcExpr (HsPar XPar GhcRn
x LHsExpr GhcRn
expr) 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 -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
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
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
\[TcType
arg_ty] [TcType
arg_mult] ->
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
arg_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr TcType
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 {
TcType
ip_ty <- TcM TcType
newOpenFlexiTyVarTy
; let ip_name :: TcType
ip_name = FieldLabelString -> TcType
mkStrLitTy (HsIPName -> FieldLabelString
hsIPNameFS HsIPName
x)
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; Var
ip_var <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
origin (Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
ip_name, TcType
ip_ty])
; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
(Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
ip_name TcType
ip_ty (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Var
ip_var)))
TcType
ip_ty ExpRhoType
res_ty }
where
fromDict :: Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
x TcType
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR forall a b. (a -> b) -> a -> b
$
TcType -> TcCoercionR
unwrapIP forall a b. (a -> b) -> a -> b
$ Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
x,TcType
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') <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
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 GhcRn
mc_what = forall p. HsMatchContext p
LambdaExpr, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay Int
1) forall a b. (a -> b) -> a -> b
$
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
match),
String -> SDoc
text String
"has"]
tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches')
<- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
msg 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 -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
x MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
where
msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
, String -> SDoc
text String
"requires"]
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = forall p. HsMatchContext p
CaseAlt, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (ExplicitList XExplicitList GhcRn
_ [LHsExpr GhcRn]
exprs) ExpRhoType
res_ty
= do { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
res_ty
; let tc_elt :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr TcType
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 GenLocated SrcSpanAnnA (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 TcType
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
; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
tup_tc TcType
res_ty
; let arg_tys' :: [TcType]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> forall a. Int -> [a] -> [a]
drop Int
arity [TcType]
arg_tys
Boxity
Boxed -> [TcType]
arg_tys
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [TcType]
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
; [TcType]
arg_tys <- case Boxity
boxity of
{ Boxity
Boxed -> Int -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
newFlexiTyVarTys Int
arity TcType
liftedTypeKind
; Boxity
Unboxed -> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM TcType
newOpenFlexiTyVarTy }
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [TcType]
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 TcType]
missing_tys = [forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
ty | (Missing (Scaled TcType
mult TcType
_), TcType
ty) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg GhcTc]
tup_args1 [TcType]
arg_tys]
act_res_ty :: TcType
act_res_ty
= [Scaled TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
missing_tys (Boxity -> [TcType] -> TcType
mkTupleTy1 Boxity
boxity [TcType]
arg_tys)
; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (forall a. Outputable a => a -> SDoc
ppr TcType
act_res_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
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
; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
sum_tc TcType
res_ty
;
let arg_tys' :: [TcType]
arg_tys' = forall a. Int -> [a] -> [a]
drop Int
arity [TcType]
arg_tys
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr ([TcType]
arg_tys' forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt forall a. Num a => a -> a -> a
- Int
1))
; 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 [TcType]
arg_tys' Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' ) }
tcExpr (HsLet XLet GhcRn
x HsLocalBinds GhcRn
binds 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 -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
x HsLocalBinds GhcTc
binds' GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do {
TcType
mult <- TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut', TcType
scrut_ty) <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
scrut
; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (forall a. Outputable a => a -> SDoc
ppr TcType
scrut_ty)
; MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches' <- forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled TcType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
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 GhcRn
mc_what = forall p. HsMatchContext p
CaseAlt,
mc_body :: GenLocated SrcSpanAnnA (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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred TcType
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 { [Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM forall a b. (a -> b) -> a -> b
$ forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpRhoType
res_ty) [LGRHS GhcRn (LHsExpr GhcRn)]
alts
; TcType
res_ty <- ExpRhoType -> TcM TcType
readExpType ExpRhoType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf TcType
res_ty [Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts') }
where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = forall p. HsMatchContext p
IfAlt, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsDo XDo GhcRn
_ HsStmtContext (HsDoRn GhcRn)
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
= HsStmtContext GhcRn
-> LocatedL [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext (HsDoRn GhcRn)
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 SrcSpan (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 SrcSpan (HsCmdTop GhcTc)
cmd') }
tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
co, (TcType
p_ty, TcType
expr_ty)) <- TcType -> TcM (TcCoercionR, (TcType, TcType))
matchExpectedAppTy TcType
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 (String -> SDoc
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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
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
; Var
_ <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
StaticOrigin forall a b. (a -> b) -> a -> b
$
TyCon -> [TcType] -> TcType
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
[TcType
liftedTypeKind, TcType
expr_ty]
; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie
; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
[TcType
p_ty]
; let wrap :: HsWrapper
wrap = [TcType] -> HsWrapper
mkWpTyApps [TcType
expr_ty]
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; 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 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, TcType
con_sigma) <- Name -> TcM (HsExpr GhcTc, TcType)
tcInferId Name
con_name
; (HsWrapper
con_wrap, TcType
con_tau) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
con_sigma
; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
Right ([Scaled TcType]
arg_tys, TcType
actual_res_ty) = Int -> TcType -> Either Int ([Scaled TcType], TcType)
tcSplitFunTysN Int
arity TcType
con_tau
; Bool -> SDoc -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con_like) forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' <- ConLike
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled TcType]
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 -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
actual_res_ty ExpRhoType
res_ty
; ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcType]
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
= ASSERT( notNull rbnds )
do {
(GenLocated SrcSpanAnnA (HsExpr GhcTc)
record_expr', TcType
record_rho) <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
Many forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
record_expr
; [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds <- LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
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 id arg. HsRecField' id arg -> Located id
hsRecFieldLbl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds
upd_fld_occs :: [FieldLabelString]
upd_fld_occs = forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FieldLabelString
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 :: [Var]
sel_ids = forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
; let bad_guys :: [TcRn ()]
bad_guys = [ forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc (Name -> SDoc
notSelector Name
fld_name)
| GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
fld <- [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds,
let L SrcSpan
loc Var
sel_id = forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> GenLocated SrcSpan Var
hsRecUpdFieldId (forall l e. GenLocated l e -> e
unLoc GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
fld),
Bool -> Bool
not (Var -> Bool
isRecordSelector Var
sel_id),
let fld_name :: Name
fld_name = Var -> Name
idName Var
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 ([Var]
data_sels, [Var]
pat_syn_sels) =
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Var -> Bool
isDataConRecordSelector [Var]
sel_ids
; MASSERT( all isPatSynRecordSelector pat_syn_sels )
; Bool -> SDoc -> TcRn ()
checkTc ( forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
data_sels Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
pat_syn_sels )
( [Var] -> [Var] -> SDoc
mixedSelectors [Var]
data_sels [Var]
pat_syn_sels )
; let
Var
sel_id : [Var]
_ = [Var]
sel_ids
mtycon :: Maybe TyCon
mtycon :: Maybe TyCon
mtycon = case Var -> IdDetails
idDetails Var
sel_id of
RecSelId (RecSelData TyCon
tycon) Bool
_ -> forall a. a -> Maybe a
Just TyCon
tycon
IdDetails
_ -> forall a. Maybe a
Nothing
con_likes :: [ConLike]
con_likes :: [ConLike]
con_likes = case Var -> IdDetails
idDetails Var
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. String -> a
panic String
"tcRecordUpd"
relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
upd_fld_occs
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
relevant_cons)) ([LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds [ConLike]
con_likes)
; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
([Var]
con1_tvs, [Var]
_, [EqSpec]
_, [TcType]
_prov_theta, [TcType]
req_theta, [Scaled TcType]
scaled_con1_arg_tys, TcType
_)
= ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
TcType)
conLikeFullSig ConLike
con1
con1_arg_tys :: [TcType]
con1_arg_tys = forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled TcType]
scaled_con1_arg_tys
con1_flds :: [FieldLabelString]
con1_flds = forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FieldLabelString
flLabel forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con1
con1_tv_tys :: [TcType]
con1_tv_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs
con1_res_ty :: TcType
con1_res_ty = case Maybe TyCon
mtycon of
Just TyCon
tc -> TyCon -> [TcType] -> TcType
mkFamilyTyConApp TyCon
tc [TcType]
con1_tv_tys
Maybe TyCon
Nothing -> ConLike -> [TcType] -> TcType
conLikeResTy ConLike
con1 [TcType]
con1_tv_tys
; Bool -> SDoc -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con1) forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con1)
; let flds1_w_tys :: [(FieldLabelString, TcType)]
flds1_w_tys = forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcExpr:RecConUpd" [FieldLabelString]
con1_flds [TcType]
con1_arg_tys
bad_upd_flds :: [(FieldLabelString, TcType)]
bad_upd_flds = forall a. (a -> Bool) -> [a] -> [a]
filter (FieldLabelString, TcType) -> Bool
bad_fld [(FieldLabelString, TcType)]
flds1_w_tys
con1_tv_set :: VarSet
con1_tv_set = [Var] -> VarSet
mkVarSet [Var]
con1_tvs
bad_fld :: (FieldLabelString, TcType) -> Bool
bad_fld (FieldLabelString
fld, TcType
ty) = FieldLabelString
fld forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs Bool -> Bool -> Bool
&&
Bool -> Bool
not (TcType -> VarSet
tyCoVarsOfType TcType
ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
con1_tv_set)
; Bool -> SDoc -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
bad_upd_flds) ([(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
bad_upd_flds)
; let fixed_tvs :: VarSet
fixed_tvs = [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
con1_tvs [ConLike]
relevant_cons
is_fixed_tv :: Var -> Bool
is_fixed_tv Var
tv = Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs
mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty :: TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
subst (Var
tv, TcType
result_inst_ty)
| Var -> Bool
is_fixed_tv Var
tv
= forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> Var -> TcType -> TCvSubst
extendTvSubst TCvSubst
subst Var
tv TcType
result_inst_ty, TcType
result_inst_ty)
| Bool
otherwise
= do { (TCvSubst
subst', Var
new_tv) <- TCvSubst -> Var -> TcM (TCvSubst, Var)
newMetaTyVarX TCvSubst
subst Var
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Var -> TcType
mkTyVarTy Var
new_tv) }
; (TCvSubst
result_subst, [Var]
con1_tvs') <- [Var] -> TcM (TCvSubst, [Var])
newMetaTyVars [Var]
con1_tvs
; let result_inst_tys :: [TcType]
result_inst_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs'
init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
result_subst)
; (TCvSubst
scrut_subst, [TcType]
scrut_inst_tys) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
init_subst
([Var]
con1_tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
result_inst_tys)
; let rec_res_ty :: TcType
rec_res_ty = HasCallStack => TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst TcType
con1_res_ty
scrut_ty :: TcType
scrut_ty = HasCallStack => TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
scrut_subst TcType
con1_res_ty
con1_arg_tys' :: [TcType]
con1_arg_tys' = forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst) [TcType]
con1_arg_tys
; TcCoercionR
co_scrut <- Maybe SDoc -> TcType -> TcType -> TcM TcCoercionR
unifyType (forall a. a -> Maybe a
Just (forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
record_expr)) TcType
record_rho TcType
scrut_ty
; [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rbinds' <- ConLike
-> [TcType]
-> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con1 [TcType]
con1_arg_tys' [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds
; let theta' :: [TcType]
theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcType]
conLikeStupidTheta ConLike
con1)
; CtOrigin -> [TcType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcType]
theta'
; let fam_co :: HsWrapper
fam_co :: HsWrapper
fam_co | Just TyCon
tycon <- Maybe TyCon
mtycon
, Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
= TcCoercionR -> HsWrapper
mkWpCastR (CoAxiom Unbranched -> [TcType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcType]
scrut_inst_tys [])
| Bool
otherwise
= HsWrapper
idHsWrapper
; let req_theta' :: [TcType]
req_theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst [TcType]
req_theta
; HsWrapper
req_wrap <- CtOrigin -> [TcType] -> TcM HsWrapper
instCallConstraints CtOrigin
RecordUpdOrigin [TcType]
req_theta'
; let upd_tc :: RecordUpdTc
upd_tc = RecordUpdTc { rupd_cons :: [ConLike]
rupd_cons = [ConLike]
relevant_cons
, rupd_in_tys :: [TcType]
rupd_in_tys = [TcType]
scrut_inst_tys
, rupd_out_tys :: [TcType]
rupd_out_tys = [TcType]
result_inst_tys
, rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
req_wrap }
expr' :: HsExpr GhcTc
expr' = RecordUpd { rupd_expr :: LHsExpr GhcTc
rupd_expr = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
fam_co forall a b. (a -> b) -> a -> b
$
TcCoercionR -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrapCo TcCoercionR
co_scrut GenLocated SrcSpanAnnA (HsExpr GhcTc)
record_expr'
, rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = forall a b. a -> Either a b
Left [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rbinds'
, rupd_ext :: XRecordUpd GhcTc
rupd_ext = RecordUpdTc
upd_tc }
; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
rec_res_ty ExpRhoType
res_ty }
tcExpr (RecordUpd {}) ExpRhoType
_ = forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
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
_ Located (HsFieldLabel GhcRn)
_) ExpRhoType
_ = forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ NonEmpty (Located (HsFieldLabel GhcRn))
_) ExpRhoType
_ = forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
tcExpr (HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedExpr HsExpr GhcRn
expr)))
ExpRhoType
res_ty
= do ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
tcExpr (HsSpliceE XSpliceE GhcRn
_ HsSplice GhcRn
splice) ExpRhoType
res_ty = HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcSpliceExpr HsSplice GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket XBracket GhcRn
_ HsBracket GhcRn
brack) ExpRhoType
res_ty = HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRnBracketOut XRnBracketOut GhcRn
_ HsBracket (HsBracketRn GhcRn)
brack [PendingRnSplice' GhcRn]
ps) ExpRhoType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsBracket (HsBracketRn GhcRn)
brack [PendingRnSplice' GhcRn]
ps ExpRhoType
res_ty
tcExpr (HsConLikeOut {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsConLikeOut" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
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)
tcExpr (HsTcBracketOut {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTcBracketOut" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (HsTick {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTick" (forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (HsBinTick {}) ExpRhoType
ty = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsBinTick" (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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <-forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
elt_ty
; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromName [TcType
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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenName [TcType
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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromToName [TcType
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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3' <- forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 TcType
elt_ty
; HsExpr GhcTc
eft <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenToName [TcType
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, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpRhoType
res_ty
= do { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, TcType
One, TcType
elt_ty, forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpRhoType
res_ty
= do { ((TcType
elt_mult, TcType
elt_ty), SyntaxExprTc
fl')
<- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
fl [SyntaxOpType
SynList] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
\ [TcType
elt_ty] [TcType
elt_mult] -> forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
elt_mult, TcType
elt_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcType
elt_mult, TcType
elt_ty, forall a. a -> Maybe a
Just SyntaxExprTc
fl') }
tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs :: [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
args [TcType]
tys
= do MASSERT( equalLength args tys )
Int -> TcRn ()
checkTupSize (forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsTupArg GhcRn, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go ([HsTupArg GhcRn]
args forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
tys)
where
go :: (HsTupArg GhcRn, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go (Missing {}, TcType
arg_ty) = do { TcType
mult <- TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XMissing id -> HsTupArg id
Missing (forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
arg_ty)) }
go (Present XPresent GhcRn
x LHsExpr GhcRn
expr, TcType
arg_ty) = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
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
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
= forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpRhoType -> SyntaxOpType
SynType ExpRhoType
res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [TcType] -> [TcType] -> TcM a
thing_inside
= do { (HsExpr GhcTc
expr, TcType
sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> Maybe TcType -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan) [] forall a. Maybe a
Nothing
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TcType
sigma)
; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
<- forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty forall a b. (a -> b) -> a -> b
$
[TcType] -> [TcType] -> TcM a
thing_inside
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TcType
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
_ [TcType] -> [TcType] -> TcM a
_ = forall a. String -> a
panic String
"tcSyntaxOpGen"
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE :: forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
sigma_ty SyntaxOpType
syn_ty [TcType] -> [TcType] -> TcM a
thing_inside
= do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
<- forall result.
UserTypeCtxt
-> TcType -> (TcType -> TcM result) -> TcM (HsWrapper, result)
tcTopSkolemise UserTypeCtxt
GenSigCtxt TcType
sigma_ty
(\ TcType
rho_ty -> TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
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 :: TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
rho_ty SyntaxOpType
SynAny
= do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
rho_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go TcType
rho_ty SyntaxOpType
SynRho
= do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
rho_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go TcType
rho_ty SyntaxOpType
SynList
= do { (TcCoercionR
list_co, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
rho_ty
; a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
elt_ty] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
list_co) }
go TcType
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
= do { ( HsWrapper
match_wrapper
, ( ( (a
result, TcType
arg_ty, TcType
res_ty, TcType
op_mult)
, HsWrapper
res_wrapper )
, HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )
<- forall a.
SDoc
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys SDoc
herald UserTypeCtxt
GenSigCtxt Int
1 (TcType -> ExpRhoType
mkCheckExpType TcType
rho_ty) forall a b. (a -> b) -> a -> b
$
\ [Scaled ExpRhoType
arg_ty] ExpRhoType
res_ty ->
do { TcType
arg_tc_ty <- ExpRhoType -> TcM TcType
expTypeToType (forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
; TcType
res_tc_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
; MASSERT2( case arg_shape of
SynFun {} -> False;
_ -> True
, text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig )
; let arg_mult :: TcType
arg_mult = forall a. Scaled a -> TcType
scaledMult Scaled ExpRhoType
arg_ty
; forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
arg_tc_ty [] SyntaxOpType
arg_shape forall a b. (a -> b) -> a -> b
$
\ [TcType]
arg_results [TcType]
arg_res_mults ->
forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
res_tc_ty SyntaxOpType
res_shape forall a b. (a -> b) -> a -> b
$
\ [TcType]
res_results [TcType]
res_res_mults ->
do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg_results forall a. [a] -> [a] -> [a]
++ [TcType]
res_results) ([TcType
arg_mult] forall a. [a] -> [a] -> [a]
++ [TcType]
arg_res_mults forall a. [a] -> [a] -> [a]
++ [TcType]
res_res_mults)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcType
arg_tc_ty, TcType
res_tc_ty, TcType
arg_mult) }}
; forall (m :: * -> *) a. Monad m => a -> m a
return ( a
result
, HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.>
HsWrapper
-> HsWrapper -> Scaled TcType -> TcType -> SDoc -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
(forall a. TcType -> a -> Scaled a
Scaled TcType
op_mult TcType
arg_ty) TcType
res_ty SDoc
doc ) }
where
herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
doc :: SDoc
doc = String -> SDoc
text String
"When checking a rebindable syntax operator arising from" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig
go TcType
rho_ty (SynType ExpRhoType
the_ty)
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> TcType -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty TcType
rho_ty
; a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [] []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
tcSynArgA :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA :: forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [TcType] -> [TcType] -> TcM a
thing_inside
= do { (HsWrapper
match_wrapper, [Scaled TcType]
arg_tys, TcType
res_ty)
<- SDoc
-> CtOrigin
-> Maybe SDoc
-> Int
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho SDoc
herald CtOrigin
orig forall a. Maybe a
Nothing
(forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) TcType
sigma_ty
; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
<- forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled TcType]
arg_tys) [SyntaxOpType]
arg_shapes forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg_results [TcType]
arg_res_mults ->
forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcType
res_ty SyntaxOpType
res_shape forall a b. (a -> b) -> a -> b
$ \ [TcType]
res_results ->
[TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg_results forall a. [a] -> [a] -> [a]
++ [TcType]
res_results) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> TcType
scaledMult [Scaled TcType]
arg_tys forall a. [a] -> [a] -> [a]
++ [TcType]
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 :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e :: forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (TcType
arg_ty : [TcType]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [TcType] -> [TcType] -> TcM a
thing_inside
= do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
<- forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
arg_ty SyntaxOpType
arg_shape forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg1_results [TcType]
arg1_mults ->
forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [TcType]
arg_tys [SyntaxOpType]
arg_shapes forall a b. (a -> b) -> a -> b
$ \ [TcType]
args_results [TcType]
args_mults ->
[TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg1_results forall a. [a] -> [a] -> [a]
++ [TcType]
args_results) ([TcType]
arg1_mults forall a. [a] -> [a] -> [a]
++ [TcType]
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 [TcType]
_ [SyntaxOpType]
_ [TcType] -> [TcType] -> TcM a
thing_inside = (, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TcType] -> [TcType] -> TcM a
thing_inside [] []
tc_syn_arg :: TcSigmaType -> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tc_syn_arg :: forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcType
res_ty SyntaxOpType
SynAny [TcType] -> TcM a
thing_inside
= do { a
result <- [TcType] -> TcM a
thing_inside [TcType
res_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
tc_syn_arg TcType
res_ty SyntaxOpType
SynRho [TcType] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
; a
result <- [TcType] -> TcM a
thing_inside [TcType
rho_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
tc_syn_arg TcType
res_ty SyntaxOpType
SynList [TcType] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
; (TcCoercionR
list_co, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
rho_ty
; a
result <- [TcType] -> TcM a
thing_inside [TcType
elt_ty]
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
tc_syn_arg TcType
_ (SynFun {}) [TcType] -> 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 TcType
res_ty (SynType ExpRhoType
the_ty) [TcType] -> TcM a
thing_inside
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> TcType -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt TcType
res_ty ExpRhoType
the_ty
; a
result <- [TcType] -> TcM a
thing_inside []
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
getFixedTyVars :: [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
univ_tvs [ConLike]
cons
= [Var] -> VarSet
mkVarSet [Var
tv1 | ConLike
con <- [ConLike]
cons
, let ([Var]
u_tvs, [Var]
_, [EqSpec]
eqspec, [TcType]
prov_theta
, [TcType]
req_theta, [Scaled TcType]
arg_tys, TcType
_)
= ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
TcType)
conLikeFullSig ConLike
con
theta :: [TcType]
theta = [EqSpec] -> [TcType]
eqSpecPreds [EqSpec]
eqspec
forall a. [a] -> [a] -> [a]
++ [TcType]
prov_theta
forall a. [a] -> [a] -> [a]
++ [TcType]
req_theta
flds :: [FieldLabel]
flds = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
fixed_tvs :: VarSet
fixed_tvs = [TcType] -> VarSet
exactTyCoVarsOfTypes (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled TcType]
fixed_tys)
VarSet -> VarSet -> VarSet
`unionVarSet` [TcType] -> VarSet
tyCoVarsOfTypes [TcType]
theta
fixed_tys :: [Scaled TcType]
fixed_tys = [Scaled TcType
ty | (FieldLabel
fl, Scaled TcType
ty) <- forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLabel]
flds [Scaled TcType]
arg_tys
, Bool -> Bool
not (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs)]
, (Var
tv1,Var
tv) <- [Var]
univ_tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
u_tvs
, Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs ]
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
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
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
(LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector [(GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
Name)]
rbnds'
Maybe
[(GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
Name)]
Nothing ->
do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; [(GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
(LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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 id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
x)) of
Unambiguous XUnambiguous GhcRn
sel_name LocatedN 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. SDoc -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [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 -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcType
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. SDoc -> TcM a
failWithTc SDoc
badOverloadedUpdate
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
(LHsRecField' GhcTc (AmbiguousFieldOcc 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 SrcSpan
loc AmbiguousFieldOcc GhcRn
_ = forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) }
Maybe GlobalRdrElt
Nothing -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
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
(LHsRecField' GhcRn (AmbiguousFieldOcc 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 (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpanAnnA
l HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd, Name
n)
= do { Var
i <- Name -> TcM Var
tcLookupId Name
n
; let L SrcSpan
loc AmbiguousFieldOcc GhcRn
af = forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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 HsRecField
{ hsRecFieldAnn :: XHsRecField (AmbiguousFieldOcc GhcTc)
hsRecFieldAnn = forall id arg. HsRecField' id arg -> XHsRecField id
hsRecFieldAnn HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd
, hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
= forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous Var
i (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
, hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hsRecFieldArg = forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd
, hsRecPun :: Bool
hsRecPun = forall id arg. HsRecField' id arg -> Bool
hsRecPun HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
$ WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnAmbiguousFields Bool
True forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The record update" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rupd
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with type" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
parent_type
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
, String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
]
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
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [TcType]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (Located Int)
dd)
= do { [Maybe
(GenLocated
SrcSpanAnnA
(HsRecField'
(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 (Located Int) -> HsRecFields p arg
HsRecFields (forall a. [Maybe a] -> [a]
catMaybes [Maybe
(GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds) Maybe (Located Int)
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, TcType)]
flds_w_tys = forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [TcType]
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 :: HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = Located (FieldOcc GhcRn)
f
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs }))
= do { Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
f GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
; case Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Located (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 (HsRecField
{ hsRecFieldAnn :: XHsRecField (FieldOcc GhcTc)
hsRecFieldAnn = forall id arg. HsRecField' id arg -> XHsRecField id
hsRecFieldAnn HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld
, hsRecFieldLbl :: Located (FieldOcc GhcTc)
hsRecFieldLbl = Located (FieldOcc GhcTc)
f'
, hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
, hsRecPun :: Bool
hsRecPun = forall id arg. HsRecField' id arg -> Bool
hsRecPun HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld}))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd :: ConLike
-> [TcType]
-> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con_like [TcType]
arg_tys [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes 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 LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
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, TcType)]
flds_w_tys = forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordUpd" [Name]
fields [TcType]
arg_tys
do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind (L SrcSpanAnnA
l fld :: HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
loc AmbiguousFieldOcc GhcTc
af
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs }))
= do { let lbl :: RdrName
lbl = forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
sel_id :: Var
sel_id = AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
f :: Located (FieldOcc GhcRn)
f = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc (Var -> Name
idName Var
sel_id) (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
; Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
f GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
; case Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
Maybe
(Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Located (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 (HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
= forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous
(forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (forall l e. GenLocated l e -> e
unLoc Located (FieldOcc GhcTc)
f'))
(forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
, hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys (L SrcSpan
loc (FieldOcc XCFieldOcc GhcRn
sel_name LocatedN RdrName
lbl)) LHsExpr GhcRn
rhs
| Just TcType
field_ty <- forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, TcType)]
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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs TcType
field_ty
; let field_id :: Var
field_id = OccName -> Unique -> TcType -> TcType -> SrcSpan -> Var
mkUserLocal (Name -> OccName
nameOccName XCFieldOcc GhcRn
sel_name)
(Name -> Unique
nameUnique XCFieldOcc GhcRn
sel_name)
TcType
Many TcType
field_ty SrcSpan
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 SrcSpan
loc (forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc Var
field_id LocatedN RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs')) }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErrTc (ConLike -> FieldLabelString -> SDoc
badFieldCon 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 = OccName -> FieldLabelString
occNameFS forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcType]
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
SDoc -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con_like [])
else do
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 [HsImplBang]
field_strs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels)
(WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con_like []))
| Bool
otherwise = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
missing_s_fields) forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, TcType)]
fs <- forall {t :: * -> *} {a}.
Traversable t =>
t (a, TcType) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcType))
zonk_fields [(FieldLabelString, TcType)]
missing_s_fields
SDoc -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con_like [(FieldLabelString, TcType)]
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, TcType)]
missing_ns_fields) forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, TcType)]
fs <- forall {t :: * -> *} {a}.
Traversable t =>
t (a, TcType) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcType))
zonk_fields [(FieldLabelString, TcType)]
missing_ns_fields
WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con_like [(FieldLabelString, TcType)]
fs)
where
zonk_fields :: t (a, TcType) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcType))
zonk_fields t (a, TcType)
fs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (a, TcType)
fs forall a b. (a -> b) -> a -> b
$ \(a
str,TcType
ty) -> do
TcType
ty' <- TcType -> TcM TcType
zonkTcType TcType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (a
str,TcType
ty')
missing_s_fields :: [(FieldLabelString, TcType)]
missing_s_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, forall a. Scaled a -> a
scaledThing Scaled TcType
ty) | (FieldLabel
fl,HsImplBang
str,Scaled TcType
ty) <- [(FieldLabel, HsImplBang, Scaled TcType)]
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, TcType)]
missing_ns_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, forall a. Scaled a -> a
scaledThing Scaled TcType
ty) | (FieldLabel
fl,HsImplBang
str,Scaled TcType
ty) <- [(FieldLabel, HsImplBang, Scaled TcType)]
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 TcType)]
field_info = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled TcType]
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
= String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"field of a record")
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes :: [(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
prs
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Record update for insufficiently polymorphic field"
SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [(FieldLabelString, TcType)]
prs SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr FieldLabelString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcType
ty | (FieldLabelString
f,TcType
ty) <- [(FieldLabelString, TcType)]
prs ])
badFieldsUpd
:: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> SDoc
badFieldsUpd :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No constructor has all these fields:")
Int
2 (forall a. Outputable a => [a] -> SDoc
pprQuotedList [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. [a] -> a
head) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
growingSets
aMember :: FieldLabelString
aMember = ASSERT( not (null members) ) fst (head 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 (OccName -> FieldLabelString
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 id arg. HsRecField' id arg -> Located id
hsRecFieldLbl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LHsRecField' GhcTc (AmbiguousFieldOcc 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] -> SDoc
mixedSelectors :: [Var] -> [Var] -> SDoc
mixedSelectors data_sels :: [Var]
data_sels@(Var
dc_rep_id:[Var]
_) pat_syn_sels :: [Var]
pat_syn_sels@(Var
ps_rep_id:[Var]
_)
= PtrString -> SDoc
ptext
(String -> PtrString
sLit String
"Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Record selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
rep_dc))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [Var]
data_sels SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Pattern synonym selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (PatSyn -> Name
patSynName PatSyn
rep_ps))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [Var]
pat_syn_sels
where
RecSelPatSyn PatSyn
rep_ps = Var -> RecSelParent
recordSelectorTyCon Var
ps_rep_id
RecSelData TyCon
rep_dc = Var -> RecSelParent
recordSelectorTyCon Var
dc_rep_id
mixedSelectors [Var]
_ [Var]
_ = forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"
missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con [(FieldLabelString, TcType)]
fields
= [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
where
pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
ty
rest :: SDoc
rest | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields = SDoc
Outputable.empty
| Bool
otherwise = [SDoc] -> SDoc
vcat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a}. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FieldLabelString, TcType)]
fields)
header :: SDoc
header = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"does not have the required strict field(s)" SDoc -> SDoc -> SDoc
<>
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields then SDoc
Outputable.empty else SDoc
colon
missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con [(FieldLabelString, TcType)]
fields
= [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
where
pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
ty
rest :: SDoc
rest | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields = SDoc
Outputable.empty
| Bool
otherwise = [SDoc] -> SDoc
vcat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a}. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FieldLabelString, TcType)]
fields)
header :: SDoc
header = String -> SDoc
text String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"not initialised" SDoc -> SDoc -> SDoc
<>
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields then SDoc
Outputable.empty else SDoc
colon
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbinds
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No type has all these fields:")
Int
2 (forall a. Outputable a => [a] -> SDoc
pprQuotedList [Located (AmbiguousFieldOcc GhcRn)]
fields)
where
fields :: [Located (AmbiguousFieldOcc GhcRn)]
fields = forall a b. (a -> b) -> [a] -> [b]
map (forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LHsRecUpdField GhcRn]
rbinds
badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"
data NotClosedReason = NotLetBoundReason
| NotTypeClosed VarSet
| NotClosed Name NotClosedReason
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 -> SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> SDoc
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 -> Var
tct_id = Var
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
$ TcType -> VarSet
tyCoVarsOfType (Var -> TcType
idType Var
tcid) ]
Maybe TcTyThing
_ -> forall a. Maybe a
Nothing
explain :: Name -> NotClosedReason -> SDoc
explain :: Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason =
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a static form but it is not closed"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because it"
SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)
causes :: NotClosedReason -> [SDoc]
causes :: NotClosedReason -> [SDoc]
causes NotClosedReason
NotLetBoundReason = [String -> SDoc
text String
"is not let-bound."]
causes (NotTypeClosed VarSet
vs) =
[ String -> SDoc
text String
"has a non-closed type because it contains the"
, String -> SDoc
text String
"type variables:" SDoc -> SDoc -> SDoc
<+>
VarSet -> ([Var] -> SDoc) -> SDoc
pprVarSet VarSet
vs ([SDoc] -> SDoc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr))
]
causes (NotClosed Name
n NotClosedReason
reason) =
let msg :: SDoc
msg = String -> SDoc
text String
"uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"which"
in case NotClosedReason
reason of
NotClosed Name
_ NotClosedReason
_ -> SDoc
msg forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
NotClosedReason
_ -> let ([SDoc]
xs0, [SDoc]
xs1) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1