{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module GHC.Tc.Gen.Head
( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, leadingValArgs, isVisibleArg
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId, tcInferConLike, obviousSig
, tyConOf, tyConOfET, fieldNotInType
, nonBidirectionalErr
, pprArgInst
, addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
import GHC.Prelude
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Tc.Errors.Types
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint( WantedConstraints )
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Zonk.TcType
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( singleUsageUE )
import GHC.Core.PatSyn( PatSyn, patSynName )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe
import Control.Monad
import GHC.Rename.Unbound (WhatLooking(WL_Anything))
data TcPass = TcpRn
| TcpInst
| TcpTc
data HsExprArg (p :: TcPass) where
EValArg :: { forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt :: AppCtxt
, forall (p :: TcPass). HsExprArg p -> XEVAType p
ea_arg_ty :: !(XEVAType p)
, forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg :: LHsExpr (GhcPass (XPass p)) }
-> HsExprArg p
EValArgQL :: { HsExprArg 'TcpInst -> AppCtxt
eaql_ctxt :: AppCtxt
, HsExprArg 'TcpInst -> Scaled TcSigmaType
eaql_arg_ty :: Scaled TcSigmaType
, HsExprArg 'TcpInst -> LHsExpr (GhcPass 'Renamed)
eaql_larg :: LHsExpr GhcRn
, HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), AppCtxt)
eaql_tc_fun :: (HsExpr GhcTc, AppCtxt)
, HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args :: [HsExprArg 'TcpInst]
, HsExprArg 'TcpInst -> WantedConstraints
eaql_wanted :: WantedConstraints
, HsExprArg 'TcpInst -> Bool
eaql_encl :: Bool
, HsExprArg 'TcpInst -> TcSigmaType
eaql_res_rho :: TcRhoType }
-> HsExprArg 'TcpInst
ETypeArg :: { ea_ctxt :: AppCtxt
, forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty :: LHsWcType GhcRn
, forall (p :: TcPass). HsExprArg p -> XETAType p
ea_ty_arg :: !(XETAType p) }
-> HsExprArg p
EPrag :: AppCtxt -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p
EWrap :: EWrap -> HsExprArg p
type family XETAType (p :: TcPass) where
XETAType 'TcpRn = NoExtField
XETAType _ = Type
type family XEVAType (p :: TcPass) where
XEVAType 'TcpInst = Scaled TcSigmaType
XEVAType _ = NoExtField
data QLFlag = DoQL | NoQL
data EWrap = EPar AppCtxt
| EExpand HsThingRn
| EHsWrap HsWrapper
data AppCtxt
= VAExpansion
HsThingRn
SrcSpan
SrcSpan
| VACall
(HsExpr GhcRn) Int
SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion HsThingRn
_ SrcSpan
l SrcSpan
_) = SrcSpan
l
appCtxtLoc (VACall HsExpr (GhcPass 'Renamed)
_ ThLevel
_ SrcSpan
l) = SrcSpan
l
insideExpansion :: AppCtxt -> Bool
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = Bool
True
insideExpansion (VACall {}) = Bool
False
instance Outputable QLFlag where
ppr :: QLFlag -> SDoc
ppr QLFlag
DoQL = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DoQL"
ppr QLFlag
NoQL = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoQL"
instance Outputable AppCtxt where
ppr :: AppCtxt -> SDoc
ppr (VAExpansion HsThingRn
e SrcSpan
l SrcSpan
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VAExpansion" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsThingRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsThingRn
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
l
ppr (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
l) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VACall" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall doc. IsLine doc => ThLevel -> doc
int ThLevel
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
l
type family XPass (p :: TcPass) where
XPass 'TcpRn = 'Renamed
XPass 'TcpInst = 'Renamed
XPass 'TcpTc = 'Typechecked
mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg :: AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
e = EValArg { ea_arg :: LHsExpr (GhcPass (XPass 'TcpRn))
ea_arg = LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpRn))
e, ea_ctxt :: AppCtxt
ea_ctxt = AppCtxt
ctxt
, ea_arg_ty :: XEVAType 'TcpRn
ea_arg_ty = NoExtField
XEVAType 'TcpRn
noExtField }
mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType (GhcPass 'Renamed)
hs_ty =
ETypeArg { ea_ctxt :: AppCtxt
ea_ctxt = AppCtxt
ctxt
, ea_hs_ty :: LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty
, ea_ty_arg :: XETAType 'TcpRn
ea_ty_arg = NoExtField
XETAType 'TcpRn
noExtField }
addArgWrap :: HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap :: forall (p :: TcPass). HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap HsWrapper
wrap [HsExprArg p]
args
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap = [HsExprArg p]
args
| Bool
otherwise = EWrap -> HsExprArg p
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsWrapper -> EWrap
EHsWrap HsWrapper
wrap) HsExprArg p -> [HsExprArg p] -> [HsExprArg p]
forall a. a -> [a] -> [a]
: [HsExprArg p]
args
splitHsApps :: HsExpr GhcRn
-> TcM ( (HsExpr GhcRn, AppCtxt)
, [HsExprArg 'TcpRn])
splitHsApps :: HsExpr (GhcPass 'Renamed)
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
e = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
0 HsExpr (GhcPass 'Renamed)
e) []
where
top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
top_ctxt :: ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun) = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
top_ctxt ThLevel
n (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun) = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
top_ctxt ThLevel
n (HsAppType XAppTypeE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsWcType (NoGhcTc (GhcPass 'Renamed))
_) = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
top_ctxt ThLevel
n (HsApp XApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsExpr (GhcPass 'Renamed)
_) = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
top_ctxt ThLevel
n (XExpr (ExpandedThingRn HsThingRn
o HsExpr (GhcPass 'Renamed)
_))
| OrigExpr HsExpr (GhcPass 'Renamed)
fun <- HsThingRn
o = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
fun ThLevel
n SrcSpan
noSrcSpan
top_ctxt ThLevel
n HsExpr (GhcPass 'Renamed)
other_fun = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
other_fun ThLevel
n SrcSpan
noSrcSpan
top_lctxt :: ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n (L l
_ HsExpr (GhcPass 'Renamed)
fun) = ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n HsExpr (GhcPass 'Renamed)
fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
-> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go :: HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (AppCtxt -> EWrap
EPar AppCtxt
ctxt) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
p (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> HsPragE (GhcPass (XPass 'TcpRn)) -> HsExprArg 'TcpRn
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
ctxt HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpRn))
p HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (HsAppType XAppTypeE (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType (NoGhcTc (GhcPass 'Renamed))
LHsWcType (GhcPass 'Renamed)
ty HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (HsApp XApp (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsExpr (GhcPass 'Renamed)
arg) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
arg HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go e :: HsExpr (GhcPass 'Renamed)
e@(HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
splice_res HsUntypedSplice (GhcPass 'Renamed)
splice) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
= do { fun <- HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Renamed))
getUntypedSpliceBody XUntypedSplice (GhcPass 'Renamed)
HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
splice_res
; go fun ctxt' (EWrap (EExpand (OrigExpr e)) : args) }
where
ctxt' :: AppCtxt
ctxt' :: AppCtxt
ctxt' = case HsUntypedSplice (GhcPass 'Renamed)
splice of
HsUntypedSpliceExpr XUntypedSpliceExpr (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
_) -> SrcSpanAnnA -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt
HsQuasiQuote XQuasiQuote (GhcPass 'Renamed)
_ IdP (GhcPass 'Renamed)
_ (L EpAnn NoEpAnns
l FastString
_) -> EpAnn NoEpAnns -> AppCtxt -> AppCtxt
forall ann. EpAnn ann -> AppCtxt -> AppCtxt
set EpAnn NoEpAnns
l AppCtxt
ctxt
go (XExpr (ExpandedThingRn HsThingRn
o HsExpr (GhcPass 'Renamed)
e)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
| HsThingRn -> Bool
isHsThingRnExpr HsThingRn
o
= HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
o (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt))
(EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsThingRn -> EWrap
EExpand HsThingRn
o) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
| OrigStmt (L SrcSpanAnnA
_ StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt) <- HsThingRn
o
, BodyStmt{} <- StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt
= HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
o SrcSpan
generatedSrcSpan SrcSpan
generatedSrcSpan)
(EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsThingRn -> EWrap
EExpand HsThingRn
o) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
| OrigPat (L SrcSpanAnnA
loc Pat (GhcPass 'Renamed)
_) <- HsThingRn
o
= HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
o (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc))
(EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsThingRn -> EWrap
EExpand HsThingRn
o) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
| Bool
otherwise
= HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
o (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt))
(EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsThingRn -> EWrap
EExpand HsThingRn
o) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go e :: HsExpr (GhcPass 'Renamed)
e@(OpApp XOpApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
arg1 (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
op) LHsExpr (GhcPass 'Renamed)
arg2) AppCtxt
_ [HsExprArg 'TcpRn]
args
= ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( (HsExpr (GhcPass 'Renamed)
op, HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
0 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l))
, AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg (HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
1 SrcSpan
generatedSrcSpan) LHsExpr (GhcPass 'Renamed)
arg1
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg (HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
2 SrcSpan
generatedSrcSpan) LHsExpr (GhcPass 'Renamed)
arg2
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsThingRn -> EWrap
EExpand (HsExpr (GhcPass 'Renamed) -> HsThingRn
OrigExpr HsExpr (GhcPass 'Renamed)
e))
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args )
go HsExpr (GhcPass 'Renamed)
e AppCtxt
ctxt [HsExprArg 'TcpRn]
args = ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((HsExpr (GhcPass 'Renamed)
e,AppCtxt
ctxt), [HsExprArg 'TcpRn]
args)
set :: EpAnn ann -> AppCtxt -> AppCtxt
set :: forall ann. EpAnn ann -> AppCtxt -> AppCtxt
set EpAnn ann
l (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)
set EpAnn ann
l (VAExpansion HsThingRn
orig SrcSpan
ol SrcSpan
_) = HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
orig SrcSpan
ol (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)
dec :: EpAnn ann -> AppCtxt -> AppCtxt
dec :: forall ann. EpAnn ann -> AppCtxt -> AppCtxt
dec EpAnn ann
l (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
f (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
-ThLevel
1) (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)
dec EpAnn ann
l (VAExpansion HsThingRn
orig SrcSpan
ol SrcSpan
_) = HsThingRn -> SrcSpan -> SrcSpan -> AppCtxt
VAExpansion HsThingRn
orig SrcSpan
ol (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)
rebuildHsApps :: (HsExpr GhcTc, AppCtxt)
-> [HsExprArg 'TcpTc]
-> HsExpr GhcTc
rebuildHsApps :: (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (HsExpr (GhcPass 'Typechecked)
fun, AppCtxt
_) [] = HsExpr (GhcPass 'Typechecked)
fun
rebuildHsApps (HsExpr (GhcPass 'Typechecked)
fun, AppCtxt
ctxt) (HsExprArg 'TcpTc
arg : [HsExprArg 'TcpTc]
args)
= case HsExprArg 'TcpTc
arg of
EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpTc))
arg, ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt' }
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XApp (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Typechecked)
NoExtField
noExtField LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lfun LHsExpr (GhcPass 'Typechecked)
LHsExpr (GhcPass (XPass 'TcpTc))
arg, AppCtxt
ctxt') [HsExprArg 'TcpTc]
args
ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, ea_ty_arg :: forall (p :: TcPass). HsExprArg p -> XETAType p
ea_ty_arg = XETAType 'TcpTc
ty, ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt' }
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XAppTypeE (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsWcType (NoGhcTc (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked)
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE (GhcPass 'Typechecked)
XETAType 'TcpTc
ty LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lfun LHsWcType (NoGhcTc (GhcPass 'Typechecked))
LHsWcType (GhcPass 'Renamed)
hs_ty, AppCtxt
ctxt') [HsExprArg 'TcpTc]
args
EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XPragE (GhcPass 'Typechecked)
-> HsPragE (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE (GhcPass 'Typechecked)
NoExtField
noExtField HsPragE (GhcPass 'Typechecked)
HsPragE (GhcPass (XPass 'TcpTc))
p LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lfun, AppCtxt
ctxt') [HsExprArg 'TcpTc]
args
EWrap (EPar AppCtxt
ctxt')
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (LHsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
gHsPar LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lfun, AppCtxt
ctxt') [HsExprArg 'TcpTc]
args
EWrap (EExpand HsThingRn
orig)
| OrigExpr HsExpr (GhcPass 'Renamed)
oe <- HsThingRn
orig
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (HsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkExpandedExprTc HsExpr (GhcPass 'Renamed)
oe HsExpr (GhcPass 'Typechecked)
fun, AppCtxt
ctxt) [HsExprArg 'TcpTc]
args
| Bool
otherwise
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (HsExpr (GhcPass 'Typechecked)
fun, AppCtxt
ctxt) [HsExprArg 'TcpTc]
args
EWrap (EHsWrap HsWrapper
wrap)
-> (HsExpr (GhcPass 'Typechecked), AppCtxt)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (HsWrapper
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrap HsWrapper
wrap HsExpr (GhcPass 'Typechecked)
fun, AppCtxt
ctxt) [HsExprArg 'TcpTc]
args
where
lfun :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lfun = SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ AppCtxt -> SrcSpan
appCtxtLoc' AppCtxt
ctxt) HsExpr (GhcPass 'Typechecked)
fun
appCtxtLoc' :: AppCtxt -> SrcSpan
appCtxtLoc' (VAExpansion HsThingRn
_ SrcSpan
_ SrcSpan
l) = SrcSpan
l
appCtxtLoc' AppCtxt
v = AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
v
isHsValArg :: HsExprArg id -> Bool
isHsValArg :: forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg (EValArg {}) = Bool
True
isHsValArg HsExprArg id
_ = Bool
False
leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr GhcRn]
leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [] = []
leadingValArgs (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpRn))
arg } : [HsExprArg 'TcpRn]
args) = LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (EWrap {} : [HsExprArg 'TcpRn]
args) = [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (EPrag {} : [HsExprArg 'TcpRn]
args) = [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (ETypeArg {} : [HsExprArg 'TcpRn]
_) = []
isValArg :: HsExprArg id -> Bool
isValArg :: forall (id :: TcPass). HsExprArg id -> Bool
isValArg (EValArg {}) = Bool
True
isValArg HsExprArg id
_ = Bool
False
isVisibleArg :: HsExprArg id -> Bool
isVisibleArg :: forall (id :: TcPass). HsExprArg id -> Bool
isVisibleArg (EValArg {}) = Bool
True
isVisibleArg (ETypeArg {}) = Bool
True
isVisibleArg HsExprArg id
_ = Bool
False
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr :: HsExprArg p -> SDoc
ppr (EPrag AppCtxt
_ HsPragE (GhcPass (XPass p))
p) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPrag" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsPragE (GhcPass (XPass p)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass (XPass p))
p
ppr (ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass 'Renamed)
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
hs_ty
ppr (EWrap EWrap
wrap) = EWrap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EWrap
wrap
ppr (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass p))
arg, ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (AppCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr AppCtxt
ctxt) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p))) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
arg
ppr (EValArgQL { eaql_tc_fun :: HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), AppCtxt)
eaql_tc_fun = (HsExpr (GhcPass 'Typechecked), AppCtxt)
fun, eaql_args :: HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args = [HsExprArg 'TcpInst]
args, eaql_res_rho :: HsExprArg 'TcpInst -> TcSigmaType
eaql_res_rho = TcSigmaType
ty})
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr (GhcPass 'Typechecked), AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Typechecked), AppCtxt)
fun)
ThLevel
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
args, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ea_ql_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty ])
pprArgInst :: HsExprArg 'TcpInst -> SDoc
pprArgInst :: HsExprArg 'TcpInst -> SDoc
pprArgInst (EPrag AppCtxt
_ HsPragE (GhcPass (XPass 'TcpInst))
p) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPrag" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsPragE (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpInst))
p
pprArgInst (ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass 'Renamed)
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
hs_ty
pprArgInst (EWrap EWrap
wrap) = EWrap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EWrap
wrap
pprArgInst (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpInst))
arg, ea_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
ea_arg_ty = XEVAType 'TcpInst
ty })
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass 'TcpInst))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg)
ThLevel
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Scaled TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcSigmaType
XEVAType 'TcpInst
ty)
pprArgInst (EValArgQL { eaql_tc_fun :: HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), AppCtxt)
eaql_tc_fun = (HsExpr (GhcPass 'Typechecked), AppCtxt)
fun, eaql_args :: HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args = [HsExprArg 'TcpInst]
args, eaql_res_rho :: HsExprArg 'TcpInst -> TcSigmaType
eaql_res_rho = TcSigmaType
ty})
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr (GhcPass 'Typechecked), AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Typechecked), AppCtxt)
fun)
ThLevel
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((HsExprArg 'TcpInst -> SDoc) -> [HsExprArg 'TcpInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map HsExprArg 'TcpInst -> SDoc
pprArgInst [HsExprArg 'TcpInst]
args), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ea_ql_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty ])
instance Outputable EWrap where
ppr :: EWrap -> SDoc
ppr (EPar AppCtxt
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPar"
ppr (EHsWrap HsWrapper
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EHsWrap" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
w
ppr (EExpand HsThingRn
orig) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EExpand" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsThingRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsThingRn
orig
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: (HsExpr (GhcPass 'Renamed), AppCtxt)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,AppCtxt
ctxt)
= AppCtxt
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
ctxt (TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun
; case mb_tc_fun of
Just (HsExpr (GhcPass 'Typechecked)
fun', TcSigmaType
fun_sigma) -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Typechecked)
fun', TcSigmaType
fun_sigma)
Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
Nothing -> (ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked)))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr (GhcPass 'Renamed)
-> ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked))
tcExpr HsExpr (GhcPass 'Renamed)
fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun
= case HsExpr (GhcPass 'Renamed)
fun of
HsVar XVar (GhcPass 'Renamed)
_ LIdP (GhcPass 'Renamed)
nm -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferId LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
nm
XExpr (HsRecSelRn FieldOcc (GhcPass 'Renamed)
f) -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferRecSelId FieldOcc (GhcPass 'Renamed)
f
ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
HsExpr (GhcPass 'Renamed)
_ -> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. Maybe a
Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt :: forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt (VAExpansion (OrigStmt (L SrcSpanAnnA
loc StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt)) SrcSpan
_ SrcSpan
_) TcM a
thing_inside =
do SrcSpanAnnA -> TcM a -> TcM a
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
ExprStmt (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt
TcM a
thing_inside
addHeadCtxt AppCtxt
fun_ctxt TcM a
thing_inside
| Bool -> Bool
not (SrcSpan -> Bool
isGoodSrcSpan SrcSpan
fun_loc)
= TcM a
thing_inside
| Bool
otherwise
= SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
fun_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
do case AppCtxt
fun_ctxt of
VAExpansion (OrigExpr HsExpr (GhcPass 'Renamed)
orig) SrcSpan
_ SrcSpan
_ -> HsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
orig TcM a
thing_inside
AppCtxt
_ -> TcM a
thing_inside
where
fun_loc :: SrcSpan
fun_loc = AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
fun_ctxt
tcInferRecSelId :: FieldOcc GhcRn
-> TcM ( (HsExpr GhcTc, TcSigmaType))
tcInferRecSelId :: FieldOcc (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferRecSelId (FieldOcc XCFieldOcc (GhcPass 'Renamed)
lbl (L SrcSpanAnnN
l Name
sel_name))
= do { sel_id <- TcM TcTyVar
tc_rec_sel_id
; let expr = XXExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XXExpr p -> HsExpr p
XExpr (FieldOcc (GhcPass 'Typechecked) -> XXExprGhcTc
HsRecSelTc (XCFieldOcc (GhcPass 'Typechecked)
-> LIdP (GhcPass 'Typechecked) -> FieldOcc (GhcPass 'Typechecked)
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc XCFieldOcc (GhcPass 'Renamed)
XCFieldOcc (GhcPass 'Typechecked)
lbl (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l TcTyVar
sel_id)))
; return $ (expr, idType sel_id)
}
where
occ :: OccName
occ :: OccName
occ = Name -> OccName
nameOccName Name
sel_name
tc_rec_sel_id :: TcM TcId
tc_rec_sel_id :: TcM TcTyVar
tc_rec_sel_id
= do { thing <- Name -> TcM TcTyThing
tcLookup Name
sel_name
; case thing of
ATcId { tct_id :: TcTyThing -> TcTyVar
tct_id = TcTyVar
id }
-> do { OccName -> TcTyVar -> TcM ()
check_naughty OccName
occ TcTyVar
id
; TcTyVar -> TcM ()
check_local_id TcTyVar
id
; TcTyVar -> TcM TcTyVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
id }
AGlobal (AnId TcTyVar
id)
-> do { OccName -> TcTyVar -> TcM ()
check_naughty OccName
occ TcTyVar
id
; TcTyVar -> TcM TcTyVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
id }
TcTyThing
_ -> TcRnMessage -> TcM TcTyVar
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TcTyVar) -> TcRnMessage -> TcM TcTyVar
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_ LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
ty) = HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Maybe
(HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
forall a. a -> Maybe a
Just LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
ty
obviousSig (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p) = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
p)
obviousSig (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p) = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
p)
obviousSig HsExpr (GhcPass 'Renamed)
_ = Maybe (LHsSigWcType (GhcPass 'Renamed))
Maybe
(HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
forall a. Maybe a
Nothing
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
ty0
= case HasDebugCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (TyCon
tc, [TcSigmaType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcSigmaType], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcSigmaType]
tys))
Maybe (TyCon, [TcSigmaType])
Nothing -> Maybe TyCon
forall a. Maybe a
Nothing
where
([TcTyVar]
_, [TcSigmaType]
_, TcSigmaType
ty) = TcSigmaType -> ([TcTyVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
ty0 = FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcSigmaType -> Maybe TyCon) -> Maybe TcSigmaType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpRhoType -> Maybe TcSigmaType
checkingExpType_maybe ExpRhoType
ty0
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType RecSelParent
p RdrName
rdr
= RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope RdrName
rdr (NotInScopeError -> TcRnMessage) -> NotInScopeError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> NotInScopeError
UnknownSubordinate (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field of type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p))
tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
expr LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
= do { sig_info <- TcM TcIdSig -> TcM TcIdSig
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSig -> TcM TcIdSig) -> TcM TcIdSig -> TcM TcIdSig
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSig
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty Maybe Name
forall a. Maybe a
Nothing
; (expr', poly_ty) <- tcExprSig expr sig_info
; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
where
loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (LHsSigWcType (GhcPass 'Renamed) -> LHsSigType (GhcPass 'Renamed)
forall (p :: Pass).
LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p)
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)
tcExprSig :: LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig :: LHsExpr (GhcPass 'Renamed)
-> TcIdSig -> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
tcExprSig LHsExpr (GhcPass 'Renamed)
expr (TcCompleteSig TcCompleteSig
sig)
= do { expr' <- LHsExpr (GhcPass 'Renamed)
-> TcCompleteSig -> TcM (LHsExpr (GhcPass 'Typechecked))
tcPolyLExprSig LHsExpr (GhcPass 'Renamed)
expr TcCompleteSig
sig
; return (expr', idType (sig_bndr sig)) }
tcExprSig LHsExpr (GhcPass 'Renamed)
expr sig :: TcIdSig
sig@(TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
name, psig_loc :: TcPartialSig -> SrcSpan
psig_loc = SrcSpan
loc }))
= SrcSpan
-> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (LHsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { (tclvl, wanted, (expr', sig_inst))
<- TcM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst)))
-> TcM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
do { sig_inst <- TcIdSig -> TcM TcIdSigInst
tcInstSig TcIdSig
sig
; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $
tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $
tcCheckPolyExprNC expr (sig_inst_tau sig_inst)
; return (expr', sig_inst) }
; let tau = TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst
infer_mode | [TcSigmaType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcSigmaType]
sig_inst_theta TcIdSigInst
sig_inst)
, Maybe TcSigmaType -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcSigmaType
sig_inst_wcx TcIdSigInst
sig_inst)
= InferMode
ApplyMR
| Bool
otherwise
= InferMode
NoRestrictions
; ((qtvs, givens, ev_binds, _), residual)
<- captureConstraints $
simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted
; emitConstraints residual
; tau <- liftZonkM $ zonkTcType tau
; let inferred_theta = (TcTyVar -> TcSigmaType) -> [TcTyVar] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> TcSigmaType
evVarPred [TcTyVar]
givens
tau_tvs = TcSigmaType -> TyCoVarSet
tyCoVarsOfType TcSigmaType
tau
; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta
tau_tvs qtvs (Just sig_inst)
; let inferred_sigma = [TcTyVar] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack =>
[TcTyVar] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [TcTyVar]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
my_sigma = [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack => [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
my_theta TcSigmaType
tau)
; wrap <- if inferred_sigma `eqType` my_sigma
then return idHsWrapper
else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma
; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
; let poly_wrap = HsWrapper
wrap
HsWrapper -> HsWrapper -> HsWrapper
<.> [TcTyVar] -> HsWrapper
mkWpTyLams [TcTyVar]
qtvs
HsWrapper -> HsWrapper -> HsWrapper
<.> [TcTyVar] -> HsWrapper
mkWpEvLams [TcTyVar]
givens
HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
ev_binds
; return (mkLHsWrap poly_wrap expr', my_sigma) }
tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit :: HsOverLit (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferOverLit lit :: HsOverLit (GhcPass 'Renamed)
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val
, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitRn { ol_rebindable :: OverLitRn -> Bool
ol_rebindable = Bool
rebindable
, ol_from_fun :: OverLitRn -> LIdP (GhcPass 'Renamed)
ol_from_fun = L SrcSpanAnnN
loc Name
from_name } })
=
do { hs_lit <- OverLitVal -> TcM (HsLit (GhcPass 'Typechecked))
mkOverLit OverLitVal
val
; from_id <- tcLookupId from_name
; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)
; let
thing = Name -> TypedThing
NameThing Name
from_name
mb_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just TypedThing
thing
herald = TypedThing -> HsExpr (GhcPass 'Typechecked) -> ExpectedFunTyOrigin
forall (p :: Pass).
Outputable (HsExpr (GhcPass p)) =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg TypedThing
thing (XLitE (GhcPass 'Typechecked)
-> HsLit (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Typechecked)
NoExtField
noExtField HsLit (GhcPass 'Typechecked)
hs_lit)
; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
; let lit_expr = SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) (HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ Coercion
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrapCo Coercion
co (HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$
XLitE (GhcPass 'Typechecked)
-> HsLit (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Typechecked)
NoExtField
noExtField HsLit (GhcPass 'Typechecked)
hs_lit
from_expr = HsWrapper
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1) (HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$
XVar (GhcPass 'Typechecked)
-> LIdP (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
from_id)
witness = XApp (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) HsExpr (GhcPass 'Typechecked)
from_expr) LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lit_expr
lit' = HsOverLit (GhcPass 'Renamed)
lit { ol_ext = OverLitTc { ol_rebindable = rebindable
, ol_witness = witness
, ol_type = res_ty } }
; return (HsOverLit noExtField lit', res_ty) }
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked))
tcCheckId Name
name ExpRhoType
res_ty
= do { (expr, actual_res_ty) <- GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferId (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name)
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addFunResCtxt expr [] actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
where
rn_fun :: HsExpr (GhcPass 'Renamed)
rn_fun = XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name)
tcInferId :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId :: GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferId lname :: GenLocated SrcSpanAnnN Name
lname@(L SrcSpanAnnN
_ Name
id_name)
| Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
= do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then tc_infer_id lname
else tc_infer_assert lname }
| Bool
otherwise
= do { (expr, ty) <- GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tc_infer_id GenLocated SrcSpanAnnN Name
lname
; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
; return (expr, ty) }
tc_infer_assert :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert :: GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tc_infer_assert (L SrcSpanAnnN
loc Name
assert_name)
= do { assert_error_id <- Name -> TcM TcTyVar
tcLookupId Name
assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
; return (mkHsWrap wrap (HsVar noExtField (L loc assert_error_id)), id_rho)
}
tc_infer_id :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: GenLocated SrcSpanAnnN Name
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tc_infer_id (L SrcSpanAnnN
loc Name
id_name)
= do { thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
; case thing of
ATcId { tct_id :: TcTyThing -> TcTyVar
tct_id = TcTyVar
id }
-> do { TcTyVar -> TcM ()
check_local_id TcTyVar
id
; TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
return_id TcTyVar
id }
AGlobal (AnId TcTyVar
id) -> TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
return_id TcTyVar
id
AGlobal (AConLike ConLike
cl) -> ConLike -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferConLike ConLike
cl
(TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> WhatLooking
-> Name -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. WhatLooking -> Name -> TcM a
failIllegalTyCon WhatLooking
WL_Anything (TyCon -> Name
tyConName TyCon
tc)
ATyVar Name
name TcTyVar
_ -> Name -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. Name -> TcM a
failIllegalTyVal Name
name
TcTyThing
_ -> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType))
-> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
where
return_id :: TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
return_id TcTyVar
id = (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar (GhcPass 'Typechecked)
-> LIdP (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
id), TcTyVar -> TcSigmaType
idType TcTyVar
id)
check_local_id :: Id -> TcM ()
check_local_id :: TcTyVar -> TcM ()
check_local_id TcTyVar
id
= do { TcTyVar -> TcM ()
checkThLocalId TcTyVar
id
; UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ TcTyVar -> UsageEnv
singleUsageUE TcTyVar
id }
check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> TcTyVar -> TcM ()
check_naughty OccName
lbl TcTyVar
id
| TcTyVar -> Bool
isNaughtyRecordSelector TcTyVar
id = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (OccName -> TcRnMessage
TcRnRecSelectorEscapedTyVar OccName
lbl)
| Bool
otherwise = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferConLike :: ConLike -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferConLike (RealDataCon DataCon
con) = DataCon -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferDataCon DataCon
con
tcInferConLike (PatSynCon PatSyn
ps) = PatSyn -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferPatSyn PatSyn
ps
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon :: DataCon -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferDataCon DataCon
con
= do { let tvbs :: [InvisTVBinder]
tvbs = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
con
tvs :: [TcTyVar]
tvs = [InvisTVBinder] -> [TcTyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvbs
theta :: [TcSigmaType]
theta = DataCon -> [TcSigmaType]
dataConOtherTheta DataCon
con
args :: [Scaled TcSigmaType]
args = DataCon -> [Scaled TcSigmaType]
dataConOrigArgTys DataCon
con
res :: TcSigmaType
res = DataCon -> TcSigmaType
dataConOrigResTy DataCon
con
stupid_theta :: [TcSigmaType]
stupid_theta = DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con
; scaled_arg_tys <- (Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType))
-> [Scaled TcSigmaType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled TcSigmaType]
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 Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
linear_to_poly [Scaled TcSigmaType]
args
; let full_theta = [TcSigmaType]
stupid_theta [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
theta
all_arg_tys = (TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType] -> [Scaled TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> Scaled TcSigmaType
forall a. a -> Scaled a
unrestricted [TcSigmaType]
full_theta [Scaled TcSigmaType]
-> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcSigmaType]
scaled_arg_tys
; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)
, mkInvisForAllTys tvbs $ mkPhiTy full_theta $
mkScaledFunTys scaled_arg_tys res ) }
where
linear_to_poly :: Scaled Type -> TcM (Scaled Type)
linear_to_poly :: Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
linear_to_poly (Scaled TcSigmaType
OneTy TcSigmaType
ty) = do { mul_var <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
; return (Scaled mul_var ty) }
linear_to_poly Scaled TcSigmaType
scaled_ty = Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Scaled TcSigmaType
scaled_ty
tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn :: PatSyn -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
tcInferPatSyn PatSyn
ps
= case PatSyn -> Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
patSynBuilderOcc PatSyn
ps of
Just (HsExpr (GhcPass 'Typechecked)
expr,TcSigmaType
ty) -> (HsExpr (GhcPass 'Typechecked), TcSigmaType)
-> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Typechecked)
expr,TcSigmaType
ty)
Maybe (HsExpr (GhcPass 'Typechecked), TcSigmaType)
Nothing -> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
nonBidirectionalErr (PatSyn -> Name
patSynName PatSyn
ps))
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = Name -> TcRnMessage
TcRnPatSynNotBidirectional
checkThLocalId :: Id -> TcM ()
checkThLocalId :: TcTyVar -> TcM ()
checkThLocalId TcTyVar
id
= do { mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel (TcTyVar -> Name
idName TcTyVar
id)
; case mb_local_use of
Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl, ThStage
use_stage)
| ThStage -> ThLevel
thLevel ThStage
use_stage ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
-> TopLevelFlag -> TcTyVar -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcTyVar
id ThStage
use_stage
Maybe (TopLevelFlag, ThLevel, ThStage)
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> TcTyVar -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcTyVar
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
= Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcM ()
keepAlive Name
id_name)
| Bool
otherwise
=
do { let id_ty :: TcSigmaType
id_ty = TcTyVar -> TcSigmaType
idType TcTyVar
id
; Bool -> TcRnMessage -> TcM ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$
THError -> TcRnMessage
TcRnTHError (THError -> TcRnMessage) -> THError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TypedTHError -> THError
TypedTHError (TypedTHError -> THError) -> TypedTHError -> THError
forall a b. (a -> b) -> a -> b
$ TcTyVar -> TypedTHError
SplicePolymorphicLocalVar TcTyVar
id
; lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
do { sid <- Name -> TcM TcTyVar
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
; return (HsVar noExtField (noLocA sid)) }
else
TcRef WantedConstraints
-> TcM (HsExpr (GhcPass 'Typechecked))
-> TcM (HsExpr (GhcPass 'Typechecked))
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var (TcM (HsExpr (GhcPass 'Typechecked))
-> TcM (HsExpr (GhcPass 'Typechecked)))
-> TcM (HsExpr (GhcPass 'Typechecked))
-> TcM (HsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> Name -> [TcSigmaType] -> TcM (HsExpr (GhcPass 'Typechecked))
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
Name
GHC.Builtin.Names.TH.liftName
[HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]
; addDetailedDiagnostic (TcRnImplicitLift $ idName id)
; ps <- readMutVar ps_var
; let pending_splice = Name -> LHsExpr (GhcPass 'Typechecked) -> PendingTcSplice
PendingTcSplice Name
id_name
(LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
mkLHsWrap (QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q) (HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr (GhcPass 'Typechecked)
lift))
(IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Typechecked)
TcTyVar
id))
; writeMutVar ps_var (pending_splice : ps)
; return () }
where
id_name :: Name
id_name = TcTyVar -> Name
idName TcTyVar
id
checkCrossStageLifting TopLevelFlag
_ TcTyVar
_ ThStage
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt :: forall (p :: TcPass) a.
HsExpr (GhcPass 'Typechecked)
-> [HsExprArg p] -> TcSigmaType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt HsExpr (GhcPass 'Typechecked)
fun [HsExprArg p]
args TcSigmaType
fun_res_ty ExpRhoType
env_ty TcM a
thing_inside
= do { env_tv <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
; dumping <- doptM Opt_D_dump_tc_trace
; addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc)) -> ZonkM SDoc -> ZonkM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> TcSigmaType -> ZonkM SDoc
mk_msg Bool
dumping TcSigmaType
env_tv) thing_inside }
where
mk_msg :: Bool -> TcSigmaType -> ZonkM SDoc
mk_msg Bool
dumping TcSigmaType
env_tv
= do { mb_env_ty <- ExpRhoType -> ZonkM (Maybe TcSigmaType)
forall (m :: * -> *).
MonadIO m =>
ExpRhoType -> m (Maybe TcSigmaType)
readExpType_maybe ExpRhoType
env_ty
; fun_res' <- zonkTcType fun_res_ty
; env' <- case mb_env_ty of
Just TcSigmaType
env_ty -> TcSigmaType -> ZonkM TcSigmaType
zonkTcType TcSigmaType
env_ty
Maybe TcSigmaType
Nothing -> do { Bool -> ZonkM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
dumping; TcSigmaType -> ZonkM TcSigmaType
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return TcSigmaType
env_tv }
; let
(_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
(_, _, env_tau) = tcSplitNestedSigmaTys env'
(args_fun, res_fun) = tcSplitFunTys fun_tau
(args_env, res_env) = tcSplitFunTys env_tau
n_fun = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_fun
n_env = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_env
info |
ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
n_env
, TcSigmaType -> Bool
not_fun TcSigmaType
res_env
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Typechecked) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Typechecked)
fun)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is applied to too few arguments"
|
ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ThLevel
n_env
, TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
, (ThLevel
n_fun ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ (HsExprArg p -> Bool) -> [HsExprArg p] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg p -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg p]
args) ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ThLevel
n_env
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Typechecked) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Typechecked)
fun)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is applied to too many arguments"
| Bool
otherwise
= SDoc
forall doc. IsOutput doc => doc
Outputable.empty
; return info }
not_fun :: TcSigmaType -> Bool
not_fun TcSigmaType
ty
= case HasDebugCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (TyCon
tc, [TcSigmaType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
Maybe (TyCon, [TcSigmaType])
Nothing -> Bool
False
addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
addStmtCtxt :: forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
stmt TcRn a
thing_inside
= do let err_doc :: SDoc
err_doc = HsStmtContextRn -> ExprStmt (GhcPass 'Renamed) -> SDoc
pprStmtInCtxt (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing)) ExprStmt (GhcPass 'Renamed)
stmt
SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_doc TcRn a
thing_inside
where
pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
pprStmtInCtxt :: HsStmtContextRn -> ExprStmt (GhcPass 'Renamed) -> SDoc
pprStmtInCtxt HsStmtContextRn
ctxt ExprStmt (GhcPass 'Renamed)
stmt
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In a stmt of"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsStmtContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. Outputable fn => HsStmtContext fn -> SDoc
pprAStmtContext HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) ThLevel
2 (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> SDoc
forall (idL :: Pass) (idR :: Pass) body.
(OutputableBndrId idL, OutputableBndrId idR,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,
Outputable body) =>
StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt)
]
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
e TcRn a
thing_inside
= case HsExpr (GhcPass 'Renamed)
e of
HsUnboundVar {} -> TcRn a
thing_inside
HsExpr (GhcPass 'Renamed)
_ -> SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr (GhcPass 'Renamed) -> SDoc
exprCtxt HsExpr (GhcPass 'Renamed)
e) TcRn a
thing_inside
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt :: HsExpr (GhcPass 'Renamed) -> SDoc
exprCtxt HsExpr (GhcPass 'Renamed)
expr = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the expression:") ThLevel
2 (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr (GhcPass 'Renamed)
expr))