{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module GHC.Tc.Gen.App
( tcApp
, tcInferSigma
, tcExprPrag ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
import GHC.Types.Var
import GHC.Builtin.Types ( multiplicityTy )
import GHC.Tc.Gen.Head
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCo.Subst (substTyWithInScope)
import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType )
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Function
import GHC.Prelude
tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcType
tcInferSigma Bool
inst (L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcRn
rn_expr)
| (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun,AppCtxt
_), [HsExprArg 'TcpRn]
rn_args) <- HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
rn_expr
= HsExpr GhcRn -> TcM TcType -> TcM TcType
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
rn_expr (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
SrcSpanAnn' (EpAnn AnnListItem) -> TcM TcType -> TcM TcType
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
do { Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
; (HsExpr GhcTc
_tc_fun, TcType
fun_sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn, AppCtxt)
fun [HsExprArg 'TcpRn]
rn_args
; (Delta
_delta, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_sigma) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
inst (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
; [HsExprArg 'TcpTc]
_tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
inst_args
; TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_sigma }
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
rn_expr ExpRhoType
exp_res_ty
| (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt), [HsExprArg 'TcpRn]
rn_args) <- HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
rn_expr
= do { String -> SDoc -> TcRn ()
traceTc String
"tcApp {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rn_fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rn_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args ]
; (HsExpr GhcTc
tc_fun, TcType
fun_sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn, AppCtxt)
fun [HsExprArg 'TcpRn]
rn_args
; Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
; (Delta
delta, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_rho) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
True (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
; TcType
app_res_rho <- if Bool
do_ql
then Delta -> TcType -> ExpRhoType -> TcM TcType
quickLookResultType Delta
delta TcType
app_res_rho ExpRhoType
exp_res_ty
else TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_rho
; let perhaps_add_res_ty_ctxt :: TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt TcM HsWrapper
thing_inside
| AppCtxt -> Bool
insideExpansion AppCtxt
fun_ctxt
= TcM HsWrapper
thing_inside
| Bool
otherwise
= HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
-> TcM HsWrapper
forall a.
HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt HsExpr GhcRn
rn_fun [HsExprArg 'TcpRn]
rn_args TcType
app_res_rho ExpRhoType
exp_res_ty (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
TcM HsWrapper
thing_inside
; Bool
do_ds <- Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DeepSubsumption
; HsWrapper
res_wrap <- TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not Bool
do_ds
then
do { TcCoercionN
co <- HsExpr GhcRn -> TcType -> ExpRhoType -> TcM TcCoercionN
unifyExpectedType HsExpr GhcRn
rn_expr TcType
app_res_rho ExpRhoType
exp_res_ty
; HsWrapper -> TcM HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionN -> HsWrapper
mkWpCastN TcCoercionN
co) }
else
do { TcType
app_res_rho <- Bool -> TcType -> TcM TcType
zonkQuickLook Bool
do_ql TcType
app_res_rho
; HsExpr GhcRn -> TcType -> ExpRhoType -> TcM HsWrapper
tcSubTypeDS HsExpr GhcRn
rn_expr TcType
app_res_rho ExpRhoType
exp_res_ty }
; [HsExprArg 'TcpTc]
tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
inst_args
; HsExpr GhcTc
tc_expr <-
if HsExpr GhcRn -> Bool
isTagToEnum HsExpr GhcRn
rn_fun
then HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho
else do HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho
; DumpFlag -> TcRn () -> TcRn ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_tc_trace (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { [HsExprArg 'TcpInst]
inst_args <- (HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst))
-> [HsExprArg 'TcpInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExprArg 'TcpInst]
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 HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
zonkArg [HsExprArg 'TcpInst]
inst_args
; String -> SDoc -> TcRn ()
traceTc String
"tcApp }" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rn_fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rn_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inst_args" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ((HsExprArg 'TcpInst -> SDoc) -> [HsExprArg 'TcpInst] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc [HsExprArg 'TcpInst]
inst_args)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do_ql: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
do_ql
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun_sigma: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"delta: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app_res_rho:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exp_res_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_res_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rn_expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_expr
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpTc]
tc_args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_expr ]) }
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
res_wrap HsExpr GhcTc
tc_expr) }
wantQuickLook :: HsExpr GhcRn -> TcM Bool
wantQuickLook :: HsExpr GhcRn -> TcM Bool
wantQuickLook (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
f))
| Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
f Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
quickLookKeys = Bool -> TcM Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
wantQuickLook HsExpr GhcRn
_ = Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
quickLookKeys :: [Unique]
quickLookKeys :: [Unique]
quickLookKeys = [Unique
dollarIdKey, Unique
leftSectionKey, Unique
rightSectionKey]
zonkQuickLook :: Bool -> TcType -> TcM TcType
zonkQuickLook :: Bool -> TcType -> TcM TcType
zonkQuickLook Bool
do_ql TcType
ty
| Bool
do_ql = TcType -> TcM TcType
zonkTcType TcType
ty
| Bool
otherwise = TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty
zonkArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
zonkArg :: HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
zonkArg eva :: HsExprArg 'TcpInst
eva@(EValArg { eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = Scaled TcType
m TcType
ty })
= do { TcType
ty' <- TcType -> TcM TcType
zonkTcType TcType
ty
; HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExprArg 'TcpInst
eva { eva_arg_ty = Scaled m ty' }) }
zonkArg HsExprArg 'TcpInst
arg = HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExprArg 'TcpInst
arg
tcValArgs :: Bool
-> [HsExprArg 'TcpInst]
-> TcM [HsExprArg 'TcpTc]
tcValArgs :: Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
args
= (HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc))
-> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
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 HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tc_arg [HsExprArg 'TcpInst]
args
where
tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)
tc_arg :: HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tc_arg (EPrag AppCtxt
l HsPragE (GhcPass (XPass 'TcpInst))
p) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt -> HsPragE (GhcPass (XPass 'TcpTc)) -> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
l (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
HsPragE (GhcPass (XPass 'TcpInst))
p))
tc_arg (EWrap EWrap
w) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EWrap -> HsExprArg 'TcpTc
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
w)
tc_arg (ETypeArg AppCtxt
l LHsToken "@" GhcRn
at LHsWcType GhcRn
hs_ty XETAType 'TcpInst
ty) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt
-> LHsToken "@" GhcRn
-> LHsWcType GhcRn
-> XETAType 'TcpTc
-> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt
-> LHsToken "@" GhcRn
-> LHsWcType GhcRn
-> XETAType p
-> HsExprArg p
ETypeArg AppCtxt
l LHsToken "@" GhcRn
at LHsWcType GhcRn
hs_ty XETAType 'TcpInst
XETAType 'TcpTc
ty)
tc_arg eva :: HsExprArg 'TcpInst
eva@(EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg 'TcpInst
arg, eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = Scaled TcType
mult TcType
arg_ty
, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt })
= do {
TcType
arg_ty <- Bool -> TcType -> TcM TcType
zonkQuickLook Bool
do_ql TcType
arg_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
arg' <- TcType
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult (TcM (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcEValArg" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ AppCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr AppCtxt
ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
arg_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
arg ]
; AppCtxt -> EValArg 'TcpInst -> TcType -> TcM (LHsExpr GhcTc)
tcEValArg AppCtxt
ctxt EValArg 'TcpInst
arg TcType
arg_ty }
; HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExprArg 'TcpInst
eva { eva_arg = ValArg arg'
, eva_arg_ty = Scaled mult arg_ty }) }
tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc)
tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcType -> TcM (LHsExpr GhcTc)
tcEValArg AppCtxt
ctxt (ValArg larg :: LHsExpr (GhcPass (XPass 'TcpInst))
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
arg)) TcType
exp_arg_sigma
= AppCtxt
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpInst))
larg (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
arg' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
exp_arg_sigma)
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcTc
arg') }
tcEValArg AppCtxt
ctxt (ValArgQL { va_expr :: EValArg 'TcpInst -> LHsExpr GhcRn
va_expr = larg :: LHsExpr GhcRn
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
_)
, va_fun :: EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc
inner_fun, AppCtxt
fun_ctxt)
, va_args :: EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
inner_args
, va_ty :: EValArg 'TcpInst -> TcType
va_ty = TcType
app_res_rho }) TcType
exp_arg_sigma
= AppCtxt
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
larg (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
"tcEValArgQL {" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
inner_fun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
inner_args ])
; [HsExprArg 'TcpTc]
tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
True [HsExprArg 'TcpInst]
inner_args
; TcCoercionN
co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyType Maybe TypedThing
forall a. Maybe a
Nothing TcType
app_res_rho TcType
exp_arg_sigma
; HsExpr GhcTc
arg' <- TcCoercionN -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionN
co (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
inner_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho
; String -> SDoc -> TcRn ()
traceTc String
"tcEValArgQL }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inner_fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
inner_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app_res_rho:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exp_arg_sigma:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
exp_arg_sigma ]
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcTc
arg') }
type Delta = TcTyVarSet
tcInstFun :: Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( Delta
, [HsExprArg 'TcpInst]
, TcSigmaType )
tcInstFun :: Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
inst_final (HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt) TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
= do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do_ql" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
do_ql ])
; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
emptyVarSet [] [] TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args }
where
fun_orig :: CtOrigin
fun_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin (case AppCtxt
fun_ctxt of
VAExpansion HsExpr GhcRn
e SrcSpan
_ -> HsExpr GhcRn
e
VACall HsExpr GhcRn
e Int
_ SrcSpan
_ -> HsExpr GhcRn
e)
n_val_args :: Int
n_val_args = (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpRn]
rn_args
fun_is_out_of_scope :: Bool
fun_is_out_of_scope
= case HsExpr GhcRn
rn_fun of
HsUnboundVar {} -> Bool
True
HsExpr GhcRn
_ -> Bool
False
inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool
inst_all :: ForAllTyFlag -> Bool
inst_all (Invisible {}) = Bool
True
inst_all ForAllTyFlag
Required = Bool
False
inst_inferred :: ForAllTyFlag -> Bool
inst_inferred (Invisible Specificity
InferredSpec) = Bool
True
inst_inferred (Invisible Specificity
SpecifiedSpec) = Bool
False
inst_inferred ForAllTyFlag
Required = Bool
False
inst_none :: ForAllTyFlag -> Bool
inst_none ForAllTyFlag
_ = Bool
False
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun [] | Bool
inst_final = ForAllTyFlag -> Bool
inst_all
| Bool
otherwise = ForAllTyFlag -> Bool
inst_none
inst_fun (EValArg {} : [HsExprArg 'TcpRn]
_) = ForAllTyFlag -> Bool
inst_all
inst_fun [HsExprArg 'TcpRn]
_ = ForAllTyFlag -> Bool
inst_inferred
go, go1 :: Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcSigmaTypeFRR]
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)
go :: Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
| Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
getTyVar_maybe TcType
fun_ty
, TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
= do { MetaDetails
cts <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
; case MetaDetails
cts of
Indirect TcType
fun_ty' -> Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty' [HsExprArg 'TcpRn]
args
MetaDetails
Flexi -> Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args }
| Bool
otherwise
= Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 :: Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
| ([TcTyVar]
tvs, TcType
body1) <- (ForAllTyFlag -> Bool) -> TcType -> ([TcTyVar], TcType)
tcSplitSomeForAllTyVars ([HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun [HsExprArg 'TcpRn]
args) TcType
fun_ty
, (ThetaType
theta, TcType
body2) <- TcType -> (ThetaType, TcType)
tcSplitPhiTy TcType
body1
, Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
= do { ([TcTyVar]
inst_tvs, HsWrapper
wrap, TcType
fun_rho) <- AppCtxt
-> TcM ([TcTyVar], HsWrapper, TcType)
-> TcM ([TcTyVar], HsWrapper, TcType)
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
fun_ctxt (TcM ([TcTyVar], HsWrapper, TcType)
-> TcM ([TcTyVar], HsWrapper, TcType))
-> TcM ([TcTyVar], HsWrapper, TcType)
-> TcM ([TcTyVar], HsWrapper, TcType)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> [TcTyVar]
-> ThetaType
-> TcType
-> TcM ([TcTyVar], HsWrapper, TcType)
instantiateSigma CtOrigin
fun_orig [TcTyVar]
tvs ThetaType
theta TcType
body2
; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go (Delta
delta Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
inst_tvs)
(HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_rho [HsExprArg 'TcpRn]
args }
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
_ TcType
fun_ty []
= do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun:ret" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty)
; (Delta, [HsExprArg 'TcpInst], TcType)
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. [a] -> [a]
reverse [HsExprArg 'TcpInst]
acc, TcType
fun_ty) }
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty (EWrap EWrap
w : [HsExprArg 'TcpRn]
args)
= Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta (EWrap -> HsExprArg 'TcpInst
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
w HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty (EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
prag : [HsExprArg 'TcpRn]
args)
= Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta (AppCtxt -> HsPragE (GhcPass (XPass 'TcpInst)) -> HsExprArg 'TcpInst
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
HsPragE (GhcPass (XPass 'TcpInst))
prag HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty ( ETypeArg { eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_at :: forall (p :: TcPass). HsExprArg p -> LHsToken "@" GhcRn
eva_at = LHsToken "@" GhcRn
at, eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty }
: [HsExprArg 'TcpRn]
rest_args )
| Bool
fun_is_out_of_scope
= Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
rest_args
| Bool
otherwise
= do { (TcType
ty_arg, TcType
inst_ty) <- TcType -> LHsWcType GhcRn -> TcM (TcType, TcType)
tcVTA TcType
fun_ty LHsWcType GhcRn
hs_ty
; let arg' :: HsExprArg 'TcpInst
arg' = ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_at :: LHsToken "@" GhcRn
eva_at = LHsToken "@" GhcRn
at, eva_hs_ty :: LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty, eva_ty :: XETAType 'TcpInst
eva_ty = TcType
XETAType 'TcpInst
ty_arg }
; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta (HsExprArg 'TcpInst
arg' HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
inst_ty [HsExprArg 'TcpRn]
rest_args }
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty args :: [HsExprArg 'TcpRn]
args@(EValArg {} : [HsExprArg 'TcpRn]
_)
| Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
getTyVar_maybe TcType
fun_ty
, TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
=
do { let valArgsCount :: Int
valArgsCount = [HsExprArg 'TcpRn] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countLeadingValArgs [HsExprArg 'TcpRn]
args
; [TcTyVar]
arg_nus <- Int
-> IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
-> IOEnv (Env TcGblEnv TcLclEnv) [TcTyVar]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
valArgsCount IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
newOpenFlexiTyVar
; ThetaType
mults <- Int -> TcM TcType -> IOEnv (Env TcGblEnv TcLclEnv) ThetaType
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
valArgsCount (TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy)
; TcTyVar
res_nu <- IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
newOpenFlexiTyVar
; TcCoercionN
kind_co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyKind Maybe TypedThing
forall a. Maybe a
Nothing TcType
liftedTypeKind (TcTyVar -> TcType
tyVarKind TcTyVar
kappa)
; let delta' :: Delta
delta' = Delta
delta Delta -> [TcTyVar] -> Delta
`extendVarSetList` (TcTyVar
res_nuTcTyVar -> [TcTyVar] -> [TcTyVar]
forall a. a -> [a] -> [a]
:[TcTyVar]
arg_nus)
arg_tys :: ThetaType
arg_tys = [TcTyVar] -> ThetaType
mkTyVarTys [TcTyVar]
arg_nus
res_ty :: TcType
res_ty = TcTyVar -> TcType
mkTyVarTy TcTyVar
res_nu
fun_ty' :: TcType
fun_ty' = [Scaled TcType] -> TcType -> TcType
(() :: Constraint) => [Scaled TcType] -> TcType -> TcType
mkScaledFunTys (String
-> (TcType -> TcType -> Scaled TcType)
-> ThetaType
-> ThetaType
-> [Scaled TcType]
forall a b c.
(() :: Constraint) =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"tcInstFun" TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
mkScaled ThetaType
mults ThetaType
arg_tys) TcType
res_ty
co_wrap :: HsWrapper
co_wrap = TcCoercionN -> HsWrapper
mkWpCastN (Role -> TcType -> TcCoercionN -> TcCoercionN
mkGReflLeftCo Role
Nominal TcType
fun_ty' TcCoercionN
kind_co)
acc' :: [HsExprArg 'TcpInst]
acc' = HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
co_wrap [HsExprArg 'TcpInst]
acc
; (() :: Constraint) => TcTyVar -> TcType -> TcRn ()
TcTyVar -> TcType -> TcRn ()
writeMetaTyVar TcTyVar
kappa (TcType -> TcCoercionN -> TcType
mkCastTy TcType
fun_ty' TcCoercionN
kind_co)
; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta' [HsExprArg 'TcpInst]
acc' [Scaled TcType]
so_far TcType
fun_ty' [HsExprArg 'TcpRn]
args }
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty
(eva :: HsExprArg 'TcpRn
eva@(EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg LHsExpr (GhcPass (XPass 'TcpRn))
arg, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt }) : [HsExprArg 'TcpRn]
rest_args)
= do { (HsWrapper
wrap, Scaled TcType
arg_ty, TcType
res_ty) <-
ExpectedFunTyOrigin
-> Maybe TypedThing
-> (Int, [Scaled TcType])
-> TcType
-> TcM (HsWrapper, Scaled TcType, TcType)
matchActualFunTySigma
(TypedThing -> HsExpr GhcRn -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg (HsExpr GhcRn -> TypedThing
HsExprRnThing HsExpr GhcRn
rn_fun) (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
-> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
arg))
(TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TypedThing -> Maybe TypedThing) -> TypedThing -> Maybe TypedThing
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TypedThing
HsExprRnThing HsExpr GhcRn
rn_fun)
(Int
n_val_args, [Scaled TcType]
so_far) TcType
fun_ty
; (Delta
delta', EValArg 'TcpInst
arg') <- if Bool
do_ql
then AppCtxt
-> LHsExpr GhcRn
-> TcM (Delta, EValArg 'TcpInst)
-> TcM (Delta, EValArg 'TcpInst)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpRn))
arg (TcM (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst))
-> TcM (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a b. (a -> b) -> a -> b
$
Delta
-> LHsExpr GhcRn -> Scaled TcType -> TcM (Delta, EValArg 'TcpInst)
quickLookArg Delta
delta LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpRn))
arg Scaled TcType
arg_ty
else (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, LHsExpr (GhcPass (XPass 'TcpInst)) -> EValArg 'TcpInst
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass (XPass 'TcpRn))
LHsExpr (GhcPass (XPass 'TcpInst))
arg)
; let acc' :: [HsExprArg 'TcpInst]
acc' = HsExprArg 'TcpRn
eva { eva_arg = arg', eva_arg_ty = arg_ty }
HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
acc
; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta' [HsExprArg 'TcpInst]
acc' (Scaled TcType
arg_tyScaled TcType -> [Scaled TcType] -> [Scaled TcType]
forall a. a -> [a] -> [a]
:[Scaled TcType]
so_far) TcType
res_ty [HsExprArg 'TcpRn]
rest_args }
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
addArgCtxt :: forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt (L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
arg) TcM a
thing_inside
= do { Bool
in_generated_code <- TcM Bool
inGeneratedCode
; case AppCtxt
ctxt of
VACall HsExpr GhcRn
fun Int
arg_no SrcSpan
_ | Bool -> Bool
not Bool
in_generated_code
-> SrcSpanAnn' (EpAnn AnnListItem) -> TcM a -> TcM a
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> HsExpr GhcRn -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt HsExpr GhcRn
fun HsExpr GhcRn
arg Int
arg_no) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
AppCtxt
_ -> SrcSpanAnn' (EpAnn AnnListItem) -> TcM a -> TcM a
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> TcM a -> TcM a
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
arg (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside }
tcVTA :: TcType
-> LHsWcType GhcRn
-> TcM (TcType, TcType)
tcVTA :: TcType -> LHsWcType GhcRn -> TcM (TcType, TcType)
tcVTA TcType
fun_ty LHsWcType GhcRn
hs_ty
| Just (TyVarBinder
tvb, TcType
inner_ty) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
, TyVarBinder -> ForAllTyFlag
forall tv argf. VarBndr tv argf -> argf
binderFlag TyVarBinder
tvb ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
Specified
= do { let tv :: TcTyVar
tv = TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
kind :: TcType
kind = TcTyVar -> TcType
tyVarKind TcTyVar
tv
; TcType
ty_arg <- LHsWcType GhcRn -> TcType -> TcM TcType
tcHsTypeApp LHsWcType GhcRn
hs_ty TcType
kind
; TcType
inner_ty <- TcType -> TcM TcType
zonkTcType TcType
inner_ty
; let in_scope :: InScopeSet
in_scope = Delta -> InScopeSet
mkInScopeSet (ThetaType -> Delta
tyCoVarsOfTypes [TcType
fun_ty, TcType
ty_arg])
insted_ty :: TcType
insted_ty = InScopeSet -> [TcTyVar] -> ThetaType -> TcType -> TcType
substTyWithInScope InScopeSet
in_scope [TcTyVar
tv] [TcType
ty_arg] TcType
inner_ty
; String -> SDoc -> TcRn ()
traceTc String
"VTA" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tv" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
debugPprType TcType
kind
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ty_arg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
debugPprType TcType
ty_arg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
debugPprType ((() :: Constraint) => TcType -> TcType
TcType -> TcType
typeKind TcType
ty_arg)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inner_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
debugPprType TcType
inner_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"insted_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
debugPprType TcType
insted_ty ])
; (TcType, TcType) -> TcM (TcType, TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
ty_arg, TcType
insted_ty) }
| Bool
otherwise
= do { (TidyEnv
_, TcType
fun_ty) <- TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcType
fun_ty
; TcRnMessage -> TcM (TcType, TcType)
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> TcM (TcType, TcType))
-> TcRnMessage -> TcM (TcType, TcType)
forall a b. (a -> b) -> a -> b
$ TcType -> LHsWcType GhcRn -> TcRnMessage
TcRnInvalidTypeApplication TcType
fun_ty LHsWcType GhcRn
hs_ty }
quickLookArg :: Delta
-> LHsExpr GhcRn
-> Scaled TcSigmaTypeFRR
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg :: Delta
-> LHsExpr GhcRn -> Scaled TcType -> TcM (Delta, EValArg 'TcpInst)
quickLookArg Delta
delta LHsExpr GhcRn
larg (Scaled TcType
_ TcType
arg_ty)
| Delta -> Bool
isEmptyVarSet Delta
delta = Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
| Bool
otherwise = TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty
where
guarded :: Bool
guarded = TcType -> Bool
isGuardedTy TcType
arg_ty
go :: TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty | Bool -> Bool
not (TcType -> Bool
isRhoTy TcType
arg_ty)
= Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
| Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
getTyVar_maybe TcType
arg_ty
, TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
= do { MetaDetails
info <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
; case MetaDetails
info of
Indirect TcType
arg_ty' -> TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty'
MetaDetails
Flexi -> Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta LHsExpr GhcRn
larg TcType
arg_ty }
| Bool
otherwise
= Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta LHsExpr GhcRn
larg TcType
arg_ty
isGuardedTy :: TcType -> Bool
isGuardedTy :: TcType -> Bool
isGuardedTy TcType
ty
| Just (TyCon
tc,ThetaType
_) <- HasCallStack => TcType -> Maybe (TyCon, ThetaType)
TcType -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe TcType
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
| Just {} <- TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty = Bool
True
| Bool
otherwise = Bool
False
quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 :: Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta larg :: LHsExpr GhcRn
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
_ HsExpr GhcRn
arg) TcType
arg_ty
= do { let (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt), [HsExprArg 'TcpRn]
rn_args) = HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
arg
; Maybe (HsExpr GhcTc, TcType)
mb_fun_ty <- HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcType))
tcInferAppHead_maybe HsExpr GhcRn
rn_fun [HsExprArg 'TcpRn]
rn_args
; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 1" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"head:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (HsExpr GhcTc, TcType) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (HsExpr GhcTc, TcType)
mb_fun_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args ]
; case Maybe (HsExpr GhcTc, TcType)
mb_fun_ty of {
Maybe (HsExpr GhcTc, TcType)
Nothing ->
Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg ;
Just (HsExpr GhcTc
tc_fun, TcType
fun_sigma) ->
do { let no_free_kappas :: Bool
no_free_kappas = TcType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"no_free_kappas:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
no_free_kappas
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"guarded:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
guarded
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun_sigma:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma ]
; if Bool -> Bool
not (Bool
guarded Bool -> Bool -> Bool
|| Bool
no_free_kappas)
then Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
else
do { Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
; (Delta
delta_app, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_rho) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
True (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 3" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"delta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"delta_app:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta_app
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
arg_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app_res_rho:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho ]
; let delta' :: Delta
delta' = Delta
delta Delta -> Delta -> Delta
`unionVarSet` Delta
delta_app
; Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta' TcType
arg_ty TcType
app_res_rho
; let ql_arg :: EValArg 'TcpInst
ql_arg = ValArgQL { va_expr :: LHsExpr GhcRn
va_expr = LHsExpr GhcRn
larg
, va_fun :: (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt)
, va_args :: [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
inst_args
, va_ty :: TcType
va_ty = TcType
app_res_rho }
; (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta', EValArg 'TcpInst
ql_arg) } } } }
skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg = (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, LHsExpr (GhcPass (XPass 'TcpInst)) -> EValArg 'TcpInst
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpInst))
larg)
quickLookResultType :: Delta -> TcRhoType -> ExpRhoType -> TcM TcRhoType
quickLookResultType :: Delta -> TcType -> ExpRhoType -> TcM TcType
quickLookResultType Delta
delta TcType
app_res_rho (Check TcType
exp_rho)
=
do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Delta -> Bool
isEmptyVarSet Delta
delta) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta TcType
app_res_rho TcType
exp_rho
; TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_rho }
quickLookResultType Delta
_ TcType
app_res_rho (Infer {})
= TcType -> TcM TcType
zonkTcType TcType
app_res_rho
qlUnify :: Delta -> TcType -> TcType -> TcM ()
qlUnify :: Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta TcType
ty1 TcType
ty2
= do { String -> SDoc -> TcRn ()
traceTc String
"qlUnify" (Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2)
; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta
emptyVarSet,Delta
emptyVarSet) TcType
ty1 TcType
ty2 }
where
go :: (TyVarSet, TcTyVarSet)
-> TcType -> TcType
-> TcM ()
go :: (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs (TyVarTy TcTyVar
tv) TcType
ty2
| TcTyVar
tv TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta = (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta, Delta)
bvs TcTyVar
tv TcType
ty2
go (Delta
bvs1, Delta
bvs2) TcType
ty1 (TyVarTy TcTyVar
tv)
| TcTyVar
tv TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta = (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta
bvs2,Delta
bvs1) TcTyVar
tv TcType
ty1
go (Delta, Delta)
bvs (CastTy TcType
ty1 TcCoercionN
_) TcType
ty2 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
go (Delta, Delta)
bvs TcType
ty1 (CastTy TcType
ty2 TcCoercionN
_) = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
go (Delta, Delta)
_ (TyConApp TyCon
tc1 []) (TyConApp TyCon
tc2 [])
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
| Just TcType
rho1 <- TcType -> Maybe TcType
coreView TcType
rho1 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
| Just TcType
rho2 <- TcType -> Maybe TcType
coreView TcType
rho2 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
go (Delta, Delta)
bvs (TyConApp TyCon
tc1 ThetaType
tys1) (TyConApp TyCon
tc2 ThetaType
tys2)
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
, Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc1)
, ThetaType
tys1 ThetaType -> ThetaType -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` ThetaType
tys2
= (TcType -> TcType -> TcRn ()) -> ThetaType -> ThetaType -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs) ThetaType
tys1 ThetaType
tys2
go (Delta, Delta)
bvs (FunTy { ft_af :: TcType -> FunTyFlag
ft_af = FunTyFlag
af1, ft_arg :: TcType -> TcType
ft_arg = TcType
arg1, ft_res :: TcType -> TcType
ft_res = TcType
res1, ft_mult :: TcType -> TcType
ft_mult = TcType
mult1 })
(FunTy { ft_af :: TcType -> FunTyFlag
ft_af = FunTyFlag
af2, ft_arg :: TcType -> TcType
ft_arg = TcType
arg2, ft_res :: TcType -> TcType
ft_res = TcType
res2, ft_mult :: TcType -> TcType
ft_mult = TcType
mult2 })
| FunTyFlag
af1 FunTyFlag -> FunTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== FunTyFlag
af2
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af1) ((Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
arg1 TcType
arg2)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunTyFlag -> Bool
isFUNArg FunTyFlag
af1) ((Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
mult1 TcType
mult2)
; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
res1 TcType
res2 }
go (Delta, Delta)
bvs (AppTy TcType
t1a TcType
t1b) TcType
ty2
| Just (TcType
t2a, TcType
t2b) <- TcType -> Maybe (TcType, TcType)
tcSplitAppTyNoView_maybe TcType
ty2
= do { (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1a TcType
t2a; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1b TcType
t2b }
go (Delta, Delta)
bvs TcType
ty1 (AppTy TcType
t2a TcType
t2b)
| Just (TcType
t1a, TcType
t1b) <- TcType -> Maybe (TcType, TcType)
tcSplitAppTyNoView_maybe TcType
ty1
= do { (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1a TcType
t2a; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1b TcType
t2b }
go (Delta
bvs1, Delta
bvs2) (ForAllTy TyVarBinder
bv1 TcType
ty1) (ForAllTy TyVarBinder
bv2 TcType
ty2)
= (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta
bvs1',Delta
bvs2') TcType
ty1 TcType
ty2
where
bvs1' :: Delta
bvs1' = Delta
bvs1 Delta -> TcTyVar -> Delta
`extendVarSet` TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
bv1
bvs2' :: Delta
bvs2' = Delta
bvs2 Delta -> TcTyVar -> Delta
`extendVarSet` TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
bv2
go (Delta, Delta)
_ TcType
_ TcType
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_kappa :: (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta, Delta)
bvs TcTyVar
kappa TcType
ty2
= Bool -> SDoc -> TcRn () -> TcRn ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TcTyVar -> Bool
isMetaTyVar TcTyVar
kappa) (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
kappa) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { MetaDetails
info <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
; case MetaDetails
info of
Indirect TcType
ty1 -> (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
MetaDetails
Flexi -> do { TcType
ty2 <- TcType -> TcM TcType
zonkTcType TcType
ty2
; (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
forall {a}. (a, Delta) -> TcTyVar -> TcType -> TcRn ()
go_flexi (Delta, Delta)
bvs TcTyVar
kappa TcType
ty2 } }
go_flexi :: (a, Delta) -> TcTyVar -> TcType -> TcRn ()
go_flexi (a
_,Delta
bvs2) TcTyVar
kappa TcType
ty2
|
let ty2_tvs :: Delta
ty2_tvs = TcType -> Delta
shallowTyCoVarsOfType TcType
ty2
, Bool -> Bool
not (Delta
ty2_tvs Delta -> Delta -> Bool
`intersectsVarSet` Delta
bvs2)
, Just TcType
ty2 <- [TcTyVar] -> TcType -> Maybe TcType
occCheckExpand [TcTyVar
kappa] TcType
ty2
= do { let ty2_kind :: TcType
ty2_kind = (() :: Constraint) => TcType -> TcType
TcType -> TcType
typeKind TcType
ty2
kappa_kind :: TcType
kappa_kind = TcTyVar -> TcType
tyVarKind TcTyVar
kappa
; TcCoercionN
co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyKind (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TcType -> TypedThing
TypeThing TcType
ty2)) TcType
ty2_kind TcType
kappa_kind
; String -> SDoc -> TcRn ()
traceTc String
"qlUnify:update" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
kappa SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
kappa_kind)
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2_kind)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"co:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcCoercionN -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCoercionN
co ]
; (() :: Constraint) => TcTyVar -> TcType -> TcRn ()
TcTyVar -> TcType -> TcRn ()
writeMetaTyVar TcTyVar
kappa (TcType -> TcCoercionN -> TcType
mkCastTy TcType
ty2 TcCoercionN
co) }
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
findNoQuantVars :: TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars :: TcType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars TcType
fun_ty [HsExprArg 'TcpRn]
args
= Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
emptyVarSet TcType
fun_ty [HsExprArg 'TcpRn]
args
where
need_instantiation :: [HsExprArg p] -> Bool
need_instantiation [] = Bool
True
need_instantiation (EValArg {} : [HsExprArg p]
_) = Bool
True
need_instantiation [HsExprArg p]
_ = Bool
False
go :: TyVarSet -> TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
go :: Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
| [HsExprArg 'TcpRn] -> Bool
forall {p :: TcPass}. [HsExprArg p] -> Bool
need_instantiation [HsExprArg 'TcpRn]
args
, ([TcTyVar]
tvs, ThetaType
theta, TcType
rho) <- TcType -> ([TcTyVar], ThetaType, TcType)
tcSplitSigmaTy TcType
fun_ty
, Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
= Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go (Delta
bvs Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
tvs) TcType
rho [HsExprArg 'TcpRn]
args
go Delta
bvs TcType
fun_ty [] = TcType -> Delta
tyCoVarsOfType TcType
fun_ty Delta -> Delta -> Bool
`disjointVarSet` Delta
bvs
go Delta
bvs TcType
fun_ty (EWrap {} : [HsExprArg 'TcpRn]
args) = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
go Delta
bvs TcType
fun_ty (EPrag {} : [HsExprArg 'TcpRn]
args) = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
go Delta
bvs TcType
fun_ty args :: [HsExprArg 'TcpRn]
args@(ETypeArg {} : [HsExprArg 'TcpRn]
rest_args)
| ([TcTyVar]
tvs, TcType
body1) <- (ForAllTyFlag -> Bool) -> TcType -> ([TcTyVar], TcType)
tcSplitSomeForAllTyVars (ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
Inferred) TcType
fun_ty
, (ThetaType
theta, TcType
body2) <- TcType -> (ThetaType, TcType)
tcSplitPhiTy TcType
body1
, Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
= Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go (Delta
bvs Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
tvs) TcType
body2 [HsExprArg 'TcpRn]
args
| Just (TyVarBinder
_tv, TcType
res_ty) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
= Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
res_ty [HsExprArg 'TcpRn]
rest_args
| Bool
otherwise
= Bool
False
go Delta
bvs TcType
fun_ty (EValArg {} : [HsExprArg 'TcpRn]
rest_args)
| Just (Scaled TcType
_, TcType
res_ty) <- TcType -> Maybe (Scaled TcType, TcType)
tcSplitFunTy_maybe TcType
fun_ty
= Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
res_ty [HsExprArg 'TcpRn]
rest_args
| Bool
otherwise
= Bool
False
isTagToEnum :: HsExpr GhcRn -> Bool
isTagToEnum :: HsExpr GhcRn -> Bool
isTagToEnum (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
fun_id)) = Name
fun_id Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
isTagToEnum HsExpr GhcRn
_ = Bool
False
tcTagToEnum :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]
-> TcRhoType
-> TcM (HsExpr GhcTc)
tcTagToEnum :: HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
res_ty
| [HsExprArg 'TcpTc
val_arg] <- (HsExprArg 'TcpTc -> Bool)
-> [HsExprArg 'TcpTc] -> [HsExprArg 'TcpTc]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (HsExprArg 'TcpTc -> Bool) -> HsExprArg 'TcpTc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExprArg 'TcpTc -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg) [HsExprArg 'TcpTc]
tc_args
= do { TcType
res_ty <- TcType -> TcM TcType
zonkTcType TcType
res_ty
; case HasCallStack => TcType -> Maybe (TyCon, ThetaType)
TcType -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe TcType
res_ty of {
Maybe (TyCon, ThetaType)
Nothing -> do { TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumUnspecifiedResTy TcType
res_ty)
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
tc, ThetaType
tc_args) ->
do {
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case FamInstEnvs
-> TyCon -> ThetaType -> Maybe (TyCon, ThetaType, TcCoercionN)
tcLookupDataFamInst_maybe FamInstEnvs
fam_envs TyCon
tc ThetaType
tc_args of {
Maybe (TyCon, ThetaType, TcCoercionN)
Nothing -> do { TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
tc
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
rep_tc, ThetaType
rep_args, TcCoercionN
coi) ->
do {
TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
rep_tc
; let rep_ty :: TcType
rep_ty = TyCon -> ThetaType -> TcType
mkTyConApp TyCon
rep_tc ThetaType
rep_args
tc_fun' :: HsExpr GhcTc
tc_fun' = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (TcType -> HsWrapper
WpTyApp TcType
rep_ty) HsExpr GhcTc
tc_fun
df_wrap :: HsWrapper
df_wrap = TcCoercionN -> HsWrapper
mkWpCastR (TcCoercionN -> TcCoercionN
mkSymCo TcCoercionN
coi)
; HsExpr GhcTc
tc_expr <- HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
tc_fun' AppCtxt
fun_ctxt [HsExprArg 'TcpTc
val_arg] TcType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
df_wrap HsExpr GhcTc
tc_expr) }}}}}
| Bool
otherwise
= TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
TcRnTagToEnumMissingValArg
where
vanilla_result :: TcM (HsExpr GhcTc)
vanilla_result = HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
res_ty
check_enumeration :: TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
tc
|
TyCon -> Bool
isTypeDataTyCon TyCon
tc = TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumResTyTypeData TcType
ty')
| TyCon -> Bool
isEnumerationTyCon TyCon
tc = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumResTyNotAnEnum TcType
ty')
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag (HsPragSCC XSCC GhcRn
x1 StringLiteral
ann) = XSCC GhcTc -> StringLiteral -> HsPragE GhcTc
forall p. XSCC p -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcRn
XSCC GhcTc
x1 StringLiteral
ann