{-# 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,
tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
) where
import GHC.Prelude
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import {-# SOURCE #-} GHC.Tc.Gen.Splice
( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody )
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.Unique.Set
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match( tcBody, tcLambdaMatches, tcCaseMatches
, tcGRHSList, tcDoStmts )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Zonk.TcType
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.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.Class(classTyCon)
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Driver.DynFlags
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Bag ( unitBag )
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad
import qualified Data.List.NonEmpty as NE
tcCheckPolyExpr, tcCheckPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTc)
tcCheckPolyExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
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
= SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
e (Infer InferResult
inf) = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e (InferResult -> ExpRhoType
Infer InferResult
inf)
tcPolyExpr HsExpr GhcRn
e (Check Type
ty) = HsExpr GhcRn -> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr GhcRn
e (Type -> Either Type TcCompleteSig
forall a b. a -> Either a b
Left Type
ty)
tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc)
tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc)
tcPolyLExprSig (L SrcSpanAnnA
loc HsExpr GhcRn
expr) TcCompleteSig
sig
= SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyLExprSig" (SrcSpanAnnA -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
loc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr)
; HsExpr GhcTc
expr' <- HsExpr GhcRn -> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr GhcRn
expr (TcCompleteSig -> Either Type TcCompleteSig
forall a b. b -> Either a b
Right TcCompleteSig
sig)
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcPolyExprCheck :: HsExpr GhcRn
-> Either TcSigmaType TcCompleteSig
-> TcM (HsExpr GhcTc)
tcPolyExprCheck :: HsExpr GhcRn -> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr GhcRn
expr Either Type TcCompleteSig
res_ty
= Either Type TcCompleteSig
-> ([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
outer_skolemise Either Type TcCompleteSig
res_ty (([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc))
-> ([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \[ExpPatType]
pat_tys Type
rho_ty ->
let
tc_body :: HsExpr GhcRn -> TcM (HsExpr GhcTc)
tc_body (HsPar XPar GhcRn
x (L SrcSpanAnnA
loc HsExpr GhcRn
e))
= SrcSpanAnnA -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
e' <- HsExpr GhcRn -> TcM (HsExpr GhcTc)
tc_body HsExpr GhcRn
e
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
e')) }
tc_body (HsUntypedSplice XUntypedSplice GhcRn
splice_res HsUntypedSplice GhcRn
_)
= do { HsExpr GhcRn
body <- HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn)
getUntypedSpliceBody XUntypedSplice GhcRn
HsUntypedSpliceResult (HsExpr GhcRn)
splice_res
; HsExpr GhcRn -> TcM (HsExpr GhcTc)
tc_body HsExpr GhcRn
body }
tc_body e :: HsExpr GhcRn
e@(HsLam XLam GhcRn
x HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches)
= do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- HsExpr GhcRn
-> HsLamVariant
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr GhcRn
e HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
pat_tys
(Type -> ExpRhoType
mkCheckExpType Type
rho_ty)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLam GhcTc
-> HsLamVariant -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTc
x HsLamVariant
lam_variant MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
tc_body HsExpr GhcRn
e = do { DeepSubsumptionFlag
ds_flag <- TcM DeepSubsumptionFlag
getDeepSubsumptionFlag
; DeepSubsumptionFlag
-> Type -> (Type -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
inner_skolemise DeepSubsumptionFlag
ds_flag Type
rho_ty ((Type -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc))
-> (Type -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \Type
rho_ty' ->
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e (Type -> ExpRhoType
mkCheckExpType Type
rho_ty') }
in HsExpr GhcRn -> TcM (HsExpr GhcTc)
tc_body HsExpr GhcRn
expr
where
outer_skolemise :: Either TcSigmaType TcCompleteSig
-> ([ExpPatType] -> TcRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
outer_skolemise :: Either Type TcCompleteSig
-> ([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc)
outer_skolemise (Left Type
ty) [ExpPatType] -> Type -> TcM (HsExpr GhcTc)
thing_inside
= do { (HsWrapper
wrap, HsExpr GhcTc
expr') <- Type
-> ([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
Type
-> ([ExpPatType] -> Type -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseExpectedType Type
ty [ExpPatType] -> Type -> TcM (HsExpr GhcTc)
thing_inside
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr') }
outer_skolemise (Right TcCompleteSig
sig) [ExpPatType] -> Type -> TcM (HsExpr GhcTc)
thing_inside
= do { (HsWrapper
wrap, HsExpr GhcTc
expr') <- TcCompleteSig
-> ([ExpPatType] -> Type -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
TcCompleteSig
-> ([ExpPatType] -> Type -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseCompleteSig TcCompleteSig
sig [ExpPatType] -> Type -> TcM (HsExpr GhcTc)
thing_inside
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr') }
inner_skolemise :: DeepSubsumptionFlag -> TcRhoType
-> (TcRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
inner_skolemise :: DeepSubsumptionFlag
-> Type -> (Type -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc)
inner_skolemise DeepSubsumptionFlag
Shallow Type
rho_ty Type -> TcM (HsExpr GhcTc)
thing_inside
=
Type -> TcM (HsExpr GhcTc)
thing_inside Type
rho_ty
inner_skolemise DeepSubsumptionFlag
Deep Type
rho_ty Type -> TcM (HsExpr GhcTc)
thing_inside
=
do { (HsWrapper
wrap, HsExpr GhcTc
expr') <- DeepSubsumptionFlag
-> UserTypeCtxt
-> Type
-> (Type -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
DeepSubsumptionFlag
-> UserTypeCtxt
-> Type
-> (Type -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise DeepSubsumptionFlag
Deep UserTypeCtxt
ctxt Type
rho_ty Type -> TcM (HsExpr GhcTc)
thing_inside
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr') }
ctxt :: UserTypeCtxt
ctxt = case Either Type TcCompleteSig
res_ty of
Left {} -> UserTypeCtxt
GenSigCtxt
Right TcCompleteSig
sig -> TcCompleteSig -> UserTypeCtxt
sig_ctxt TcCompleteSig
sig
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
= SrcSpanAnnA
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
expr', Type
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }
tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRhoNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
= SrcSpanAnnA
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
expr', Type
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }
tcCheckMonoExpr, tcCheckMonoExprNC
:: LHsExpr GhcRn
-> TcRhoType
-> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcMonoExpr, tcMonoExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcMonoExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
= SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
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
= SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr e :: HsExpr GhcRn
e@(HsVar {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsApp {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(OpApp {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRecSel {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr (XExpr XXExpr GhcRn
e) ExpRhoType
res_ty = XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr XXExpr GhcRn
XXExprGhcRn
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' -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
NoExtField
noExtField HsOverLit GhcTc
lit')
Maybe (HsOverLit GhcTc)
Nothing -> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty }
tcExpr (HsUnboundVar XUnboundVar GhcRn
_ RdrName
occ) ExpRhoType
res_ty
= do { Type
ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; HoleExprRef
her <- RdrName -> Type -> TcM HoleExprRef
emitNewExprHole RdrName
occ Type
ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcTc -> RdrName -> HsExpr GhcTc
forall p. XUnboundVar p -> RdrName -> HsExpr p
HsUnboundVar XUnboundVar GhcTc
HoleExprRef
her RdrName
occ) }
tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
= do { let lit_ty :: Type
lit_ty = HsLit GhcRn -> Type
forall (p :: Pass). HsLit (GhcPass p) -> Type
hsLitType HsLit GhcRn
lit
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTc
x (HsLit GhcRn -> HsLit GhcTc
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcRn
lit)) Type
lit_ty ExpRhoType
res_ty }
tcExpr (HsPar XPar GhcRn
x 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
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x LHsExpr GhcTc
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
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcRn
XPragE GhcTc
x (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExpr GhcTc
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')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type]
-> [Type]
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
SyntaxExprRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty (([Type]
-> [Type]
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc))
-> ([Type]
-> [Type]
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\[Type
arg_ty] [Type
arg_mult] ->
Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
arg_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
arg_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTc -> LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' SyntaxExpr GhcTc
SyntaxExprTc
neg_expr') }
tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpRhoType
res_ty
= do { Type
ip_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; let ip_name :: Type
ip_name = FastString -> Type
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; TyCoVar
ip_var <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
origin (Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
ip_name, Type
ip_ty])
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
(Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
ip_name Type
ip_ty (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (TyCoVar -> GenLocated SrcSpanAnnN TyCoVar
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA TyCoVar
ip_var)))
Type
ip_ty ExpRhoType
res_ty }
where
fromDict :: Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
x Type
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
Type -> TcCoercionR
unwrapIP (Type -> TcCoercionR) -> Type -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
x,Type
ty]
origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x
tcExpr e :: HsExpr GhcRn
e@(HsLam XLam GhcRn
x HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- HsExpr GhcRn
-> HsLamVariant
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr GhcRn
e HsLamVariant
lam_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches [] ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLam GhcTc
-> HsLamVariant -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTc
x HsLamVariant
lam_variant MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
tcExpr (ExplicitList XExplicitList GhcRn
_ [LHsExpr GhcRn]
exprs) ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
; let tc_elt :: LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt LocatedA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
expr Type
elt_ty
; [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' <- (LocatedA (HsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [LocatedA (HsExpr GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tc_elt [LHsExpr GhcRn]
[LocatedA (HsExpr GhcRn)]
exprs
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcTc
Type
elt_ty [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' }
tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcRn]
tup_args Boxity
boxity) ExpRhoType
res_ty
| (HsTupArg GhcRn -> Bool) -> [HsTupArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsTupArg GhcRn -> Bool
forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg GhcRn]
tup_args
= do { let arity :: Int
arity = [HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args
tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
tup_tc Type
res_ty
; let arg_tys' :: [Type]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
Boxity
Boxed -> [Type]
arg_tys
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcCheckExplicitTuple [HsTupArg GhcRn]
tup_args [Type]
arg_tys'
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity) }
| Bool
otherwise
=
do { ([HsTupArg GhcTc]
tup_args1, [Type]
arg_tys) <- Boxity -> [HsTupArg GhcRn] -> TcM ([HsTupArg GhcTc], [Type])
tcInferTupArgs Boxity
boxity [HsTupArg GhcRn]
tup_args
; let expr' :: HsExpr GhcTc
expr' = XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity
missing_tys :: [Scaled Type]
missing_tys = [Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
ty | (Missing (Scaled Type
mult Type
_), Type
ty) <- [HsTupArg GhcTc] -> [Type] -> [(HsTupArg GhcTc, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg GhcTc]
tup_args1 [Type]
arg_tys]
act_res_ty :: Type
act_res_ty = [Scaled Type] -> Type -> Type
(() :: Constraint) => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
missing_tys (Boxity -> [Type] -> Type
mkTupleTy1 Boxity
boxity [Type]
arg_tys)
; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_res_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
act_res_ty ExpRhoType
res_ty }
tcExpr (ExplicitSum XExplicitSum GhcRn
_ Int
alt Int
arity LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
sum_tc Type
res_ty
;
let arg_tys' :: [Type]
arg_tys' = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
arg_ty :: Type
arg_ty = [Type]
arg_tys' [Type] -> Int -> Type
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (Maybe Int -> FixedRuntimeRepContext
FRRUnboxedSum Maybe Int
forall a. Maybe a
Nothing) Type
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [Type]
XExplicitSum GhcTc
arg_tys' Int
alt Int
arity LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' ) }
tcExpr (HsLet XLet GhcRn
x HsLocalBinds GhcRn
binds LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { (HsLocalBinds GhcTc
binds', HsWrapper
wrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc)
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc -> HsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x HsLocalBinds GhcTc
binds' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrapper LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr')) }
tcExpr (HsCase XCase GhcRn
ctxt LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
= do {
Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut', Type
scrut_ty) <- Type -> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
mult (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
scrut
; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRCase Type
scrut_ty
; (HsWrapper
mult_co_wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- TcMatchAltChecker HsExpr
-> Scaled Type
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
(AnnoBody body, Outputable (body GhcTc)) =>
TcMatchAltChecker body
-> Scaled Type
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
tcCaseMatches LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
scrut_ty) MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
XCase GhcTc
ctxt (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
mult_co_wrap LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut') MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
tcExpr (HsIf XIf GhcRn
x LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpRhoType
res_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred Type
boolTy
; (UsageEnv
u1,GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
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') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
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)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
XIf GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
b2') }
tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpRhoType
res_ty
= do { [GenLocated
(Anno (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' <- HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> [LGRHS GhcRn (LocatedA (HsExpr GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
IfAlt LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody [LGRHS GhcRn (LHsExpr GhcRn)]
[LGRHS GhcRn (LocatedA (HsExpr GhcRn))]
alts ExpRhoType
res_ty
; Type
res_ty <- ExpRhoType -> TcM Type
forall (m :: * -> *). MonadIO m => ExpRhoType -> m Type
readExpType ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcTc -> [LGRHS GhcTc (LHsExpr GhcTc)] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcTc
Type
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
(Anno (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts') }
tcExpr (HsDo XDo GhcRn
_ HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
= HsDoFlavour
-> LocatedL [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
LocatedL [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 (EpAnn NoEpAnns) (HsCmdTop GhcTc)
cmd', TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XProc GhcTc -> LPat GhcTc -> LHsCmdTop GhcTc -> HsExpr GhcTc
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
XProc GhcTc
x LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LHsCmdTop GhcTc
GenLocated (EpAnn NoEpAnns) (HsCmdTop GhcTc)
cmd') }
tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
co, (Type
p_ty, Type
expr_ty)) <- Type -> TcM (TcCoercionR, (Type, Type))
matchExpectedAppTy Type
res_ty
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', WantedConstraints
lie) <- IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the body of a static form:")
Int
2 (LocatedA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
expr)
) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
expr_ty
; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
checkClosedInStaticForm ([Name] -> TcRn ()) -> [Name] -> TcRn ()
forall a b. (a -> b) -> a -> b
$ UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet XStatic GhcRn
UniqSet Name
fvs
; Class
typeableClass <- Name -> TcM Class
tcLookupClass Name
typeableClassName
; TyCoVar
typeable_ev <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
StaticOrigin (Type -> TcM TyCoVar) -> Type -> TcM TyCoVar
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
[Type
liftedTypeKind, Type
expr_ty]
; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie
; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
[Type
p_ty]
; let wrap :: HsWrapper
wrap = [TyCoVar] -> HsWrapper
mkWpEvVarApps [TyCoVar
typeable_ev] HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type
expr_ty]
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; TyCon
static_ptr_ty_con <- Name -> TcM TyCon
tcLookupTyCon Name
staticPtrTyConName
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
NoExtField
noExtField
(SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
(SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic (XStatic GhcRn
UniqSet Name
fvs, TyCon -> [Type] -> Type
mkTyConApp TyCon
static_ptr_ty_con [Type
expr_ty]) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'))
}
tcExpr (HsEmbTy XEmbTy GhcRn
_ LHsWcType (NoGhcTc GhcRn)
_) ExpRhoType
_ = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWith TcRnMessage
TcRnIllegalTypeExpr
tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L SrcSpanAnnN
loc Name
con_name
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) ExpRhoType
res_ty
= do { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
con_name
; (HsExpr GhcTc
con_expr, Type
con_sigma) <- Name -> TcM (HsExpr GhcTc, Type)
tcInferId Name
con_name
; (HsWrapper
con_wrap, Type
con_tau) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
con_sigma
; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
Right ([Scaled Type]
arg_tys, Type
actual_res_ty) = Int -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN Int
arity Type
con_tau
; Bool -> TcRnMessage -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con_like) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> TcRnMessage
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' <- ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) HsRecordBinds GhcRn
rbinds
; let rcon_tc :: HsExpr GhcTc
rcon_tc = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr
expr' :: HsExpr GhcTc
expr' = RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = XRecordCon GhcTc
HsExpr GhcTc
rcon_tc
, rcon_con :: XRec GhcTc (ConLikeP GhcTc)
rcon_con = SrcSpanAnnN -> ConLike -> GenLocated SrcSpanAnnN ConLike
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc ConLike
con_like
, rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecordBinds GhcTc
HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' }
; HsExpr GhcTc
ret <- HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
actual_res_ty ExpRhoType
res_ty
; ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 -> LHsRecUpdFields p
rupd_flds =
RegularRecUpdFields
{ xRecUpdFields :: forall p. LHsRecUpdFields p -> XLHsRecUpdLabels p
xRecUpdFields = XLHsRecUpdLabels GhcRn
possible_parents
, recUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdField p p]
recUpdFields = [LHsRecUpdField GhcRn GhcRn]
rbnds }
})
ExpRhoType
res_ty
= Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LHsRecUpdField GhcRn GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
rbnds) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do {
; (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt)
<- LHsExpr GhcRn
-> NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
expandRecordUpd LHsExpr GhcRn
record_expr NonEmpty (HsRecUpdParent GhcRn)
XLHsRecUpdLabels GhcRn
possible_parents [LHsRecUpdField GhcRn GhcRn]
rbnds ExpRhoType
res_ty
; HsExpr GhcTc
expr' <- SDoc -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
expr HsExpr GhcRn
ds_expr) (Type -> ExpRhoType
Check Type
ds_res_ty)
; SDoc -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
ds_res_ty ExpRhoType
res_ty
}
tcExpr e :: HsExpr GhcRn
e@(RecordUpd { rupd_flds :: forall p. HsExpr p -> LHsRecUpdFields p
rupd_flds = OverloadedRecUpdFields {}}) ExpRhoType
_
= String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr: unexpected overloaded-dot RecordUpd" (SDoc -> TcM (HsExpr GhcTc)) -> SDoc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e
tcExpr (ArithSeq XArithSeq GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq) ExpRhoType
res_ty
= Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpRhoType
res_ty
tcExpr (HsGetField XGetField GhcRn
_ LHsExpr GhcRn
_ XRec GhcRn (DotFieldOcc GhcRn)
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ NonEmpty (XRec GhcRn (DotFieldOcc GhcRn))
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
tcExpr (HsTypedSplice XTypedSplice GhcRn
ext LHsExpr GhcRn
splice) ExpRhoType
res_ty = Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedSplice XTypedSplice GhcRn
Name
ext LHsExpr GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsTypedBracket XTypedBracket GhcRn
_ LHsExpr GhcRn
body) ExpRhoType
res_ty = HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e LHsExpr GhcRn
body ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUntypedBracket XUntypedBracket GhcRn
ps HsQuote GhcRn
body) ExpRhoType
res_ty = HsExpr GhcRn
-> HsQuote GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsQuote GhcRn
body [PendingRnSplice]
XUntypedBracket GhcRn
ps ExpRhoType
res_ty
tcExpr (HsUntypedSplice XUntypedSplice GhcRn
splice HsUntypedSplice GhcRn
_) ExpRhoType
res_ty
= do { HsExpr GhcRn
expr <- HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn)
getUntypedSpliceBody XUntypedSplice GhcRn
HsUntypedSpliceResult (HsExpr GhcRn)
splice
; HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty }
tcExpr (HsOverLabel {}) ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsOverLabel" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionL {}) ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionL" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionR {}) ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionR" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr (PopErrCtxt (L SrcSpanAnnA
loc HsExpr GhcRn
e)) ExpRhoType
res_ty
= TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. TcM a -> TcM a
popErrCtxt (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e ExpRhoType
res_ty
tcXExpr xe :: XXExprGhcRn
xe@(ExpandedThingRn HsThingRn
o HsExpr GhcRn
e') ExpRhoType
res_ty
| OrigStmt ls :: ExprLStmt GhcRn
ls@(L SrcSpanAnnA
loc s :: StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))
s@LetStmt{}) <- HsThingRn
o
, HsLet XLet GhcRn
x HsLocalBinds GhcRn
binds LHsExpr GhcRn
e <- HsExpr GhcRn
e'
= do { (HsLocalBinds GhcTc
binds', HsWrapper
wrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc)
e') <- SrcSpanAnnA
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
ExprStmt GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. ExprStmt GhcRn -> TcRn a -> TcRn a
addStmtCtxt ExprStmt GhcRn
StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))
s (IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsLocalBinds GhcTc, HsWrapper,
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc)
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, HsWrapper, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
e ExpRhoType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ ExprLStmt GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedStmtTc ExprLStmt GhcRn
ls (XLet GhcTc -> HsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x HsLocalBinds GhcTc
binds' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrapper LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e'))
}
| OrigStmt ls :: ExprLStmt GhcRn
ls@(L SrcSpanAnnA
loc s :: StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))
s@LastStmt{}) <- HsThingRn
o
= SrcSpanAnnA -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
ExprStmt GhcRn -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. ExprStmt GhcRn -> TcRn a -> TcRn a
addStmtCtxt ExprStmt GhcRn
StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))
s (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
ExprLStmt GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedStmtTc ExprLStmt GhcRn
ls (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e' ExpRhoType
res_ty
| OrigStmt ls :: ExprLStmt GhcRn
ls@(L SrcSpanAnnA
loc StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))
_) <- HsThingRn
o
= SrcSpanAnnA -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
ExprLStmt GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedStmtTc ExprLStmt GhcRn
ls (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp (XXExpr GhcRn -> HsExpr GhcRn
forall p. XXExpr p -> HsExpr p
XExpr XXExpr GhcRn
XXExprGhcRn
xe) ExpRhoType
res_ty
tcXExpr XXExprGhcRn
xe ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp (XXExpr GhcRn -> HsExpr GhcRn
forall p. XXExpr p -> HsExpr p
XExpr XXExpr GhcRn
XXExprGhcRn
xe) ExpRhoType
res_ty
tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From LHsExpr GhcRn
expr) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <-Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
elt_ty
; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromName [Type
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenName [Type
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_then Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromToName [Type
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_to Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2 LHsExpr GhcRn
expr3) ExpRhoType
res_ty
= do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 Type
elt_ty
; HsExpr GhcTc
eft <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenToName [Type
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
eft Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3') }
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpRhoType
res_ty
= do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
; (HsWrapper, Type, Type, Maybe SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsWrapper, Type, Type, Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, Type
OneTy, Type
elt_ty, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpRhoType
res_ty
= do { ((Type
elt_mult, Type
elt_ty), SyntaxExprTc
fl')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM (Type, Type))
-> TcM ((Type, Type), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
SyntaxExprRn
fl [SyntaxOpType
SynList] ExpRhoType
res_ty (([Type] -> [Type] -> TcM (Type, Type))
-> TcM ((Type, Type), SyntaxExprTc))
-> ([Type] -> [Type] -> TcM (Type, Type))
-> TcM ((Type, Type), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [Type
elt_ty] [Type
elt_mult] -> (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
elt_mult, Type
elt_ty)
; (HsWrapper, Type, Type, Maybe SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (HsWrapper, Type, Type, Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, Type
elt_mult, Type
elt_ty, SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fl') }
tcCheckExplicitTuple :: [HsTupArg GhcRn]
-> [TcSigmaType]
-> TcM [HsTupArg GhcTc]
tcCheckExplicitTuple :: [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcCheckExplicitTuple [HsTupArg GhcRn]
args [Type]
tys
= do Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([HsTupArg GhcRn] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [HsTupArg GhcRn]
args [Type]
tys)
Int -> TcRn ()
checkTupSize ([HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
(Int
-> HsTupArg GhcRn
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc))
-> [Int] -> [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M Int
-> HsTupArg GhcRn
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go [Int
1,Int
2..] [HsTupArg GhcRn]
args [Type]
tys
where
go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
go :: Int
-> HsTupArg GhcRn
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go Int
i (Missing {}) Type
arg_ty
= String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcCheckExplicitTuple: tuple sections not handled here"
(Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
go Int
i (Present XPresent GhcRn
x LHsExpr GhcRn
expr) Type
arg_ty
= do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
; (TcCoercionR
co, Type
_) <- (() :: Constraint) =>
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
hasFixedRuntimeRep (Int -> FixedRuntimeRepContext
FRRUnboxedTuple Int
i) Type
arg_ty
; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
co) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr')) }
tcInferTupArgs :: Boxity
-> [HsTupArg GhcRn]
-> TcM ([HsTupArg GhcTc], [TcSigmaTypeFRR])
tcInferTupArgs :: Boxity -> [HsTupArg GhcRn] -> TcM ([HsTupArg GhcTc], [Type])
tcInferTupArgs Boxity
boxity [HsTupArg GhcRn]
args
= do { Int -> TcRn ()
checkTupSize ([HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
; (Int
-> HsTupArg GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type))
-> [Int] -> [HsTupArg GhcRn] -> TcM ([HsTupArg GhcTc], [Type])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM Int
-> HsTupArg GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
tc_infer_tup_arg [Int
1,Int
2..] [HsTupArg GhcRn]
args }
where
tc_infer_tup_arg :: Int -> HsTupArg GhcRn -> TcM (HsTupArg GhcTc, TcSigmaTypeFRR)
tc_infer_tup_arg :: Int
-> HsTupArg GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
tc_infer_tup_arg Int
i (Missing {})
= do { Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; Type
arg_ty <- Int -> TcM Type
new_arg_ty Int
i
; (HsTupArg GhcTc, Type)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty), Type
arg_ty) }
tc_infer_tup_arg Int
i (Present XPresent GhcRn
x lexpr :: LHsExpr GhcRn
lexpr@(L SrcSpanAnnA
l HsExpr GhcRn
expr))
= do { (HsExpr GhcTc
expr', Type
arg_ty) <- case Boxity
boxity of
Boxity
Unboxed -> FixedRuntimeRepContext
-> (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a.
FixedRuntimeRepContext -> (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInferFRR (Int -> FixedRuntimeRepContext
FRRUnboxedTuple Int
i) (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr)
Boxity
Boxed -> do { Type
arg_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; L SrcSpanAnnA
_ HsExpr GhcTc
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
lexpr Type
arg_ty
; (HsExpr GhcTc, Type) -> TcM (HsExpr GhcTc, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr', Type
arg_ty) }
; (HsTupArg GhcTc, Type)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr GhcTc
expr'), Type
arg_ty) }
new_arg_ty :: Int -> TcM TcTypeFRR
new_arg_ty :: Int -> TcM Type
new_arg_ty Int
i =
case Boxity
boxity of
Boxity
Unboxed -> FixedRuntimeRepContext -> TcM Type
newOpenFlexiFRRTyVarTy (Int -> FixedRuntimeRepContext
FRRUnboxedTupleSection Int
i)
Boxity
Boxed -> Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
= CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpRhoType -> SyntaxOpType
SynType ExpRhoType
res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (HsExpr GhcTc
expr, Type
sigma) <- (HsExpr GhcRn, AppCtxt) -> TcM (HsExpr GhcTc, Type)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan)
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sigma)
; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
<- CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
[Type] -> [Type] -> TcM a
thing_inside
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sigma )
; (a, SyntaxExprTc) -> TcM (a, SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
expr_wrap HsExpr GhcTc
expr
, syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: HsWrapper
syn_res_wrap = HsWrapper
res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [Type] -> [Type] -> TcM a
_ = String -> TcM (a, SyntaxExprTc)
forall a. HasCallStack => String -> a
panic String
"tcSyntaxOpGen"
tcSynArgE :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty SyntaxOpType
syn_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
<- DeepSubsumptionFlag
-> UserTypeCtxt
-> Type
-> (Type -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
DeepSubsumptionFlag
-> UserTypeCtxt
-> Type
-> (Type -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise DeepSubsumptionFlag
Shallow UserTypeCtxt
GenSigCtxt Type
sigma_ty ((Type -> TcM (a, HsWrapper)) -> TcM (HsWrapper, (a, HsWrapper)))
-> (Type -> TcM (a, HsWrapper)) -> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \Type
rho_ty ->
Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
syn_ty
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
skol_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
ty_wrapper) }
where
go :: Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
SynAny
= do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynRho
= do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynList
= do { (TcCoercionR
list_co, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
; a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
elt_ty] []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
list_co) }
go Type
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
= do { ( HsWrapper
match_wrapper
, ( ( (a
result, Type
arg_ty, Type
res_ty, Type
op_mult)
, HsWrapper
res_wrapper )
, HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )
<- ExpectedFunTyOrigin
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([ExpPatType]
-> ExpRhoType
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
-> TcM
(HsWrapper,
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([ExpPatType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
GenSigCtxt Int
1 (Type -> ExpRhoType
mkCheckExpType Type
rho_ty) (([ExpPatType]
-> ExpRhoType
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
-> TcM
(HsWrapper,
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper)))
-> ([ExpPatType]
-> ExpRhoType
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
-> TcM
(HsWrapper,
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
forall a b. (a -> b) -> a -> b
$
\ [ExpFunPatTy Scaled ExpRhoType
arg_ty] ExpRhoType
res_ty ->
do { Type
arg_tc_ty <- ExpRhoType -> TcM Type
expTypeToType (Scaled ExpRhoType -> ExpRhoType
forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
; Type
res_tc_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; Bool -> SDoc -> TcRn ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (case SyntaxOpType
arg_shape of
SynFun {} -> Bool
False;
SyntaxOpType
_ -> Bool
True)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Too many nested arrows in SyntaxOpType" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig)
; let arg_mult :: Type
arg_mult = Scaled ExpRhoType -> Type
forall a. Scaled a -> Type
scaledMult Scaled ExpRhoType
arg_ty
; CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
arg_tc_ty [] SyntaxOpType
arg_shape (([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper))
-> ([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
-> TcM
(((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
HsWrapper)
forall a b. (a -> b) -> a -> b
$
\ [Type]
arg_results [Type]
arg_res_mults ->
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
res_tc_ty SyntaxOpType
res_shape (([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper))
-> ([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper)
forall a b. (a -> b) -> a -> b
$
\ [Type]
res_results [Type]
res_res_mults ->
do { a
result <- [Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_results) ([Type
arg_mult] [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_res_mults)
; (a, Type, Type, Type) -> TcM (a, Type, Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Type
arg_tc_ty, Type
res_tc_ty, Type
arg_mult) }}
; let fun_wrap :: HsWrapper
fun_wrap = HsWrapper -> HsWrapper -> Scaled Type -> Type -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
(Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
op_mult Type
arg_ty) Type
res_ty
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
fun_wrap) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
CtOrigin -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op
go Type
rho_ty (SynType ExpRhoType
the_ty)
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> Type -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty Type
rho_ty
; a
result <- [Type] -> [Type] -> TcM a
thing_inside [] []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
tcSynArgA :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [Type] -> [Type] -> TcM a
thing_inside
= do { (HsWrapper
match_wrapper, [Scaled Type]
arg_tys, Type
res_ty)
<- ExpectedFunTyOrigin
-> CtOrigin -> Int -> Type -> TcM (HsWrapper, [Scaled Type], Type)
matchActualFunTys ExpectedFunTyOrigin
herald CtOrigin
orig ([SyntaxOpType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) Type
sigma_ty
; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
<- [Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [SyntaxOpType]
arg_shapes (([Type] -> [Type] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper]))
-> ([Type] -> [Type] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [Type]
arg_results [Type]
arg_res_mults ->
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg Type
res_ty SyntaxOpType
res_shape (([Type] -> TcM a) -> TcM (a, HsWrapper))
-> ([Type] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [Type]
res_results ->
[Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_results) ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult [Scaled Type]
arg_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults)
; (a, HsWrapper, [HsWrapper], HsWrapper)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
CtOrigin -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op
tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e :: forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (Type
arg_ty : [Type]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [Type] -> [Type] -> TcM a
thing_inside
= do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
<- CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
arg_ty SyntaxOpType
arg_shape (([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper))
-> ([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [Type]
arg1_results [Type]
arg1_mults ->
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [Type]
arg_tys [SyntaxOpType]
arg_shapes (([Type] -> [Type] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([Type] -> [Type] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [Type]
args_results [Type]
args_mults ->
[Type] -> [Type] -> TcM a
thing_inside ([Type]
arg1_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args_results) ([Type]
arg1_mults [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args_mults)
; (a, [HsWrapper]) -> TcM (a, [HsWrapper])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
arg_wrap HsWrapper -> [HsWrapper] -> [HsWrapper]
forall a. a -> [a] -> [a]
: [HsWrapper]
arg_wraps) }
tc_syn_args_e [Type]
_ [SyntaxOpType]
_ [Type] -> [Type] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> TcM a
thing_inside [] []
tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType
-> ([TcSigmaTypeFRR] -> TcM a)
-> TcM (a, HsWrapper)
tc_syn_arg :: forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg Type
res_ty SyntaxOpType
SynAny [Type] -> TcM a
thing_inside
= do { a
result <- [Type] -> TcM a
thing_inside [Type
res_ty]
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
tc_syn_arg Type
res_ty SyntaxOpType
SynRho [Type] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; a
result <- [Type] -> TcM a
thing_inside [Type
rho_ty]
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
tc_syn_arg Type
res_ty SyntaxOpType
SynList [Type] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; (TcCoercionR
list_co, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
; a
result <- [Type] -> TcM a
thing_inside [Type
elt_ty]
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
tc_syn_arg Type
_ (SynFun {}) [Type] -> TcM a
_
= String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
tc_syn_arg Type
res_ty (SynType ExpRhoType
the_ty) [Type] -> TcM a
thing_inside
= do { HsWrapper
wrap <- CtOrigin -> UserTypeCtxt -> Type -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt Type
res_ty ExpRhoType
the_ty
; a
result <- [Type] -> TcM a
thing_inside []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
expandRecordUpd :: LHsExpr GhcRn
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM ( HsExpr GhcRn
, TcType
, SDoc
)
expandRecordUpd :: LHsExpr GhcRn
-> NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
expandRecordUpd LHsExpr GhcRn
record_expr NonEmpty (HsRecUpdParent GhcRn)
possible_parents [LHsRecUpdField GhcRn GhcRn]
rbnds ExpRhoType
res_ty
= do {
; ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
_, Type
record_rho), WantedConstraints
_lie) <- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> TcM
((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> TcM
((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> TcM
((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
Type -> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
ManyTy (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
record_expr
; (UniqSet ConLike
cons, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds)
<- LHsExpr GhcRn
-> Type
-> NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn])
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho NonEmpty (HsRecUpdParent GhcRn)
possible_parents [LHsRecUpdField GhcRn GhcRn]
rbnds ExpRhoType
res_ty
; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc)
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds
sel_ids :: [TyCoVar]
sel_ids = (AmbiguousFieldOcc GhcTc -> TyCoVar)
-> [AmbiguousFieldOcc GhcTc] -> [TyCoVar]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> TyCoVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
upd_fld_names :: [Name]
upd_fld_names = (TyCoVar -> Name) -> [TyCoVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Name
idName [TyCoVar]
sel_ids
relevant_cons :: [ConLike]
relevant_cons = UniqSet ConLike -> [ConLike]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ConLike
cons
relevant_con :: ConLike
relevant_con = [ConLike] -> ConLike
forall a. HasCallStack => [a] -> a
head [ConLike]
relevant_cons
; let ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
_, [Type]
_, [Scaled Type]
arg_tys, Type
con_res_ty) = ConLike
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Type], [Scaled Type],
Type)
conLikeFullSig ConLike
relevant_con
; (Subst
subst, [TyCoVar]
tc_tvs) <- [TyCoVar] -> TcM (Subst, [TyCoVar])
newMetaTyVars ([TyCoVar]
univ_tvs [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++ [TyCoVar]
ex_tvs)
; let ([Type]
actual_univ_tys, [Type]
_actual_ex_tys) = [TyCoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [TyCoVar]
univ_tvs ([Type] -> ([Type], [Type])) -> [Type] -> ([Type], [Type])
forall a b. (a -> b) -> a -> b
$ (TyCoVar -> Type) -> [TyCoVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Type
mkTyVarTy [TyCoVar]
tc_tvs
ds_res_ty :: Type
ds_res_ty = case ConLike
relevant_con of
RealDataCon DataCon
con
| Bool -> Bool
not ([EqSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec)
-> TyCon -> [Type] -> Type
mkFamilyTyConApp (DataCon -> TyCon
dataConTyCon DataCon
con) [Type]
actual_univ_tys
ConLike
_ -> (() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
con_res_ty
; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn))
mk_upd_id :: forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id Name
fld_nm (L SrcSpanAnnA
_ HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind)
= do { let Scaled Type
_ Type
arg_ty = NameEnv (Scaled Type) -> Name -> Scaled Type
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv (Scaled Type)
arg_ty_env Name
fld_nm
nm_occ :: OccName
nm_occ = RdrName -> OccName
rdrNameOcc (RdrName -> OccName) -> (Name -> RdrName) -> Name -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ Name
fld_nm
actual_arg_ty :: Type
actual_arg_ty = (() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
arg_ty
rhs :: LocatedA (HsExpr GhcRn)
rhs = HsFieldBind fld (LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind
; (TcCoercionR
_co, Type
actual_arg_ty) <- (() :: Constraint) =>
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
hasFixedRuntimeRep (Name -> HsExpr GhcRn -> FixedRuntimeRepContext
FRRRecordUpdate Name
fld_nm (LocatedA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr GhcRn)
rhs)) Type
actual_arg_ty
; Name
nm <- OccName -> SrcSpan -> TcM Name
newNameAt OccName
nm_occ SrcSpan
generatedSrcSpan
; let id :: TyCoVar
id = (() :: Constraint) => Name -> Type -> Type -> TyCoVar
Name -> Type -> Type -> TyCoVar
mkLocalId Name
nm Type
ManyTy Type
actual_arg_ty
; (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fld_nm, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs))
}
arg_ty_env :: NameEnv (Scaled Type)
arg_ty_env = [(Name, Scaled Type)] -> NameEnv (Scaled Type)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv
([(Name, Scaled Type)] -> NameEnv (Scaled Type))
-> [(Name, Scaled Type)] -> NameEnv (Scaled Type)
forall a b. (a -> b) -> a -> b
$ (FieldLabel -> Scaled Type -> (Name, Scaled Type))
-> [FieldLabel] -> [Scaled Type] -> [(Name, Scaled Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ FieldLabel
lbl Scaled Type
arg_ty -> (FieldLabel -> Name
flSelector FieldLabel
lbl, Scaled Type
arg_ty))
(ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
relevant_con)
[Scaled Type]
arg_tys
; String -> SDoc -> TcRn ()
traceTc String
"tcRecordUpd" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"upd_fld_names:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
upd_fld_names
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"relevant_cons:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ConLike] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ConLike]
relevant_cons ]
; [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids <- (Name
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn))))
-> [Name]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name
-> LHsFieldBind
GhcTc
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
Name
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id [Name]
upd_fld_names [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds
; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)
updEnv :: UniqMap Name (TyCoVar, LHsExpr GhcRn)
updEnv = [(Name, (TyCoVar, LHsExpr GhcRn))]
-> UniqMap Name (TyCoVar, LHsExpr GhcRn)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(Name, (TyCoVar, LHsExpr GhcRn))]
-> UniqMap Name (TyCoVar, LHsExpr GhcRn))
-> [(Name, (TyCoVar, LHsExpr GhcRn))]
-> UniqMap Name (TyCoVar, LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ [(Name, (TyCoVar, LHsExpr GhcRn))]
[(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat ConLike
conLike = HsMatchContext (LIdP (NoGhcTc GhcRn))
-> [LPat GhcRn]
-> LocatedA (HsExpr GhcRn)
-> LMatch GhcRn (LocatedA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (LIdP (NoGhcTc GhcRn))
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
RecUpd [LPat GhcRn
pat] LocatedA (HsExpr GhcRn)
rhs
where
([GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats, [LocatedA (HsExpr GhcRn)]
rhs_con_args)
= (Int
-> FieldLabel
-> (GenLocated SrcSpanAnnA (Pat GhcRn), LocatedA (HsExpr GhcRn)))
-> [Int]
-> [FieldLabel]
-> ([GenLocated SrcSpanAnnA (Pat GhcRn)],
[LocatedA (HsExpr GhcRn)])
forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
Int
-> FieldLabel
-> (GenLocated SrcSpanAnnA (Pat GhcRn), LocatedA (HsExpr GhcRn))
mk_con_arg [Int
1..] [FieldLabel]
con_fields
pat :: LPat GhcRn
pat = Name -> [LPat GhcRn] -> LPat GhcRn
genSimpleConPat Name
con [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats
rhs :: LocatedA (HsExpr GhcRn)
rhs = HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall an a. NoAnn an => a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> LocatedA (HsExpr GhcRn))
-> HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps Name
con [LHsExpr GhcRn]
[LocatedA (HsExpr GhcRn)]
rhs_con_args
con :: Name
con = ConLike -> Name
conLikeName ConLike
conLike
con_fields :: [FieldLabel]
con_fields = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
conLike
mk_con_arg :: Int
-> FieldLabel
-> ( LPat GhcRn
, LHsExpr GhcRn )
mk_con_arg :: Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
mk_con_arg Int
i FieldLabel
fld_lbl =
case UniqMap Name (TyCoVar, LocatedA (HsExpr GhcRn))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name (TyCoVar, LHsExpr GhcRn)
UniqMap Name (TyCoVar, LocatedA (HsExpr GhcRn))
updEnv (Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn)))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
flSelector FieldLabel
fld_lbl of
Just (TyCoVar
upd_id, LocatedA (HsExpr GhcRn)
_) -> (LPat GhcRn
genWildPat, Name -> LHsExpr GhcRn
genLHsVar (TyCoVar -> Name
idName TyCoVar
upd_id))
Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
_ -> let fld_nm :: Name
fld_nm = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
i)
(Name -> OccName
nameOccName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
flSelector (FieldLabel -> Name) -> FieldLabel -> Name
forall a b. (a -> b) -> a -> b
$ FieldLabel
fld_lbl)
SrcSpan
generatedSrcSpan
in (Name -> LPat GhcRn
genVarPat Name
fld_nm, Name -> LHsExpr GhcRn
genLHsVar Name
fld_nm)
; let ds_expr :: HsExpr GhcRn
ds_expr :: HsExpr GhcRn
ds_expr = XLet GhcRn -> HsLocalBinds GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
NoExtField
noExtField HsLocalBinds GhcRn
let_binds (SrcSpanAnnA -> HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
gen HsExpr GhcRn
case_expr)
case_expr :: HsExpr GhcRn
case_expr :: HsExpr GhcRn
case_expr = XCase GhcRn
-> LHsExpr GhcRn
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> HsExpr GhcRn
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
RecUpd LHsExpr GhcRn
record_expr
(MatchGroup GhcRn (LHsExpr GhcRn) -> HsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn) -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedL [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup (GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
DoPmc) ([LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> LocatedL [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall an a. NoAnn an => a -> LocatedAn an a
wrapGenSpan [LMatch GhcRn (LHsExpr GhcRn)]
[LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = (ConLike -> LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn))))
-> [ConLike] -> [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> LMatch GhcRn (LHsExpr GhcRn)
ConLike -> LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))
make_pat [ConLike]
relevant_cons
let_binds :: HsLocalBindsLR GhcRn GhcRn
let_binds :: HsLocalBinds GhcRn
let_binds = XHsValBinds GhcRn GhcRn
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcRn
EpAnn AnnList
forall a. NoAnn a => a
noAnn (HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn)
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$ XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
(XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn)
-> XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn
forall a b. (a -> b) -> a -> b
$ [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR GhcRn
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds GhcRn)]
upd_ids_lhs (((Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpanAnnA (Sig GhcRn))
-> [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpanAnnA (Sig GhcRn)
mk_idSig [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids)
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs :: [(RecFlag, LHsBinds GhcRn)]
upd_ids_lhs = [ (RecFlag
NonRecursive, LHsBind GhcRn -> LHsBinds GhcRn
forall a. a -> Bag a
unitBag (LHsBind GhcRn -> LHsBinds GhcRn)
-> LHsBind GhcRn -> LHsBinds GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> [LPat GhcRn] -> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind (TyCoVar -> Name
idName TyCoVar
id) [] LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs)
| (Name
_, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs)) <- [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids ]
mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig :: (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig (Name
_, (TyCoVar
id, LHsExpr GhcRn
_)) = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
gen (Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XXSig GhcRn -> Sig GhcRn
forall pass. XXSig pass -> Sig pass
XSig (XXSig GhcRn -> Sig GhcRn) -> XXSig GhcRn -> Sig GhcRn
forall a b. (a -> b) -> a -> b
$ TyCoVar -> IdSig
IdSig TyCoVar
id
gen :: SrcSpanAnnA
gen = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
generatedSrcSpan
; String -> SDoc -> TcRn ()
traceTc String
"expandRecordUpd" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"relevant_con:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
relevant_con
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"res_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_res_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ds_res_ty
]
; let cons :: SDoc
cons = [ConLike] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [ConLike]
relevant_cons
err_lines :: [SDoc]
err_lines =
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In a record update at field" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
upd_fld_names SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Name]
upd_fld_names :)
([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ case ConLike
relevant_con of
RealDataCon DataCon
con ->
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with type constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> TyCon
dataConTyCon DataCon
con))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"data constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ConLike] -> SDoc
forall a. [a] -> SDoc
plural [ConLike]
relevant_cons SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
PatSynCon {} ->
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with pattern synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ConLike] -> SDoc
forall a. [a] -> SDoc
plural [ConLike]
relevant_cons SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
[SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ if [TyCoVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ex_tvs
then []
else [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"existential variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
ex_tvs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
ex_tvs ]
err_ctxt :: SDoc
err_ctxt = [SDoc] -> SDoc
make_lines_msg [SDoc]
err_lines
; (HsExpr GhcRn, Type, SDoc) -> TcM (HsExpr GhcRn, Type, SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt) }
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg [] = SDoc
forall doc. IsOutput doc => doc
empty
make_lines_msg [SDoc
last] = SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
last SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
dot
make_lines_msg [SDoc
l1,SDoc
l2] = SDoc
l1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
l2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
dot
make_lines_msg (SDoc
l:[SDoc]
ls) = SDoc
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
make_lines_msg [SDoc]
ls
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType
-> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn])
disambiguateRecordBinds :: LHsExpr GhcRn
-> Type
-> NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn])
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho NonEmpty (HsRecUpdParent GhcRn)
possible_parents [LHsRecUpdField GhcRn GhcRn]
rbnds ExpRhoType
res_ty
= do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; TcRecUpdParent
{ tcRecUpdLabels :: HsRecUpdParent GhcTc -> NonEmpty FieldGlobalRdrElt
tcRecUpdLabels = NonEmpty FieldGlobalRdrElt
lbls
, tcRecUpdCons :: HsRecUpdParent GhcTc -> UniqSet ConLike
tcRecUpdCons = UniqSet ConLike
cons }
<- FamInstEnvs
-> NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc)
identifyParentLabels FamInstEnvs
fam_inst_envs NonEmpty (HsRecUpdParent GhcRn)
possible_parents
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbnds' <- (FieldGlobalRdrElt
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))))
-> [FieldGlobalRdrElt]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM FieldGlobalRdrElt
-> LHsRecUpdField GhcRn GhcRn -> TcM (LHsRecUpdField GhcTc GhcRn)
FieldGlobalRdrElt
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
lookupField (NonEmpty FieldGlobalRdrElt -> [FieldGlobalRdrElt]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FieldGlobalRdrElt
lbls) [LHsRecUpdField GhcRn GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
rbnds
; (UniqSet ConLike,
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(UniqSet ConLike,
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSet ConLike
cons, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbnds') }
where
identifyParentLabels :: FamInstEnvs
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> TcM (HsRecUpdParent GhcTc)
identifyParentLabels :: FamInstEnvs
-> NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc)
identifyParentLabels FamInstEnvs
fam_inst_envs NonEmpty (HsRecUpdParent GhcRn)
possible_parents
= case NonEmpty (HsRecUpdParent GhcRn)
possible_parents of
HsRecUpdParent GhcRn
p NE.:| [] -> HsRecUpdParent GhcRn -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds HsRecUpdParent GhcRn
p
HsRecUpdParent GhcRn
_ NE.:| HsRecUpdParent GhcRn
_ : [HsRecUpdParent GhcRn]
_
| Just TyCon
tc <- FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
res_ty
-> do { NonEmpty (HsRecUpdParent GhcRn) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent GhcRn)
possible_parents TyCon
tc
; TyCon
-> NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent GhcRn)
possible_parents }
| Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LocatedA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
record_expr)
, Just TyCon
tc <- FamInstEnvs -> Type -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs Type
record_rho
-> do { NonEmpty (HsRecUpdParent GhcRn) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent GhcRn)
possible_parents TyCon
tc
; TyCon
-> NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent GhcRn)
possible_parents }
HsRecUpdParent GhcRn
p1 NE.:| HsRecUpdParent GhcRn
p2 : [HsRecUpdParent GhcRn]
ps
-> do { RecSelParent
p1 <- HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent HsRecUpdParent GhcRn
p1
; RecSelParent
p2 <- HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent HsRecUpdParent GhcRn
p2
; [RecSelParent]
ps <- (HsRecUpdParent GhcRn -> TcM RecSelParent)
-> [HsRecUpdParent GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [RecSelParent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent [HsRecUpdParent GhcRn]
ps
; TcRnMessage -> TcM (HsRecUpdParent GhcTc)
forall a. TcRnMessage -> TcRn a
failWithTc (TcRnMessage -> TcM (HsRecUpdParent GhcTc))
-> TcRnMessage -> TcM (HsRecUpdParent GhcTc)
forall a b. (a -> b) -> a -> b
$ [RdrName] -> BadRecordUpdateReason -> TcRnMessage
TcRnBadRecordUpdate ([LHsRecUpdField GhcRn GhcRn] -> [RdrName]
forall (p :: Pass) q.
UnXRec (GhcPass p) =>
[LHsRecUpdField (GhcPass p) q] -> [RdrName]
getUpdFieldLbls [LHsRecUpdField GhcRn GhcRn]
rbnds)
(BadRecordUpdateReason -> TcRnMessage)
-> BadRecordUpdateReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ (RecSelParent, RecSelParent, [RecSelParent])
-> BadRecordUpdateReason
MultiplePossibleParents (RecSelParent
p1, RecSelParent
p2, [RecSelParent]
ps) }
try_disambiguated_tycon :: TyCon
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon :: TyCon
-> NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent GhcRn)
pars
= do { [HsRecUpdParent GhcTc]
pars <- (HsRecUpdParent GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc)))
-> [HsRecUpdParent GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsRecUpdParent GhcTc]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc))
-> TcM (HsRecUpdParent GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc))
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc)
guard_parent TyCon
tc) (TcM (HsRecUpdParent GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc)))
-> (HsRecUpdParent GhcRn -> TcM (HsRecUpdParent GhcTc))
-> HsRecUpdParent GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecUpdParent GhcRn -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds) (NonEmpty (HsRecUpdParent GhcRn) -> [HsRecUpdParent GhcRn]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (HsRecUpdParent GhcRn)
pars)
; case [HsRecUpdParent GhcTc]
pars of
[HsRecUpdParent GhcTc
par] -> HsRecUpdParent GhcTc -> TcM (HsRecUpdParent GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsRecUpdParent GhcTc
par
[] -> do { NonEmpty RecSelParent
pars <- (HsRecUpdParent GhcRn -> TcM RecSelParent)
-> NonEmpty (HsRecUpdParent GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty RecSelParent)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent NonEmpty (HsRecUpdParent GhcRn)
possible_parents
; TcRnMessage -> TcM (HsRecUpdParent GhcTc)
forall a. TcRnMessage -> TcRn a
failWithTc (TcRnMessage -> TcM (HsRecUpdParent GhcTc))
-> TcRnMessage -> TcM (HsRecUpdParent GhcTc)
forall a b. (a -> b) -> a -> b
$ [RdrName] -> BadRecordUpdateReason -> TcRnMessage
TcRnBadRecordUpdate ([LHsRecUpdField GhcRn GhcRn] -> [RdrName]
forall (p :: Pass) q.
UnXRec (GhcPass p) =>
[LHsRecUpdField (GhcPass p) q] -> [RdrName]
getUpdFieldLbls [LHsRecUpdField GhcRn GhcRn]
rbnds)
(BadRecordUpdateReason -> TcRnMessage)
-> BadRecordUpdateReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TyCon -> NonEmpty RecSelParent -> BadRecordUpdateReason
InvalidTyConParent TyCon
tc NonEmpty RecSelParent
pars }
[HsRecUpdParent GhcTc]
_ -> String -> SDoc -> TcM (HsRecUpdParent GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"try_disambiguated_tycon: more than 1 valid parent"
([RecSelParent] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([RecSelParent] -> SDoc) -> [RecSelParent] -> SDoc
forall a b. (a -> b) -> a -> b
$ (HsRecUpdParent GhcTc -> RecSelParent)
-> [HsRecUpdParent GhcTc] -> [RecSelParent]
forall a b. (a -> b) -> [a] -> [b]
map HsRecUpdParent GhcTc -> RecSelParent
tcRecUpdParent [HsRecUpdParent GhcTc]
pars) }
guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc)
guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc)
guard_parent TyCon
disamb_tc cand_parent :: HsRecUpdParent GhcTc
cand_parent@(TcRecUpdParent { tcRecUpdParent :: HsRecUpdParent GhcTc -> RecSelParent
tcRecUpdParent = RecSelParent
cand_tc })
= do { Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon -> RecSelParent
RecSelData TyCon
disamb_tc RecSelParent -> RecSelParent -> Bool
forall a. Eq a => a -> a -> Bool
== RecSelParent
cand_tc)
; HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return HsRecUpdParent GhcTc
cand_parent }
lookup_parent_flds :: HsRecUpdParent GhcRn
-> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds :: HsRecUpdParent GhcRn -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds par :: HsRecUpdParent GhcRn
par@(RnRecUpdParent { rnRecUpdLabels :: HsRecUpdParent GhcRn -> NonEmpty FieldGlobalRdrElt
rnRecUpdLabels = NonEmpty FieldGlobalRdrElt
lbls, rnRecUpdCons :: HsRecUpdParent GhcRn -> UniqSet ConLikeName
rnRecUpdCons = UniqSet ConLikeName
cons })
= do { let cons' :: NonDetUniqFM ConLike ConLikeName
cons' :: NonDetUniqFM ConLike ConLikeName
cons' = UniqFM ConLike ConLikeName -> NonDetUniqFM ConLike ConLikeName
forall {k} (key :: k) ele. UniqFM key ele -> NonDetUniqFM key ele
NonDetUniqFM (UniqFM ConLike ConLikeName -> NonDetUniqFM ConLike ConLikeName)
-> UniqFM ConLike ConLikeName -> NonDetUniqFM ConLike ConLikeName
forall a b. (a -> b) -> a -> b
$ UniqFM ConLikeName ConLikeName -> UniqFM ConLike ConLikeName
forall {k1} {k2} (key1 :: k1) elt (key2 :: k2).
UniqFM key1 elt -> UniqFM key2 elt
unsafeCastUFMKey (UniqFM ConLikeName ConLikeName -> UniqFM ConLike ConLikeName)
-> UniqFM ConLikeName ConLikeName -> UniqFM ConLike ConLikeName
forall a b. (a -> b) -> a -> b
$ UniqSet ConLikeName -> UniqFM ConLikeName ConLikeName
forall a. UniqSet a -> UniqFM a a
getUniqSet UniqSet ConLikeName
cons
; NonDetUniqFM ConLike ConLike
cons <- (ConLikeName -> TcM ConLike)
-> NonDetUniqFM ConLike ConLikeName
-> IOEnv (Env TcGblEnv TcLclEnv) (NonDetUniqFM ConLike ConLike)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonDetUniqFM ConLike a -> f (NonDetUniqFM ConLike b)
traverse (Name -> TcM ConLike
tcLookupConLike (Name -> TcM ConLike)
-> (ConLikeName -> Name) -> ConLikeName -> TcM ConLike
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLikeName -> Name
conLikeName_Name) NonDetUniqFM ConLike ConLikeName
cons'
; RecSelParent
tc <- HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent HsRecUpdParent GhcRn
par
; HsRecUpdParent GhcTc -> TcM (HsRecUpdParent GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRecUpdParent GhcTc -> TcM (HsRecUpdParent GhcTc))
-> HsRecUpdParent GhcTc -> TcM (HsRecUpdParent GhcTc)
forall a b. (a -> b) -> a -> b
$
TcRecUpdParent
{ tcRecUpdParent :: RecSelParent
tcRecUpdParent = RecSelParent
tc
, tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt
tcRecUpdLabels = NonEmpty FieldGlobalRdrElt
lbls
, tcRecUpdCons :: UniqSet ConLike
tcRecUpdCons = UniqFM ConLike ConLike -> UniqSet ConLike
forall a. UniqFM a a -> UniqSet a
unsafeUFMToUniqSet (UniqFM ConLike ConLike -> UniqSet ConLike)
-> UniqFM ConLike ConLike -> UniqSet ConLike
forall a b. (a -> b) -> a -> b
$ NonDetUniqFM ConLike ConLike -> UniqFM ConLike ConLike
forall {k} (key :: k) ele. NonDetUniqFM key ele -> UniqFM key ele
getNonDet NonDetUniqFM ConLike ConLike
cons } }
lookupField :: FieldGlobalRdrElt
-> LHsRecUpdField GhcRn GhcRn
-> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField :: FieldGlobalRdrElt
-> LHsRecUpdField GhcRn GhcRn -> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField FieldGlobalRdrElt
fld_gre (L SrcSpanAnnA
l HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd)
= do { let L SrcSpanAnnA
loc AmbiguousFieldOcc GhcRn
af = HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
lbl :: RdrName
lbl = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
ambiguousFieldOccRdrName AmbiguousFieldOcc GhcRn
af
mb_gre :: [FieldGlobalRdrElt]
mb_gre = RdrName -> [FieldGlobalRdrElt] -> [FieldGlobalRdrElt]
forall info.
RdrName -> [GlobalRdrEltX info] -> [GlobalRdrEltX info]
pickGREs RdrName
lbl [FieldGlobalRdrElt
fld_gre]
; SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (FieldGlobalRdrElt -> TcRn ()) -> [FieldGlobalRdrElt] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DeprecationWarnings -> FieldGlobalRdrElt -> TcRn ()
addUsedGRE DeprecationWarnings
AllDeprecationWarnings) [FieldGlobalRdrElt]
mb_gre
; TyCoVar
sel <- Name -> TcM TyCoVar
tcLookupId (FieldGlobalRdrElt -> Name
forall info. GlobalRdrEltX info -> Name
greName FieldGlobalRdrElt
fld_gre)
; GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
hfbAnn = HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> XHsFieldBind (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbLHS :: GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
hfbLHS = SrcSpanAnnA
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) (AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc))
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcTc)
forall a b. (a -> b) -> a -> b
$ XUnambiguous GhcTc -> XRec GhcTc RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> XRec pass RdrName -> AmbiguousFieldOcc pass
Unambiguous XUnambiguous GhcTc
TyCoVar
sel (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) RdrName
lbl)
, hfbRHS :: LocatedA (HsExpr GhcRn)
hfbRHS = HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbPun :: Bool
hfbPun = HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
} }
reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn)
-> TyCon -> TcM ()
reportAmbiguousUpdate :: NonEmpty (HsRecUpdParent GhcRn) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent GhcRn)
parents TyCon
parent_type =
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnostic (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TyCon -> TcRnMessage
TcRnAmbiguousRecordUpdate HsExpr GhcRn
rupd TyCon
parent_type
where
rupd :: HsExpr GhcRn
rupd = RecordUpd { rupd_expr :: LHsExpr GhcRn
rupd_expr = LHsExpr GhcRn
record_expr
, rupd_flds :: LHsRecUpdFields GhcRn
rupd_flds =
RegularRecUpdFields
{ xRecUpdFields :: XLHsRecUpdLabels GhcRn
xRecUpdFields = NonEmpty (HsRecUpdParent GhcRn)
XLHsRecUpdLabels GhcRn
parents
, recUpdFields :: [LHsRecUpdField GhcRn GhcRn]
recUpdFields = [LHsRecUpdField GhcRn GhcRn]
rbnds }
, rupd_ext :: XRecordUpd GhcRn
rupd_ext = XRecordUpd GhcRn
NoExtField
noExtField }
loc :: SrcSpan
loc = GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
forall a. HasCallStack => [a] -> a
head [LHsRecUpdField GhcRn GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
rbnds)
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds :: ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [Type]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (XRec GhcRn RecFieldsDotDot)
dd)
= do { [Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
rbinds
; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> Maybe (XRec GhcTc RecFieldsDotDot)
-> HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields ([Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds) Maybe (XRec GhcRn RecFieldsDotDot)
Maybe (XRec GhcTc RecFieldsDotDot)
dd) }
where
fields :: [Name]
fields = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, Type)]
flds_w_tys = String -> [Name] -> [Type] -> [(Name, Type)]
forall a b. (() :: Constraint) => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [Type]
arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L SrcSpanAnnA
l fld :: HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
fld@(HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f
, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = LocatedA (HsExpr GhcRn)
rhs }))
= do { Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys LFieldOcc GhcRn
GenLocated SrcSpanAnnA (FieldOcc GhcRn)
f LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs
; case Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing -> Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. Maybe a
Nothing
Just (GenLocated SrcSpanAnnA (FieldOcc GhcTc)
f', GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs') -> Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
hfbAnn = HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
-> XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
fld
, hfbLHS :: GenLocated SrcSpanAnnA (FieldOcc GhcTc)
hfbLHS = GenLocated SrcSpanAnnA (FieldOcc GhcTc)
f'
, hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
, hfbPun :: Bool
hfbPun = HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
fld}))) }
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_name
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field of a record"
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys (L SrcSpanAnnA
loc (FieldOcc XCFieldOcc GhcRn
sel_name XRec GhcRn RdrName
lbl)) LHsExpr GhcRn
rhs
| Just Type
field_ty <- [(Name, Type)] -> Name -> Maybe Type
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, Type)]
flds_w_tys XCFieldOcc GhcRn
Name
sel_name
= SDoc
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_lbl) (TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs Type
field_ty
; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (RdrName -> HsExpr GhcTc -> FixedRuntimeRepContext
FRRRecordCon (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
GenLocated SrcSpanAnnN RdrName
lbl) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'))
Type
field_ty
; let field_id :: TyCoVar
field_id = OccName -> Unique -> Type -> Type -> SrcSpan -> TyCoVar
mkUserLocal (Name -> OccName
nameOccName XCFieldOcc GhcRn
Name
sel_name)
(Name -> Unique
nameUnique XCFieldOcc GhcRn
Name
sel_name)
Type
ManyTy Type
field_ty (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc)
; Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> FieldOcc GhcTc -> GenLocated SrcSpanAnnA (FieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
TyCoVar
field_id XRec GhcRn RdrName
XRec GhcTc RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs')) }
| Bool
otherwise
= do { TcRnMessage -> TcRn ()
addErrTc (Name -> FieldLabelString -> TcRnMessage
badFieldConErr (ConLike -> Name
forall a. NamedThing a => a -> Name
getName ConLike
con_like) FieldLabelString
field_lbl)
; Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(GenLocated SrcSpanAnnA (FieldOcc GhcTc),
GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. Maybe a
Nothing }
where
field_lbl :: FieldLabelString
field_lbl = FastString -> FieldLabelString
FieldLabelString (FastString -> FieldLabelString) -> FastString -> FieldLabelString
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
GenLocated SrcSpanAnnN RdrName
lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys
| [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels
= if (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [])
else do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HsImplBang] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like []
(Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg)
| Bool
otherwise = do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
missing_s_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, Type)]
fs <- ZonkM [(FieldLabelString, Type)] -> TcM [(FieldLabelString, Type)]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [(FieldLabelString, Type)]
-> TcM [(FieldLabelString, Type)])
-> ZonkM [(FieldLabelString, Type)]
-> TcM [(FieldLabelString, Type)]
forall a b. (a -> b) -> a -> b
$ [(FieldLabelString, Type)] -> ZonkM [(FieldLabelString, Type)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> ZonkM (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_s_fields
TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [(FieldLabelString, Type)]
fs)
Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [(FieldLabelString, Type)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(FieldLabelString, Type)]
missing_ns_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
[(FieldLabelString, Type)]
fs <- ZonkM [(FieldLabelString, Type)] -> TcM [(FieldLabelString, Type)]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [(FieldLabelString, Type)]
-> TcM [(FieldLabelString, Type)])
-> ZonkM [(FieldLabelString, Type)]
-> TcM [(FieldLabelString, Type)]
forall a b. (a -> b) -> a -> b
$ [(FieldLabelString, Type)] -> ZonkM [(FieldLabelString, Type)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> ZonkM (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_ns_fields
let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like [(FieldLabelString, Type)]
fs
Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg
where
zonk_fields :: t (a, Type) -> ZonkM (t (a, Type))
zonk_fields t (a, Type)
fs = t (a, Type)
-> ((a, Type) -> ZonkM (a, Type)) -> ZonkM (t (a, Type))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (a, Type)
fs (((a, Type) -> ZonkM (a, Type)) -> ZonkM (t (a, Type)))
-> ((a, Type) -> ZonkM (a, Type)) -> ZonkM (t (a, Type))
forall a b. (a -> b) -> a -> b
$ \(a
str,Type
ty) -> do
Type
ty' <- Type -> ZonkM Type
zonkTcType Type
ty
(a, Type) -> ZonkM (a, Type)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
str,Type
ty')
missing_s_fields :: [(FieldLabelString, Type)]
missing_s_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
HsImplBang -> Bool
isBanged HsImplBang
str,
Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
[Name]
field_names_used)
]
missing_ns_fields :: [(FieldLabelString, Type)]
missing_ns_fields
= [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
[Name]
field_names_used)
]
field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecFields GhcRn (LocatedA (HsExpr GhcRn)) -> [XCFieldOcc GhcRn]
forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
HsRecFields GhcRn (LocatedA (HsExpr GhcRn))
rbinds
field_labels :: [FieldLabel]
field_labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
field_info :: [(FieldLabel, HsImplBang, Scaled Type)]
field_info = [FieldLabel]
-> [HsImplBang]
-> [Scaled Type]
-> [(FieldLabel, HsImplBang, Scaled Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled Type]
arg_tys
field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like
FieldLabel
fl elemField :: FieldLabel -> t Name -> Bool
`elemField` t Name
flds = (Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Name
fl' -> FieldLabel -> Name
flSelector FieldLabel
fl Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fl') t Name
flds
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 -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just NotClosedReason
reason -> TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> TcRnMessage
explain Name
name NotClosedReason
reason
where
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
n = TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> UniqSet Name
unitNameSet Name
n) Name
n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop :: TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env UniqSet Name
visited Name
n =
case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
n of
Just (ATcId { tct_id :: TcTyThing -> TyCoVar
tct_id = TyCoVar
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
IdBindingInfo
ClosedLet -> Maybe NotClosedReason
forall a. Maybe a
Nothing
IdBindingInfo
NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
NonClosedLet UniqSet Name
fvs Bool
type_closed -> [NotClosedReason] -> Maybe NotClosedReason
forall a. [a] -> Maybe a
listToMaybe ([NotClosedReason] -> Maybe NotClosedReason)
-> [NotClosedReason] -> Maybe NotClosedReason
forall a b. (a -> b) -> a -> b
$
[ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
| Name
n' <- UniqSet Name -> [Name]
nameSetElemsStable UniqSet Name
fvs
, Bool -> Bool
not (Name -> UniqSet Name -> Bool
elemNameSet Name
n' UniqSet Name
visited)
, Just NotClosedReason
reason <- [TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (UniqSet Name -> Name -> UniqSet Name
extendNameSet UniqSet Name
visited Name
n') Name
n']
] [NotClosedReason] -> [NotClosedReason] -> [NotClosedReason]
forall a. [a] -> [a] -> [a]
++
if Bool
type_closed then
[]
else
[ VarSet -> NotClosedReason
NotTypeClosed (VarSet -> NotClosedReason) -> VarSet -> NotClosedReason
forall a b. (a -> b) -> a -> b
$ Type -> VarSet
tyCoVarsOfType (TyCoVar -> Type
idType TyCoVar
tcid) ]
Maybe TcTyThing
_ -> Maybe NotClosedReason
forall a. Maybe a
Nothing
explain :: Name -> NotClosedReason -> TcRnMessage
explain :: Name -> NotClosedReason -> TcRnMessage
explain = Name -> NotClosedReason -> TcRnMessage
TcRnStaticFormNotClosed