{-# 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.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 (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr (GhcPass 'Renamed)
expr Type
res_ty = LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr LHsExpr (GhcPass 'Renamed)
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckPolyExprNC :: LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr (GhcPass 'Renamed)
expr Type
res_ty = LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr (GhcPass 'Renamed)
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr :: LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed)
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { expr' <- HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (L loc expr') }
tcPolyLExprNC :: LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 { expr' <- HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (L loc expr') }
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr :: HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr (GhcPass 'Renamed)
e (Infer InferResult
inf) = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
e (InferResult -> ExpRhoType
Infer InferResult
inf)
tcPolyExpr HsExpr (GhcPass 'Renamed)
e (Check Type
ty) = HsExpr (GhcPass 'Renamed)
-> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr (GhcPass 'Renamed)
e (Type -> Either Type TcCompleteSig
forall a b. a -> Either a b
Left Type
ty)
tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc)
tcPolyLExprSig :: LHsExpr (GhcPass 'Renamed) -> TcCompleteSig -> TcM (LHsExpr GhcTc)
tcPolyLExprSig (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
expr)
; expr' <- HsExpr (GhcPass 'Renamed)
-> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr (GhcPass 'Renamed)
expr (TcCompleteSig -> Either Type TcCompleteSig
forall a b. b -> Either a b
Right TcCompleteSig
sig)
; return (L loc expr') }
tcPolyExprCheck :: HsExpr GhcRn
-> Either TcSigmaType TcCompleteSig
-> TcM (HsExpr GhcTc)
tcPolyExprCheck :: HsExpr (GhcPass 'Renamed)
-> Either Type TcCompleteSig -> TcM (HsExpr GhcTc)
tcPolyExprCheck HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed) -> TcM (HsExpr GhcTc)
tc_body (HsPar XPar (GhcPass 'Renamed)
x (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 { e' <- HsExpr (GhcPass 'Renamed) -> TcM (HsExpr GhcTc)
tc_body HsExpr (GhcPass 'Renamed)
e
; return (HsPar x (L loc e')) }
tc_body (HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
splice_res HsUntypedSplice (GhcPass 'Renamed)
_)
= do { body <- HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Renamed))
getUntypedSpliceBody XUntypedSplice (GhcPass 'Renamed)
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
splice_res
; tc_body body }
tc_body e :: HsExpr (GhcPass 'Renamed)
e@(HsLam XLam (GhcPass 'Renamed)
x HsLamVariant
lam_variant MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches)
= do { (wrap, matches') <- HsExpr (GhcPass 'Renamed)
-> HsLamVariant
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr (GhcPass 'Renamed)
e HsLamVariant
lam_variant MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches [ExpPatType]
pat_tys
(Type -> ExpRhoType
mkCheckExpType Type
rho_ty)
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
tc_body HsExpr (GhcPass 'Renamed)
e = do { ds_flag <- TcM DeepSubsumptionFlag
getDeepSubsumptionFlag
; inner_skolemise ds_flag rho_ty $ \Type
rho_ty' ->
HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
e (Type -> ExpRhoType
mkCheckExpType Type
rho_ty') }
in HsExpr (GhcPass 'Renamed) -> TcM (HsExpr GhcTc)
tc_body HsExpr (GhcPass 'Renamed)
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 { (wrap, 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
; return (mkHsWrap wrap expr') }
outer_skolemise (Right TcCompleteSig
sig) [ExpPatType] -> Type -> TcM (HsExpr GhcTc)
thing_inside
= do { (wrap, 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
; return (mkHsWrap wrap 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 { (wrap, 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
; return (mkHsWrap wrap 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 (GhcPass 'Renamed) -> TcM (LHsExpr GhcTc, Type)
tcInferRho (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed)
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
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 { (expr', rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
expr)
; return (L loc expr', rho) }
tcInferRhoNC :: LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr GhcTc, Type)
tcInferRhoNC (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 { (expr', rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
expr)
; return (L loc expr', rho) }
tcCheckMonoExpr, tcCheckMonoExprNC
:: LHsExpr GhcRn
-> TcRhoType
-> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
expr Type
res_ty = LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr (GhcPass 'Renamed)
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckMonoExprNC :: LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr (GhcPass 'Renamed)
expr Type
res_ty = LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr (GhcPass 'Renamed)
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcMonoExpr, tcMonoExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcMonoExpr :: LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed)
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { expr' <- HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (L loc expr') }
tcMonoExprNC :: LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
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 { expr' <- HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (L loc expr') }
tcExpr :: HsExpr GhcRn
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcExpr :: HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsVar {}) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsApp {}) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(OpApp {}) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsAppType {}) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(ExprWithTySig {}) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcExpr (XExpr XXExpr (GhcPass 'Renamed)
e) ExpRhoType
res_ty = XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr XXExpr (GhcPass 'Renamed)
XXExprGhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit) ExpRhoType
res_ty
= do { mb_res <- HsOverLit (GhcPass 'Renamed)
-> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit HsOverLit (GhcPass 'Renamed)
lit ExpRhoType
res_ty
; case 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 (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty }
tcExpr (HsUnboundVar XUnboundVar (GhcPass 'Renamed)
_ RdrName
occ) ExpRhoType
res_ty
= do { ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; her <- emitNewExprHole occ ty
; tcEmitBindingUsage bottomUE
; return (HsUnboundVar her occ) }
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsLit XLitE (GhcPass 'Renamed)
x HsLit (GhcPass 'Renamed)
lit) ExpRhoType
res_ty
= do { let lit_ty :: Type
lit_ty = HsLit (GhcPass 'Renamed) -> Type
forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> Type
hsLitType HsLit (GhcPass 'Renamed)
lit
; HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr (GhcPass 'Renamed)
e (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Renamed)
XLitE GhcTc
x (HsLit (GhcPass 'Renamed) -> HsLit GhcTc
forall (p :: Pass) (p' :: Pass).
(XXLit (GhcPass p) ~ DataConCantHappen) =>
HsLit (GhcPass p) -> HsLit (GhcPass p')
convertLit HsLit (GhcPass 'Renamed)
lit)) Type
lit_ty ExpRhoType
res_ty }
tcExpr (HsPar XPar (GhcPass 'Renamed)
x LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { expr' <- LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (HsPar x expr') }
tcExpr (HsPragE XPragE (GhcPass 'Renamed)
x HsPragE (GhcPass 'Renamed)
prag LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { expr' <- LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (HsPragE x (tcExprPrag prag) expr') }
tcExpr (NegApp XNegApp (GhcPass 'Renamed)
x LHsExpr (GhcPass 'Renamed)
expr SyntaxExpr (GhcPass 'Renamed)
neg_expr) ExpRhoType
res_ty
= do { (expr', neg_expr')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr (GhcPass 'Renamed)
SyntaxExprRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty (([Type] -> [Type] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc))
-> ([Type] -> [Type] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr 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 (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
expr Type
arg_ty
; return (NegApp x expr' neg_expr') }
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsIPVar XIPVar (GhcPass 'Renamed)
_ HsIPName
x) ExpRhoType
res_ty
= do { ip_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; let ip_name = FastString -> Type
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
; tcWrapResult e
(fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
ip_ty 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 (GhcPass 'Renamed)
e@(HsLam XLam (GhcPass 'Renamed)
x HsLamVariant
lam_variant MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches) ExpRhoType
res_ty
= do { (wrap, matches') <- HsExpr (GhcPass 'Renamed)
-> HsLamVariant
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> [ExpPatType]
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcLambdaMatches HsExpr (GhcPass 'Renamed)
e HsLamVariant
lam_variant MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches [] ExpRhoType
res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
tcExpr (ExplicitList XExplicitList (GhcPass 'Renamed)
_ [LHsExpr (GhcPass 'Renamed)]
exprs) ExpRhoType
res_ty
= do { res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; let tc_elt LocatedA (HsExpr (GhcPass 'Renamed))
expr = LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
expr Type
elt_ty
; exprs' <- mapM tc_elt exprs
; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
tcExpr expr :: HsExpr (GhcPass 'Renamed)
expr@(ExplicitTuple XExplicitTuple (GhcPass 'Renamed)
x [HsTupArg (GhcPass 'Renamed)]
tup_args Boxity
boxity) ExpRhoType
res_ty
| (HsTupArg (GhcPass 'Renamed) -> Bool)
-> [HsTupArg (GhcPass 'Renamed)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsTupArg (GhcPass 'Renamed) -> Bool
forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg (GhcPass 'Renamed)]
tup_args
= do { let arity :: Int
arity = [HsTupArg (GhcPass 'Renamed)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg (GhcPass 'Renamed)]
tup_args
tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
; res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
; let 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
; tup_args1 <- tcCheckExplicitTuple tup_args arg_tys'
; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
| Bool
otherwise
=
do { (tup_args1, arg_tys) <- Boxity
-> [HsTupArg (GhcPass 'Renamed)] -> TcM ([HsTupArg GhcTc], [Type])
tcInferTupArgs Boxity
boxity [HsTupArg (GhcPass 'Renamed)]
tup_args
; let expr' = XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple (GhcPass 'Renamed)
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity
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 = [Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
missing_tys (Boxity -> [Type] -> Type
mkTupleTy1 Boxity
boxity [Type]
arg_tys)
; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
; tcWrapResultMono expr expr' act_res_ty res_ty }
tcExpr (ExplicitSum XExplicitSum (GhcPass 'Renamed)
_ Int
alt Int
arity LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
; res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
;
let arg_tys' = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
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)
; expr' <- tcCheckPolyExpr expr arg_ty
; hasFixedRuntimeRep_syntactic (FRRUnboxedSum Nothing) res_ty
; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
tcExpr (HsLet XLet (GhcPass 'Renamed)
x HsLocalBinds (GhcPass 'Renamed)
binds LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { (binds', expr') <- HsLocalBinds (GhcPass 'Renamed)
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall thing.
HsLocalBinds (GhcPass 'Renamed)
-> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds (GhcPass 'Renamed)
binds (TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr (GhcPass 'Renamed)
expr ExpRhoType
res_ty
; return (HsLet x binds' expr') }
tcExpr (HsCase XCase (GhcPass 'Renamed)
ctxt LHsExpr (GhcPass 'Renamed)
scrut MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches) ExpRhoType
res_ty
= do {
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
; matches' <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty
; return (HsCase ctxt scrut' matches') }
tcExpr (HsIf XIf (GhcPass 'Renamed)
x LHsExpr (GhcPass 'Renamed)
pred LHsExpr (GhcPass 'Renamed)
b1 LHsExpr (GhcPass 'Renamed)
b2) ExpRhoType
res_ty
= do { pred' <- LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
pred Type
boolTy
; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
; tcEmitBindingUsage (supUE u1 u2)
; return (HsIf x pred' b1' b2') }
tcExpr (HsMultiIf XMultiIf (GhcPass 'Renamed)
_ [LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
alts) ExpRhoType
res_ty
= do { alts' <- HsMatchContextRn
-> TcMatchAltChecker HsExpr
-> [LGRHS
(GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> TcMatchAltChecker body
-> [LGRHS (GhcPass 'Renamed) (LocatedA (body (GhcPass 'Renamed)))]
-> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
IfAlt LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
TcMatchAltChecker HsExpr
tcBody [LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
[LGRHS (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))]
alts ExpRhoType
res_ty
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
tcExpr (HsDo XDo (GhcPass 'Renamed)
_ HsDoFlavour
do_or_lc XRec (GhcPass 'Renamed) [ExprLStmt (GhcPass 'Renamed)]
stmts) ExpRhoType
res_ty
= HsDoFlavour
-> LocatedLW [ExprLStmt (GhcPass 'Renamed)]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
do_or_lc XRec (GhcPass 'Renamed) [ExprLStmt (GhcPass 'Renamed)]
LocatedLW [ExprLStmt (GhcPass 'Renamed)]
stmts ExpRhoType
res_ty
tcExpr (HsProc XProc (GhcPass 'Renamed)
x LPat (GhcPass 'Renamed)
pat LHsCmdTop (GhcPass 'Renamed)
cmd) ExpRhoType
res_ty
= do { (pat', cmd', coi) <- LPat (GhcPass 'Renamed)
-> LHsCmdTop (GhcPass 'Renamed)
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat (GhcPass 'Renamed)
pat LHsCmdTop (GhcPass 'Renamed)
cmd ExpRhoType
res_ty
; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
tcExpr (HsStatic XStatic (GhcPass 'Renamed)
fvs LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
; (expr', lie) <- captureConstraints $
addErrCtxt (hang (text "In the body of a static form:")
2 (ppr expr)
) $
tcCheckPolyExprNC expr expr_ty
; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
; typeableClass <- tcLookupClass typeableClassName
; typeable_ev <- emitWantedEvVar StaticOrigin $
mkTyConApp (classTyCon typeableClass)
[liftedTypeKind, expr_ty]
; emitStaticConstraints lie
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
[p_ty]
; let wrap = [TyCoVar] -> HsWrapper
mkWpEvVarApps [TyCoVar
typeable_ev] HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type
expr_ty]
; loc <- getSrcSpanM
; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName
; return $ mkHsWrapCo co $ HsApp noExtField
(L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
(L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))
}
tcExpr (HsEmbTy XEmbTy (GhcPass 'Renamed)
_ LHsWcType (NoGhcTc (GhcPass 'Renamed))
_) ExpRhoType
_ = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWith (TypeSyntax -> TcRnMessage
TcRnIllegalTypeExpr TypeSyntax
TypeKeywordSyntax)
tcExpr (HsQual XQual (GhcPass 'Renamed)
_ XRec (GhcPass 'Renamed) [LHsExpr (GhcPass 'Renamed)]
_ LHsExpr (GhcPass 'Renamed)
_) ExpRhoType
_ = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWith (TypeSyntax -> TcRnMessage
TcRnIllegalTypeExpr TypeSyntax
ContextArrowSyntax)
tcExpr (HsForAll XForAll (GhcPass 'Renamed)
_ HsForAllTelescope (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_) ExpRhoType
_ = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWith (TypeSyntax -> TcRnMessage
TcRnIllegalTypeExpr TypeSyntax
ForallTelescopeSyntax)
tcExpr (HsFunArr XFunArr (GhcPass 'Renamed)
_ HsArrowOf (LHsExpr (GhcPass 'Renamed)) (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_) ExpRhoType
_ = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWith (TypeSyntax -> TcRnMessage
TcRnIllegalTypeExpr TypeSyntax
FunctionArrowSyntax)
tcExpr expr :: HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed)
rbinds }) ExpRhoType
res_ty
= do { con_like <- Name -> TcM ConLike
tcLookupConLike Name
con_name
; (con_expr, con_sigma) <- tcInferConLike con_like
; (con_wrap, con_tau) <- topInstantiate orig con_sigma
; let arity = ConLike -> Int
conLikeArity ConLike
con_like
Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
; checkTc (conLikeHasBuilder con_like) $
nonBidirectionalErr (conLikeName con_like)
; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
; let rcon_tc = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr
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' }
; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
; checkMissingFields con_like rbinds arg_tys
; return ret }
where
orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
con_name
tcExpr expr :: HsExpr (GhcPass 'Renamed)
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr (GhcPass 'Renamed)
record_expr
, rupd_flds :: forall p. HsExpr p -> LHsRecUpdFields p
rupd_flds =
RegularRecUpdFields
{ xRecUpdFields :: forall p. LHsRecUpdFields p -> XLHsRecUpdLabels p
xRecUpdFields = XLHsRecUpdLabels (GhcPass 'Renamed)
possible_parents
, recUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdField p p]
recUpdFields = [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbnds }
})
ExpRhoType
res_ty
= Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rbnds) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do {
; (ds_expr, ds_res_ty, err_ctxt)
<- LHsExpr (GhcPass 'Renamed)
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> ExpRhoType
-> TcM (HsExpr (GhcPass 'Renamed), Type, SDoc)
expandRecordUpd LHsExpr (GhcPass 'Renamed)
record_expr NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
XLHsRecUpdLabels (GhcPass 'Renamed)
possible_parents [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbnds ExpRhoType
res_ty
; expr' <- addErrCtxt err_ctxt $
tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty
}
tcExpr e :: HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e
tcExpr (ArithSeq XArithSeq (GhcPass 'Renamed)
_ Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ArithSeqInfo (GhcPass 'Renamed)
seq) ExpRhoType
res_ty
= Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ArithSeqInfo (GhcPass 'Renamed)
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ArithSeqInfo (GhcPass 'Renamed)
seq ExpRhoType
res_ty
tcExpr (HsGetField XGetField (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_ XRec (GhcPass 'Renamed) (DotFieldOcc (GhcPass 'Renamed))
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection (GhcPass 'Renamed)
_ NonEmpty (DotFieldOcc (GhcPass 'Renamed))
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
tcExpr (HsTypedSplice XTypedSplice (GhcPass 'Renamed)
ext LHsExpr (GhcPass 'Renamed)
splice) ExpRhoType
res_ty = Name
-> LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedSplice XTypedSplice (GhcPass 'Renamed)
Name
ext LHsExpr (GhcPass 'Renamed)
splice ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsTypedBracket XTypedBracket (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
body) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr (GhcPass 'Renamed)
e LHsExpr (GhcPass 'Renamed)
body ExpRhoType
res_ty
tcExpr e :: HsExpr (GhcPass 'Renamed)
e@(HsUntypedBracket XUntypedBracket (GhcPass 'Renamed)
ps HsQuote (GhcPass 'Renamed)
body) ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed)
-> HsQuote (GhcPass 'Renamed)
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr (GhcPass 'Renamed)
e HsQuote (GhcPass 'Renamed)
body [PendingRnSplice]
XUntypedBracket (GhcPass 'Renamed)
ps ExpRhoType
res_ty
tcExpr (HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
splice HsUntypedSplice (GhcPass 'Renamed)
_) ExpRhoType
res_ty
= do { expr <- HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Renamed))
getUntypedSpliceBody XUntypedSplice (GhcPass 'Renamed)
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
splice
; tcExpr expr 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 (GhcPass 'Renamed)
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 (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
tcXExpr xe :: XXExprGhcRn
xe@(ExpandedThingRn HsThingRn
o HsExpr (GhcPass 'Renamed)
e') ExpRhoType
res_ty
| OrigStmt ls :: ExprLStmt (GhcPass 'Renamed)
ls@(L SrcSpanAnnA
loc s :: StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
s@LetStmt{}) <- HsThingRn
o
, HsLet XLet (GhcPass 'Renamed)
x HsLocalBinds (GhcPass 'Renamed)
binds LHsExpr (GhcPass 'Renamed)
e <- HsExpr (GhcPass 'Renamed)
e'
= do { (binds', e') <- SrcSpanAnnA
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
ExprStmt (GhcPass 'Renamed)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
s (TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
-> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsLocalBinds (GhcPass 'Renamed)
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall thing.
HsLocalBinds (GhcPass 'Renamed)
-> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds (GhcPass 'Renamed)
binds (TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr (GhcPass 'Renamed)
e ExpRhoType
res_ty
; return $ mkExpandedStmtTc ls (HsLet x binds' e')
}
| OrigStmt ls :: ExprLStmt (GhcPass 'Renamed)
ls@(L SrcSpanAnnA
loc s :: StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
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 (GhcPass 'Renamed)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
s (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
ExprLStmt (GhcPass 'Renamed) -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedStmtTc ExprLStmt (GhcPass 'Renamed)
ls (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
e' ExpRhoType
res_ty
| OrigStmt ls :: ExprLStmt (GhcPass 'Renamed)
ls@(L SrcSpanAnnA
loc StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
_) <- 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 (GhcPass 'Renamed) -> HsExpr GhcTc -> HsExpr GhcTc
mkExpandedStmtTc ExprLStmt (GhcPass 'Renamed)
ls (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp (XXExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XXExpr p -> HsExpr p
XExpr XXExpr (GhcPass 'Renamed)
XXExprGhcRn
xe) ExpRhoType
res_ty
tcXExpr XXExprGhcRn
xe ExpRhoType
res_ty = HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp (XXExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XXExpr p -> HsExpr p
XExpr XXExpr (GhcPass 'Renamed)
XXExprGhcRn
xe) ExpRhoType
res_ty
tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq :: Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ArithSeqInfo (GhcPass 'Renamed)
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr (GhcPass 'Renamed))
witness seq :: ArithSeqInfo (GhcPass 'Renamed)
seq@(From LHsExpr (GhcPass 'Renamed)
expr) ExpRhoType
res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ExpRhoType
res_ty
; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from wit' (From expr') }
tcArithSeq Maybe (SyntaxExpr (GhcPass 'Renamed))
witness seq :: ArithSeqInfo (GhcPass 'Renamed)
seq@(FromThen LHsExpr (GhcPass 'Renamed)
expr1 LHsExpr (GhcPass 'Renamed)
expr2) ExpRhoType
res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ExpRhoType
res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
tcArithSeq Maybe (SyntaxExpr (GhcPass 'Renamed))
witness seq :: ArithSeqInfo (GhcPass 'Renamed)
seq@(FromTo LHsExpr (GhcPass 'Renamed)
expr1 LHsExpr (GhcPass 'Renamed)
expr2) ExpRhoType
res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ExpRhoType
res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
tcArithSeq Maybe (SyntaxExpr (GhcPass 'Renamed))
witness seq :: ArithSeqInfo (GhcPass 'Renamed)
seq@(FromThenTo LHsExpr (GhcPass 'Renamed)
expr1 LHsExpr (GhcPass 'Renamed)
expr2 LHsExpr (GhcPass 'Renamed)
expr3) ExpRhoType
res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr (GhcPass 'Renamed))
witness ExpRhoType
res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr (GhcPass 'Renamed))
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr (GhcPass 'Renamed))
Nothing ExpRhoType
res_ty
= do { res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; return (mkWpCastN coi, OneTy, elt_ty, Nothing) }
arithSeqEltType (Just SyntaxExpr (GhcPass 'Renamed)
fl) ExpRhoType
res_ty
= do { ((elt_mult, elt_ty), 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 (GhcPass 'Renamed)
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)
; return (idHsWrapper, elt_mult, elt_ty, Just fl') }
tcCheckExplicitTuple :: [HsTupArg GhcRn]
-> [TcSigmaType]
-> TcM [HsTupArg GhcTc]
tcCheckExplicitTuple :: [HsTupArg (GhcPass 'Renamed)] -> [Type] -> TcM [HsTupArg GhcTc]
tcCheckExplicitTuple [HsTupArg (GhcPass 'Renamed)]
args [Type]
tys
= do Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([HsTupArg (GhcPass 'Renamed)] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [HsTupArg (GhcPass 'Renamed)]
args [Type]
tys)
Int -> TcRn ()
checkTupSize ([HsTupArg (GhcPass 'Renamed)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg (GhcPass 'Renamed)]
args)
(Int
-> HsTupArg (GhcPass 'Renamed)
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc))
-> [Int]
-> [HsTupArg (GhcPass 'Renamed)]
-> [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 (GhcPass 'Renamed)
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go [Int
1,Int
2..] [HsTupArg (GhcPass 'Renamed)]
args [Type]
tys
where
go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
go :: Int
-> HsTupArg (GhcPass 'Renamed)
-> 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 (GhcPass 'Renamed)
x LHsExpr (GhcPass 'Renamed)
expr) Type
arg_ty
= do { expr' <- LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr (GhcPass 'Renamed)
expr Type
arg_ty
; (co, _) <- hasFixedRuntimeRep (FRRUnboxedTuple i) arg_ty
; return (Present x (mkLHsWrap (mkWpCastN co) expr')) }
tcInferTupArgs :: Boxity
-> [HsTupArg GhcRn]
-> TcM ([HsTupArg GhcTc], [TcSigmaTypeFRR])
tcInferTupArgs :: Boxity
-> [HsTupArg (GhcPass 'Renamed)] -> TcM ([HsTupArg GhcTc], [Type])
tcInferTupArgs Boxity
boxity [HsTupArg (GhcPass 'Renamed)]
args
= do { Int -> TcRn ()
checkTupSize ([HsTupArg (GhcPass 'Renamed)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg (GhcPass 'Renamed)]
args)
; (Int
-> HsTupArg (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type))
-> [Int]
-> [HsTupArg (GhcPass 'Renamed)]
-> 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 (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
tc_infer_tup_arg [Int
1,Int
2..] [HsTupArg (GhcPass 'Renamed)]
args }
where
tc_infer_tup_arg :: Int -> HsTupArg GhcRn -> TcM (HsTupArg GhcTc, TcSigmaTypeFRR)
tc_infer_tup_arg :: Int
-> HsTupArg (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc, Type)
tc_infer_tup_arg Int
i (Missing {})
= do { mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
; arg_ty <- new_arg_ty i
; return (Missing (Scaled mult arg_ty), arg_ty) }
tc_infer_tup_arg Int
i (Present XPresent (GhcPass 'Renamed)
x lexpr :: LHsExpr (GhcPass 'Renamed)
lexpr@(L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
expr))
= do { (expr', 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 (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr (GhcPass 'Renamed)
expr)
Boxity
Boxed -> do { arg_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; L _ expr' <- tcCheckPolyExpr lexpr arg_ty
; return (expr', arg_ty) }
; return (Present x (L l expr'), 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 (GhcPass 'Renamed)
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (expr, sigma) <- (HsExpr (GhcPass 'Renamed), AppCtxt) -> TcM (HsExpr GhcTc, Type)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
op, HsExpr (GhcPass 'Renamed) -> Int -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op Int
0 SrcSpan
noSrcSpan)
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
; (result, expr_wrap, arg_wraps, res_wrap)
<- tcSynArgA orig op sigma arg_tys res_ty $
thing_inside
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [Type] -> [Type] -> TcM a
_ = String -> IOEnv (Env TcGblEnv TcLclEnv) (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 (GhcPass 'Renamed)
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr (GhcPass 'Renamed)
op Type
sigma_ty SyntaxOpType
syn_ty [Type] -> [Type] -> TcM a
thing_inside
= do { (skol_wrap, (result, 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
; return (result, skol_wrap <.> ty_wrapper) }
where
go :: Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
SynAny
= do { result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; return (result, idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynRho
= do { result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
; return (result, idHsWrapper) }
go Type
rho_ty SyntaxOpType
SynList
= do { (list_co, elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
; result <- thing_inside [elt_ty] []
; return (result, mkWpCastN list_co) }
go Type
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
= do { ( match_wrapper
, ( ( (result, arg_ty, res_ty, op_mult)
, res_wrapper )
, arg_wrapper1, [], 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 { arg_tc_ty <- ExpRhoType -> TcM Type
expTypeToType (Scaled ExpRhoType -> ExpRhoType
forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
; res_tc_ty <- expTypeToType res_ty
; massertPpr (case arg_shape of
SynFun {} -> Bool
False;
SyntaxOpType
_ -> Bool
True)
(text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig)
; let arg_mult = Scaled ExpRhoType -> Type
forall a. Scaled a -> Type
scaledMult Scaled ExpRhoType
arg_ty
; tcSynArgA orig op arg_tc_ty [] arg_shape $
\ [Type]
arg_results [Type]
arg_res_mults ->
CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper)
forall a.
CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr (GhcPass 'Renamed)
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 { 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)
; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}
; let 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
; return (result, match_wrapper <.> fun_wrap) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr (GhcPass 'Renamed) -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
CtOrigin -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr (GhcPass 'Renamed)
op
go Type
rho_ty (SynType ExpRhoType
the_ty)
= do { wrap <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> Type -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty Type
rho_ty
; result <- thing_inside [] []
; return (result, wrap) }
tcSynArgA :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA :: forall a.
CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr (GhcPass 'Renamed)
op Type
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [Type] -> [Type] -> TcM a
thing_inside
= do { (match_wrapper, arg_tys, 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
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ [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)
; return (result, match_wrapper, arg_wrappers, res_wrapper) }
where
herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr (GhcPass 'Renamed) -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
CtOrigin -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr (GhcPass 'Renamed)
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 { ((result, arg_wraps), arg_wrap)
<- CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr (GhcPass 'Renamed)
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)
; return (result, arg_wrap : 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 { result <- [Type] -> TcM a
thing_inside [Type
res_ty]
; return (result, idHsWrapper) }
tc_syn_arg Type
res_ty SyntaxOpType
SynRho [Type] -> TcM a
thing_inside
= do { (inst_wrap, rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; result <- thing_inside [rho_ty]
; return (result, inst_wrap) }
tc_syn_arg Type
res_ty SyntaxOpType
SynList [Type] -> TcM a
thing_inside
= do { (inst_wrap, rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
; (list_co, elt_ty) <- matchExpectedListTy rho_ty
; result <- thing_inside [elt_ty]
; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) }
tc_syn_arg Type
_ (SynFun {}) [Type] -> TcM a
_
= String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (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 { wrap <- CtOrigin -> UserTypeCtxt -> Type -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt Type
res_ty ExpRhoType
the_ty
; result <- thing_inside []
; return (result, wrap) }
expandRecordUpd :: LHsExpr GhcRn
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> [LHsRecUpdField GhcRn GhcRn]
-> ExpRhoType
-> TcM ( HsExpr GhcRn
, TcType
, SDoc
)
expandRecordUpd :: LHsExpr (GhcPass 'Renamed)
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> ExpRhoType
-> TcM (HsExpr (GhcPass 'Renamed), Type, SDoc)
expandRecordUpd LHsExpr (GhcPass 'Renamed)
record_expr NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbnds ExpRhoType
res_ty
= do {
; ((_, record_rho), _lie) <- TcM (LHsExpr GhcTc, Type)
-> TcM ((LHsExpr GhcTc, Type), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM (LHsExpr GhcTc, Type)
-> TcM ((LHsExpr GhcTc, Type), WantedConstraints))
-> TcM (LHsExpr GhcTc, Type)
-> TcM ((LHsExpr 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 (GhcPass 'Renamed) -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr (GhcPass 'Renamed)
record_expr
; (cons, rbinds)
<- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
; let sel_ids = (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> TyCoVar)
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> [TyCoVar]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN TyCoVar -> TyCoVar
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN TyCoVar -> TyCoVar)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnN TyCoVar)
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> TyCoVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcTc -> LIdP GhcTc
FieldOcc GhcTc -> GenLocated SrcSpanAnnN TyCoVar
forall pass. FieldOcc pass -> LIdP pass
foLabel (FieldOcc GhcTc -> GenLocated SrcSpanAnnN TyCoVar)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> FieldOcc GhcTc)
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnN TyCoVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FieldOcc GhcTc) -> FieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (FieldOcc GhcTc) -> FieldOcc GhcTc)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnA (FieldOcc GhcTc))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> FieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (FieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (FieldOcc GhcTc))
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnA (FieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed)))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rbinds
upd_fld_names = (TyCoVar -> Name) -> [TyCoVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Name
idName [TyCoVar]
sel_ids
relevant_cons = UniqSet ConLike -> [ConLike]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ConLike
cons
relevant_con = [ConLike] -> ConLike
forall a. HasCallStack => [a] -> a
head [ConLike]
relevant_cons
; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con
; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs)
; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs
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
_ -> HasDebugCallStack => 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 Name
fld_nm (L SrcSpanAnnA
_ HsFieldBind fld (LocatedA (HsExpr (GhcPass 'Renamed)))
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 = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
arg_ty
rhs :: LocatedA (HsExpr (GhcPass 'Renamed))
rhs = HsFieldBind fld (LocatedA (HsExpr (GhcPass 'Renamed)))
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind fld (LocatedA (HsExpr (GhcPass 'Renamed)))
rbind
; (_co, actual_arg_ty) <- HasDebugCallStack =>
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
hasFixedRuntimeRep (Name -> HsExpr (GhcPass 'Renamed) -> FixedRuntimeRepContext
FRRRecordUpdate Name
fld_nm (LocatedA (HsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr (GhcPass 'Renamed))
rhs)) Type
actual_arg_ty
; nm <- newNameAt nm_occ generatedSrcSpan
; let id = HasDebugCallStack => Name -> Type -> Type -> TyCoVar
Name -> Type -> Type -> TyCoVar
mkLocalId Name
nm Type
ManyTy Type
actual_arg_ty
; return (fld_nm, (id, rhs))
}
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
; traceTc "tcRecordUpd" $
vcat [ text "upd_fld_names:" <+> ppr upd_fld_names
, text "relevant_cons:" <+> ppr relevant_cons ]
; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds
; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)
updEnv = [(Name, (TyCoVar, LHsExpr (GhcPass 'Renamed)))]
-> UniqMap Name (TyCoVar, LHsExpr (GhcPass 'Renamed))
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(Name, (TyCoVar, LHsExpr (GhcPass 'Renamed)))]
-> UniqMap Name (TyCoVar, LHsExpr (GhcPass 'Renamed)))
-> [(Name, (TyCoVar, LHsExpr (GhcPass 'Renamed)))]
-> UniqMap Name (TyCoVar, LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ [(Name, (TyCoVar, LHsExpr (GhcPass 'Renamed)))]
[(Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))]
upd_ids
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat ConLike
conLike = HsMatchContext (LIdP (NoGhcTc (GhcPass 'Renamed)))
-> LocatedE [LPat (GhcPass 'Renamed)]
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
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)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (LIdP (NoGhcTc (GhcPass 'Renamed)))
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
RecUpd ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
-> GenLocated
EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
pat]) LocatedA (HsExpr (GhcPass 'Renamed))
rhs
where
([GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
lhs_con_pats, [LocatedA (HsExpr (GhcPass 'Renamed))]
rhs_con_args)
= (Int
-> FieldLabel
-> (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)),
LocatedA (HsExpr (GhcPass 'Renamed))))
-> [Int]
-> [FieldLabel]
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))],
[LocatedA (HsExpr (GhcPass 'Renamed))])
forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip Int
-> FieldLabel
-> (LPat (GhcPass 'Renamed), LHsExpr (GhcPass 'Renamed))
Int
-> FieldLabel
-> (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)),
LocatedA (HsExpr (GhcPass 'Renamed)))
mk_con_arg [Int
1..] [FieldLabel]
con_fields
pat :: LPat (GhcPass 'Renamed)
pat = Name -> [LPat (GhcPass 'Renamed)] -> LPat (GhcPass 'Renamed)
genSimpleConPat Name
con [LPat (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
lhs_con_pats
rhs :: LocatedA (HsExpr (GhcPass 'Renamed))
rhs = HsExpr (GhcPass 'Renamed) -> LocatedA (HsExpr (GhcPass 'Renamed))
forall e a. HasAnnotation e => a -> GenLocated e a
wrapGenSpan (HsExpr (GhcPass 'Renamed) -> LocatedA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ Name -> [LHsExpr (GhcPass 'Renamed)] -> HsExpr (GhcPass 'Renamed)
genHsApps Name
con [LHsExpr (GhcPass 'Renamed)]
[LocatedA (HsExpr (GhcPass 'Renamed))]
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
i FieldLabel
fld_lbl =
case UniqMap Name (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed)))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed)))
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name (TyCoVar, LHsExpr (GhcPass 'Renamed))
UniqMap Name (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed)))
updEnv (Name -> Maybe (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
flSelector FieldLabel
fld_lbl of
Just (TyCoVar
upd_id, LocatedA (HsExpr (GhcPass 'Renamed))
_) -> (LPat (GhcPass 'Renamed)
genWildPat, Name -> LHsExpr (GhcPass 'Renamed)
genLHsVar (TyCoVar -> Name
idName TyCoVar
upd_id))
Maybe (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed)))
_ -> 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 (GhcPass 'Renamed)
genVarPat Name
fld_nm, Name -> LHsExpr (GhcPass 'Renamed)
genLHsVar Name
fld_nm)
; let ds_expr :: HsExpr GhcRn
ds_expr = XLet (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet (GhcPass 'Renamed)
NoExtField
noExtField HsLocalBinds (GhcPass 'Renamed)
let_binds (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
gen HsExpr (GhcPass 'Renamed)
case_expr)
case_expr :: HsExpr GhcRn
case_expr = XCase (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase (GhcPass 'Renamed)
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
RecUpd LHsExpr (GhcPass 'Renamed)
record_expr
(MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed))
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedLW
[LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
-> MatchGroup
(GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedLW
[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 (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
-> LocatedLW
[LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
forall e a. HasAnnotation e => a -> GenLocated e a
wrapGenSpan [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
[LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = (ConLike
-> LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
-> [ConLike]
-> [LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
ConLike
-> LocatedA
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))
make_pat [ConLike]
relevant_cons
let_binds :: HsLocalBindsLR GhcRn GhcRn
let_binds = XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
EpAnn (AnnList (EpToken "where"))
forall a. NoAnn a => a
noAnn (HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed))
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ XXValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
(XXValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> XXValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR (GhcPass 'Renamed)
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
upd_ids_lhs (((Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)))
-> [(Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))]
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (TyCoVar, LHsExpr (GhcPass 'Renamed)))
-> LSig (GhcPass 'Renamed)
(Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
mk_idSig [(Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))]
upd_ids)
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs = [ (RecFlag
NonRecursive, [Name
-> [LPat (GhcPass 'Renamed)]
-> LHsExpr (GhcPass 'Renamed)
-> LHsBind (GhcPass 'Renamed)
genSimpleFunBind (TyCoVar -> Name
idName TyCoVar
id) [] LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
rhs])
| (Name
_, (TyCoVar
id, LocatedA (HsExpr (GhcPass 'Renamed))
rhs)) <- [(Name, (TyCoVar, LocatedA (HsExpr (GhcPass 'Renamed))))]
upd_ids ]
mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig (Name
_, (TyCoVar
id, LHsExpr (GhcPass 'Renamed)
_)) = SrcSpanAnnA
-> Sig (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
gen (Sig (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)))
-> Sig (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XXSig (GhcPass 'Renamed) -> Sig (GhcPass 'Renamed)
forall pass. XXSig pass -> Sig pass
XSig (XXSig (GhcPass 'Renamed) -> Sig (GhcPass 'Renamed))
-> XXSig (GhcPass 'Renamed) -> Sig (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ TyCoVar -> IdSig
IdSig TyCoVar
id
gen = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
generatedSrcSpan
; traceTc "expandRecordUpd" $
vcat [ text "relevant_con:" <+> ppr relevant_con
, text "res_ty:" <+> ppr res_ty
, text "ds_res_ty:" <+> ppr ds_res_ty
]
; let cons = [ConLike] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [ConLike]
relevant_cons
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]
forall a. a -> [a] -> [a]
:)
([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] -> SDoc
make_lines_msg [SDoc]
err_lines
; return (ds_expr, ds_res_ty, 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 (GhcPass 'Renamed)
-> Type
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> ExpRhoType
-> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc (GhcPass 'Renamed)])
disambiguateRecordBinds LHsExpr (GhcPass 'Renamed)
record_expr Type
record_rho NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbnds ExpRhoType
res_ty
= do { fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; TcRecUpdParent
{ tcRecUpdLabels = lbls
, tcRecUpdCons = cons }
<- identifyParentLabels fam_inst_envs possible_parents
; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds
; return (cons, rbnds') }
where
identifyParentLabels :: FamInstEnvs
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> TcM (HsRecUpdParent GhcTc)
identifyParentLabels :: FamInstEnvs
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> TcM (HsRecUpdParent GhcTc)
identifyParentLabels FamInstEnvs
fam_inst_envs NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents
= case NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents of
HsRecUpdParent (GhcPass 'Renamed)
p NE.:| [] -> HsRecUpdParent (GhcPass 'Renamed) -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds HsRecUpdParent (GhcPass 'Renamed)
p
HsRecUpdParent (GhcPass 'Renamed)
_ NE.:| HsRecUpdParent (GhcPass 'Renamed)
_ : [HsRecUpdParent (GhcPass 'Renamed)]
_
| Just TyCon
tc <- FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
res_ty
-> do { NonEmpty (HsRecUpdParent (GhcPass 'Renamed)) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents TyCon
tc
; TyCon
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents }
| Just {} <- HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (LocatedA (HsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
record_expr)
, Just TyCon
tc <- FamInstEnvs -> Type -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs Type
record_rho
-> do { NonEmpty (HsRecUpdParent (GhcPass 'Renamed)) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents TyCon
tc
; TyCon
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents }
HsRecUpdParent (GhcPass 'Renamed)
p1 NE.:| HsRecUpdParent (GhcPass 'Renamed)
p2 : [HsRecUpdParent (GhcPass 'Renamed)]
ps
-> do { p1 <- HsRecUpdParent (GhcPass 'Renamed) -> TcM RecSelParent
tcLookupRecSelParent HsRecUpdParent (GhcPass 'Renamed)
p1
; p2 <- tcLookupRecSelParent p2
; ps <- mapM tcLookupRecSelParent ps
; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds)
$ MultiplePossibleParents (p1, p2, ps) }
try_disambiguated_tycon :: TyCon
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon :: TyCon
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> TcM (HsRecUpdParent GhcTc)
try_disambiguated_tycon TyCon
tc NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
pars
= do { pars <- (HsRecUpdParent (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc)))
-> [HsRecUpdParent (GhcPass 'Renamed)]
-> 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 (GhcPass 'Renamed)
-> TcM (HsRecUpdParent GhcTc))
-> HsRecUpdParent (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (HsRecUpdParent GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecUpdParent (GhcPass 'Renamed) -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds) (NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> [HsRecUpdParent (GhcPass 'Renamed)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
pars)
; case 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 { pars <- (HsRecUpdParent (GhcPass 'Renamed) -> TcM RecSelParent)
-> NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
-> 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 (GhcPass 'Renamed) -> TcM RecSelParent
tcLookupRecSelParent NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
possible_parents
; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds)
$ InvalidTyConParent tc 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 (GhcPass 'Renamed) -> TcM (HsRecUpdParent GhcTc)
lookup_parent_flds par :: HsRecUpdParent (GhcPass 'Renamed)
par@(RnRecUpdParent { rnRecUpdLabels :: HsRecUpdParent (GhcPass 'Renamed) -> NonEmpty FieldGlobalRdrElt
rnRecUpdLabels = NonEmpty FieldGlobalRdrElt
lbls, rnRecUpdCons :: HsRecUpdParent (GhcPass 'Renamed) -> 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
; 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'
; tc <- tcLookupRecSelParent par
; return $
TcRecUpdParent
{ tcRecUpdParent = tc
, tcRecUpdLabels = lbls
, tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } }
lookupField :: FieldGlobalRdrElt
-> LHsRecUpdField GhcRn GhcRn
-> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField :: FieldGlobalRdrElt
-> LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM (LHsRecUpdField GhcTc (GhcPass 'Renamed))
lookupField FieldGlobalRdrElt
fld_gre (L SrcSpanAnnA
l HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
upd)
= do { let L SrcSpanAnnA
loc FieldOcc (GhcPass 'Renamed)
af = HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed))
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
upd
lbl :: RdrName
lbl = FieldOcc (GhcPass 'Renamed) -> RdrName
forall (p :: Pass). IsPass p => FieldOcc (GhcPass p) -> RdrName
fieldOccRdrName FieldOcc (GhcPass 'Renamed)
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
; sel <- Name -> TcM TyCoVar
tcLookupId (FieldGlobalRdrElt -> Name
forall info. GlobalRdrEltX info -> Name
greName FieldGlobalRdrElt
fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
, hfbLHS = L (l2l loc) (FieldOcc lbl (L (l2l loc) sel))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
} }
reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn)
-> TyCon -> TcM ()
reportAmbiguousUpdate :: NonEmpty (HsRecUpdParent (GhcPass 'Renamed)) -> TyCon -> TcRn ()
reportAmbiguousUpdate NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
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 (GhcPass 'Renamed) -> TyCon -> TcRnMessage
TcRnAmbiguousRecordUpdate HsExpr (GhcPass 'Renamed)
rupd TyCon
parent_type
where
rupd :: HsExpr (GhcPass 'Renamed)
rupd = RecordUpd { rupd_expr :: LHsExpr (GhcPass 'Renamed)
rupd_expr = LHsExpr (GhcPass 'Renamed)
record_expr
, rupd_flds :: LHsRecUpdFields (GhcPass 'Renamed)
rupd_flds =
RegularRecUpdFields
{ xRecUpdFields :: XLHsRecUpdLabels (GhcPass 'Renamed)
xRecUpdFields = NonEmpty (HsRecUpdParent (GhcPass 'Renamed))
XLHsRecUpdLabels (GhcPass 'Renamed)
parents
, recUpdFields :: [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
recUpdFields = [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbnds }
, rupd_ext :: XRecordUpd (GhcPass 'Renamed)
rupd_ext = XRecordUpd (GhcPass 'Renamed)
NoExtField
noExtField }
loc :: SrcSpan
loc = GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))
forall a. HasCallStack => [a] -> a
head [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rbnds)
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds :: ConLike
-> [Type]
-> HsRecordBinds (GhcPass 'Renamed)
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [Type]
arg_tys (HsRecFields XHsRecFields (GhcPass 'Renamed)
x [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
rbinds Maybe (XRec (GhcPass 'Renamed) RecFieldsDotDot)
dd)
= do { mb_binds <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> 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 LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
do_bind [LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rbinds
; return (HsRecFields x (catMaybes mb_binds) 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. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [Type]
arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind :: LHsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L SrcSpanAnnA
l fld :: HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
fld@(HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed))
f
, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = LocatedA (HsExpr (GhcPass 'Renamed))
rhs }))
= do { mb <- ConLike
-> [(Name, Type)]
-> LFieldOcc (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys LFieldOcc (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed))
f LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
rhs
; case 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 (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> XHsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
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 (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Renamed)))
(LocatedA (HsExpr (GhcPass 'Renamed)))
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 (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys (L SrcSpanAnnA
loc (FieldOcc XCFieldOcc (GhcPass 'Renamed)
rdr (L SrcSpanAnnN
l Name
sel_name))) LHsExpr (GhcPass 'Renamed)
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 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 { rhs' <- LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr (GhcPass 'Renamed)
rhs Type
field_ty
; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))
field_ty
; let field_id = OccName -> Unique -> Type -> Type -> SrcSpan -> TyCoVar
mkUserLocal (Name -> OccName
nameOccName Name
sel_name)
(Name -> Unique
nameUnique Name
sel_name)
Type
ManyTy Type
field_ty (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc)
; return (Just (L loc (FieldOcc rdr (L l field_id)), 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 XCFieldOcc (GhcPass 'Renamed)
RdrName
rdr
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike
-> HsRecordBinds (GhcPass 'Renamed) -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds (GhcPass 'Renamed)
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
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
addErrTc (TcRnMissingStrictFields con_like fs)
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
when (warn && notNull missing_ns_fields) $ do
fs <- liftZonkM $ zonk_fields missing_ns_fields
let msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like [(FieldLabelString, Type)]
fs
diagnosticTc True 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
ty' <- Type -> ZonkM Type
zonkTcType Type
ty
return (str,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` [Name]
[IdGhcP 'Renamed]
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` [Name]
[IdGhcP 'Renamed]
field_names_used)
]
field_names_used :: [IdGhcP 'Renamed]
field_names_used = HsRecFields
(GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
-> [IdGhcP 'Renamed]
forall (p :: Pass) arg. HsRecFields (GhcPass p) arg -> [IdGhcP p]
hsRecFields HsRecordBinds (GhcPass 'Renamed)
HsRecFields
(GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
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
type_env <- TcM TcTypeEnv
getLclTypeEnv
case checkClosed type_env 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