{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module GHC.Tc.Gen.Head
( HsExprArg(..), EValArg(..), TcPass(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, countLeadingValArgs, isVisibleArg, pprHsExprArgTc
, countVisAndInvisValArgs, countHsWrapperInvisArgs
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId
, obviousSig
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
, addHeadCtxt, addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Gen.HsType
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Unit.Module ( getModule )
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.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
import GHC.Hs.Syn.Type
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( unitUE )
import GHC.Core.PatSyn( PatSyn )
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.Var( isInvisibleFunArg )
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.Env
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Maybe
import Control.Monad
data TcPass = TcpRn
| TcpInst
| TcpTc
data HsExprArg (p :: TcPass)
=
EValArg { forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt :: AppCtxt
, forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg :: EValArg p
, forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty :: !(XEVAType p) }
| ETypeArg { eva_ctxt :: AppCtxt
, forall (p :: TcPass).
HsExprArg p -> LHsToken "@" (GhcPass 'Renamed)
eva_at :: !(LHsToken "@" GhcRn)
, forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_hs_ty :: LHsWcType GhcRn
, forall (p :: TcPass). HsExprArg p -> XETAType p
eva_ty :: !(XETAType p) }
| EPrag AppCtxt
(HsPragE (GhcPass (XPass p)))
| EWrap EWrap
data EWrap = EPar AppCtxt
| EExpand (HsExpr GhcRn)
| EHsWrap HsWrapper
data EValArg (p :: TcPass) where
ValArg :: LHsExpr (GhcPass (XPass p))
-> EValArg p
ValArgQL :: { EValArg 'TcpInst -> LHsExpr (GhcPass 'Renamed)
va_expr :: LHsExpr GhcRn
, EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun :: (HsExpr GhcTc, AppCtxt)
, EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args :: [HsExprArg 'TcpInst]
, EValArg 'TcpInst -> TcSigmaType
va_ty :: TcRhoType }
-> EValArg 'TcpInst
data AppCtxt
= VAExpansion
(HsExpr GhcRn)
SrcSpan
| VACall
(HsExpr GhcRn) Int
SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion HsExpr (GhcPass 'Renamed)
_ SrcSpan
l) = 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 AppCtxt where
ppr :: AppCtxt -> SDoc
ppr (VAExpansion HsExpr (GhcPass 'Renamed)
e SrcSpan
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VAExpansion" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e
ppr (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_) = 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
type family XPass p where
XPass 'TcpRn = 'Renamed
XPass 'TcpInst = 'Renamed
XPass 'TcpTc = 'Typechecked
type family XETAType p where
XETAType 'TcpRn = NoExtField
XETAType _ = Type
type family XEVAType p where
XEVAType 'TcpRn = NoExtField
XEVAType _ = Scaled Type
mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg :: AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
e = EValArg { eva_arg :: EValArg 'TcpRn
eva_arg = LHsExpr (GhcPass (XPass 'TcpRn)) -> EValArg 'TcpRn
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpRn))
e, eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt
, eva_arg_ty :: XEVAType 'TcpRn
eva_arg_ty = NoExtField
XEVAType 'TcpRn
noExtField }
mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt
-> LHsToken "@" (GhcPass 'Renamed)
-> LHsWcType (GhcPass 'Renamed)
-> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsToken "@" (GhcPass 'Renamed)
at LHsWcType (GhcPass 'Renamed)
hs_ty =
ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt
, eva_at :: LHsToken "@" (GhcPass 'Renamed)
eva_at = LHsToken "@" (GhcPass 'Renamed)
at, eva_hs_ty :: LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty
, eva_ty :: XETAType 'TcpRn
eva_ty = NoExtField
XETAType 'TcpRn
noExtField }
addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
args
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap = [HsExprArg 'TcpInst]
args
| Bool
otherwise = EWrap -> HsExprArg 'TcpInst
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsWrapper -> EWrap
EHsWrap HsWrapper
wrap) HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
args
splitHsApps :: HsExpr GhcRn
-> ( (HsExpr GhcRn, AppCtxt)
, [HsExprArg 'TcpRn])
splitHsApps :: HsExpr (GhcPass 'Renamed)
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
e = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((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)
_ LHsToken "(" (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsToken ")" (GhcPass 'Renamed)
_) = 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 LHsToken "@" (GhcPass 'Renamed)
_ 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 (HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr (GhcPass 'Renamed)
_)) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
orig 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]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go :: HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar (GhcPass 'Renamed)
_ LHsToken "(" (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsToken ")" (GhcPass 'Renamed)
_) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> 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]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> 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) LHsToken "@" (GhcPass 'Renamed)
at LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt
-> LHsToken "@" (GhcPass 'Renamed)
-> LHsWcType (GhcPass 'Renamed)
-> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsToken "@" (GhcPass 'Renamed)
at 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]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> 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 (XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr (GhcPass 'Renamed)
fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
= HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (HsExpr (GhcPass 'Renamed) -> SrcSpan -> AppCtxt
VAExpansion HsExpr (GhcPass 'Renamed)
orig (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt))
(EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand HsExpr (GhcPass 'Renamed)
orig) 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)
op, HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
0 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' 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 (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand 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)
e,AppCtxt
ctxt), [HsExprArg 'TcpRn]
args)
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
set SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt
dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
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) (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
dec SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt
rebuildHsApps :: HsExpr GhcTc
-> AppCtxt
-> [HsExprArg 'TcpTc]
-> TcRhoType
-> TcM (HsExpr GhcTc)
rebuildHsApps :: HsExpr GhcTc
-> AppCtxt
-> [HsExprArg 'TcpTc]
-> TcSigmaType
-> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
fun AppCtxt
ctxt [HsExprArg 'TcpTc]
args TcSigmaType
app_res_rho
= do { [HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
(() :: Constraint) =>
[HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
tcRemainingValArgs [HsExprArg 'TcpTc]
args TcSigmaType
app_res_rho HsExpr GhcTc
fun
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
ctxt [HsExprArg 'TcpTc]
args }
rebuild_hs_apps :: HsExpr GhcTc
-> AppCtxt
-> [HsExprArg 'TcpTc]
-> HsExpr GhcTc
rebuild_hs_apps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
_ [] = HsExpr GhcTc
fun
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
ctxt (HsExprArg 'TcpTc
arg : [HsExprArg 'TcpTc]
args)
= case HsExprArg 'TcpTc
arg of
EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg LHsExpr (GhcPass (XPass 'TcpTc))
arg, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt' }
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsExpr GhcTc
LHsExpr (GhcPass (XPass 'TcpTc))
arg) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
ETypeArg { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, eva_at :: forall (p :: TcPass).
HsExprArg p -> LHsToken "@" (GhcPass 'Renamed)
eva_at = LHsToken "@" (GhcPass 'Renamed)
at, eva_ty :: forall (p :: TcPass). HsExprArg p -> XETAType p
eva_ty = XETAType 'TcpTc
ty, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt' }
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XAppTypeE GhcTc
-> LHsExpr GhcTc
-> LHsToken "@" GhcTc
-> LHsWcType (NoGhcTc GhcTc)
-> HsExpr GhcTc
forall p.
XAppTypeE p
-> LHsExpr p -> LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XETAType 'TcpTc
ty LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsToken "@" (GhcPass 'Renamed)
LHsToken "@" GhcTc
at LHsWcType (NoGhcTc GhcTc)
LHsWcType (GhcPass 'Renamed)
hs_ty) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcTc
NoExtField
noExtField HsPragE GhcTc
HsPragE (GhcPass (XPass 'TcpTc))
p LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EPar AppCtxt
ctxt')
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (LHsExpr GhcTc -> HsExpr GhcTc
forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EExpand HsExpr (GhcPass 'Renamed)
orig)
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
-> XXExprGhcTc
ExpansionExpr (HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
forall orig expanded. orig -> expanded -> HsExpansion orig expanded
HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr GhcTc
fun))) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
EWrap (EHsWrap HsWrapper
wrap)
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fun) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
where
lfun :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) HsExpr GhcTc
fun
tcRemainingValArgs :: HasDebugCallStack
=> [HsExprArg 'TcpTc]
-> TcRhoType
-> HsExpr GhcTc
-> TcM ()
tcRemainingValArgs :: (() :: Constraint) =>
[HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
tcRemainingValArgs [HsExprArg 'TcpTc]
applied_args TcSigmaType
app_res_rho HsExpr GhcTc
fun = case HsExpr GhcTc
fun of
HsVar XVar GhcTc
_ (L SrcAnn NameAnn
_ Var
fun_id)
| Var -> Name
idName Var
fun_id Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeCoercePrimName
-> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args ThLevel
1 (Var -> RepPolyFun
RepPolyWiredIn Var
fun_id)
| Name -> Bool
isWiredInName (Var -> Name
idName Var
fun_id) Bool -> Bool -> Bool
&& Var -> Bool
hasNoBinding Var
fun_id
-> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args (Var -> ThLevel
idArity Var
fun_id) (Var -> RepPolyFun
RepPolyWiredIn Var
fun_id)
XExpr (ConLikeTc (RealDataCon DataCon
con) [Var]
_ [Scaled TcSigmaType]
_)
| DataCon -> Bool
isNewDataCon DataCon
con
Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
-> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args (DataCon -> ThLevel
dc_val_arity DataCon
con) (DataCon -> RepPolyFun
RepPolyDataCon DataCon
con)
HsExpr GhcTc
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dc_val_arity :: DataCon -> Arity
dc_val_arity :: DataCon -> ThLevel
dc_val_arity DataCon
con = (TcSigmaType -> Bool) -> [TcSigmaType] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count (Bool -> Bool
not (Bool -> Bool) -> (TcSigmaType -> Bool) -> TcSigmaType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigmaType -> Bool
isEqPrimPred) (DataCon -> [TcSigmaType]
dataConTheta DataCon
con)
ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length (DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con)
ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ DataCon -> ThLevel
dataConSourceArity DataCon
con
nb_applied_vis_val_args :: Int
nb_applied_vis_val_args :: ThLevel
nb_applied_vis_val_args = (HsExprArg 'TcpTc -> Bool) -> [HsExprArg 'TcpTc] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg 'TcpTc -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpTc]
applied_args
nb_applied_val_args :: Int
nb_applied_val_args :: ThLevel
nb_applied_val_args = [HsExprArg 'TcpTc] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg 'TcpTc]
applied_args
tc_remaining_args :: Arity -> RepPolyFun -> TcM ()
tc_remaining_args :: ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args ThLevel
arity RepPolyFun
rep_poly_fun =
ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args
(ThLevel
nb_applied_vis_val_args ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1)
(ThLevel
nb_applied_val_args ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1)
[(Scaled TcSigmaType, FunTyFlag)]
rem_arg_tys
where
rem_arg_tys :: [(Scaled Type, FunTyFlag)]
rem_arg_tys :: [(Scaled TcSigmaType, FunTyFlag)]
rem_arg_tys = TcSigmaType -> [(Scaled TcSigmaType, FunTyFlag)]
getRuntimeArgTys TcSigmaType
app_res_rho
tc_rem_args :: Int
-> Int
-> [(Scaled Type, FunTyFlag)]
-> TcM ()
tc_rem_args :: ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args ThLevel
_ ThLevel
i_val [(Scaled TcSigmaType, FunTyFlag)]
_
| ThLevel
i_val ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
arity
= () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tc_rem_args ThLevel
_ ThLevel
_ []
= String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcRemainingValArgs" SDoc
debug_msg
tc_rem_args ThLevel
i_visval !ThLevel
i_val ((Scaled TcSigmaType
_ TcSigmaType
arg_ty, FunTyFlag
af) : [(Scaled TcSigmaType, FunTyFlag)]
tys)
= do { let (ThLevel
i_visval', ArgPos
arg_pos)
| FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = ( ThLevel
i_visval , ArgPos
ArgPosInvis )
| Bool
otherwise = ( ThLevel
i_visval ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1, ThLevel -> ArgPos
ArgPosVis ThLevel
i_visval )
frr_ctxt :: FixedRuntimeRepContext
frr_ctxt = RepPolyFun -> ArgPos -> FixedRuntimeRepContext
FRRNoBindingResArg RepPolyFun
rep_poly_fun ArgPos
arg_pos
; (() :: Constraint) =>
FixedRuntimeRepContext -> TcSigmaType -> TcM ()
FixedRuntimeRepContext -> TcSigmaType -> TcM ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
frr_ctxt TcSigmaType
arg_ty
; ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args ThLevel
i_visval' (ThLevel
i_val ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1) [(Scaled TcSigmaType, FunTyFlag)]
tys }
debug_msg :: SDoc
debug_msg :: SDoc
debug_msg =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app_head =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arity =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
arity
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"applied_args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpTc]
applied_args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nb_applied_val_args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
nb_applied_val_args ]
isHsValArg :: HsExprArg id -> Bool
isHsValArg :: forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg (EValArg {}) = Bool
True
isHsValArg HsExprArg id
_ = Bool
False
countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs :: forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [] = ThLevel
0
countLeadingValArgs (EValArg {} : [HsExprArg id]
args) = ThLevel
1 ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EWrap {} : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EPrag {} : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (ETypeArg {} : [HsExprArg id]
_) = ThLevel
0
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
countVisAndInvisValArgs :: [HsExprArg id] -> Arity
countVisAndInvisValArgs :: forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [] = ThLevel
0
countVisAndInvisValArgs (EValArg {} : [HsExprArg id]
args) = ThLevel
1 ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (EWrap EWrap
wrap : [HsExprArg id]
args) =
case EWrap
wrap of { EHsWrap HsWrapper
hsWrap -> HsWrapper -> ThLevel
countHsWrapperInvisArgs HsWrapper
hsWrap ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
; EPar {} -> [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
; EExpand {} -> [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args }
countVisAndInvisValArgs (EPrag {} : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (ETypeArg {}: [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
countHsWrapperInvisArgs :: HsWrapper -> Arity
countHsWrapperInvisArgs :: HsWrapper -> ThLevel
countHsWrapperInvisArgs = HsWrapper -> ThLevel
forall {a}. Num a => HsWrapper -> a
go
where
go :: HsWrapper -> a
go HsWrapper
WpHole = a
0
go (WpCompose HsWrapper
wrap1 HsWrapper
wrap2) = HsWrapper -> a
go HsWrapper
wrap1 a -> a -> a
forall a. Num a => a -> a -> a
+ HsWrapper -> a
go HsWrapper
wrap2
go fun :: HsWrapper
fun@(WpFun {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
fun
go (WpCast {}) = a
0
go evLam :: HsWrapper
evLam@(WpEvLam {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
evLam
go (WpEvApp EvTerm
_) = a
1
go tyLam :: HsWrapper
tyLam@(WpTyLam {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
tyLam
go (WpTyApp TcSigmaType
_) = a
0
go (WpLet TcEvBinds
_) = a
0
go (WpMultCoercion {}) = a
0
nope :: a -> a
nope a
x = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countHsWrapperInvisApps" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr :: HsExprArg p -> SDoc
ppr (EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg p
arg }) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> EValArg p -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg p
arg
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 { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_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
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 HsExpr (GhcPass 'Renamed)
orig) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EExpand" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
orig
instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
ppr :: EValArg p -> SDoc
ppr (ValArg LHsExpr (GhcPass (XPass p))
e) = GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p))) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
e
ppr (ValArgQL { va_fun :: EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc, AppCtxt)
fun, va_args :: EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
args, va_ty :: EValArg 'TcpInst -> TcSigmaType
va_ty = TcSigmaType
ty})
= SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr GhcTc, AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcTc, 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
"va_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty ])
pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc (EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg 'TcpInst
tm, eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = XEVAType 'TcpInst
ty })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> ThLevel -> SDoc -> SDoc
hang (EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
tm) ThLevel
2 (SDoc
dcolon 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)
pprHsExprArgTc HsExprArg 'TcpInst
arg = HsExprArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExprArg 'TcpInst
arg
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: (HsExpr (GhcPass 'Renamed), AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args
= AppCtxt
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
ctxt (TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args
; case Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun of
Just (HsExpr GhcTc
fun', TcSigmaType
fun_sigma) -> (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcSigmaType
fun_sigma)
Maybe (HsExpr GhcTc, TcSigmaType)
Nothing -> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args
= case HsExpr (GhcPass 'Renamed)
fun of
HsVar XVar (GhcPass 'Renamed)
_ (L SrcAnn NameAnn
_ Name
nm) -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
nm
HsRecSel XRecSel (GhcPass 'Renamed)
_ FieldOcc (GhcPass 'Renamed)
f -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId FieldOcc (GhcPass 'Renamed)
f
ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
HsUntypedSplice (HsUntypedSpliceTop ThModFinalizers
_ HsExpr (GhcPass 'Renamed)
e) HsUntypedSplice (GhcPass 'Renamed)
_
-> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
e [HsExprArg 'TcpRn]
args
HsExpr (GhcPass 'Renamed)
_ -> Maybe (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr GhcTc, TcSigmaType)
forall a. Maybe a
Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt :: forall a. AppCtxt -> TcM a -> TcM a
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
$
case AppCtxt
fun_ctxt of
VAExpansion HsExpr (GhcPass 'Renamed)
orig 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
VACall {} -> 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 GhcTc, TcSigmaType)
tcInferRecSelId (FieldOcc XCFieldOcc (GhcPass 'Renamed)
sel_name XRec (GhcPass 'Renamed) RdrName
lbl)
= do { Var
sel_id <- TcM Var
tc_rec_sel_id
; let expr :: HsExpr GhcTc
expr = XRecSel GhcTc -> FieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecSel p -> FieldOcc p -> HsExpr p
HsRecSel XRecSel GhcTc
NoExtField
noExtField (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
Var
sel_id XRec (GhcPass 'Renamed) RdrName
XRec GhcTc RdrName
lbl)
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Var -> TcSigmaType
idType Var
sel_id)
}
where
occ :: OccName
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (GenLocated (SrcAnn NameAnn) RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Renamed) RdrName
GenLocated (SrcAnn NameAnn) RdrName
lbl)
tc_rec_sel_id :: TcM TcId
tc_rec_sel_id :: TcM Var
tc_rec_sel_id
= do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup XCFieldOcc (GhcPass 'Renamed)
Name
sel_name
; case TcTyThing
thing of
ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
id }
-> do { OccName -> Var -> TcM ()
check_naughty OccName
occ Var
id
; Var -> TcM ()
check_local_id Var
id
; Var -> TcM Var
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
id }
AGlobal (AnId Var
id)
-> do { OccName -> Var -> TcM ()
check_naughty OccName
occ Var
id
; Var -> TcM Var
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
id }
TcTyThing
_ -> TcRnMessage -> TcM Var
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM Var) -> TcRnMessage -> TcM Var
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)
_ LHsToken "(" (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p LHsToken ")" (GhcPass 'Renamed)
_) = 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 HasCallStack => 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
([Var]
_, [TcSigmaType]
_, TcSigmaType
ty) = TcSigmaType -> ([Var], [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
lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
is_selector RdrName
rdr
= do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let all_gres :: [GlobalRdrElt]
all_gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName' RdrName
rdr GlobalRdrEnv
env
; let gres :: [GlobalRdrElt]
gres | Bool
is_selector = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isFieldSelectorGRE [GlobalRdrElt]
all_gres
| Bool
otherwise = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isRecFldGRE [GlobalRdrElt]
all_gres
; (GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt))
-> [GlobalRdrElt] -> RnM [(RecSelParent, GlobalRdrElt)]
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 GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent [GlobalRdrElt]
gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent :: GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent GlobalRdrElt
gre = do { Var
id <- Name -> TcM Var
tcLookupId (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
; case Var -> Maybe RecSelParent
recordSelectorTyCon_maybe Var
id of
Just RecSelParent
rstc -> (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecSelParent
rstc, GlobalRdrElt
gre)
Maybe RecSelParent
Nothing -> TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
notSelector (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)) }
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))
notSelector :: Name -> TcRnMessage
notSelector :: Name -> TcRnMessage
notSelector = Name -> TcRnMessage
TcRnNotARecordSelector
tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
expr LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
= do { TcIdSigInfo
sig_info <- TcM TcIdSigInfo -> TcM TcIdSigInfo
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSigInfo -> TcM TcIdSigInfo)
-> TcM TcIdSigInfo -> TcM TcIdSigInfo
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty Maybe Name
forall a. Maybe a
Nothing
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) <- UserTypeCtxt
-> LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo
-> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig UserTypeCtxt
ctxt LHsExpr (GhcPass 'Renamed)
expr TcIdSigInfo
sig_info
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExprWithTySig GhcTc
-> LHsExpr GhcTc -> LHsSigWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcTc
NoExtField
noExtField LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcSigmaType
poly_ty) }
where
loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LHsSigWcType (GhcPass 'Renamed) -> LHsSigType (GhcPass 'Renamed)
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)
ctxt :: UserTypeCtxt
ctxt = ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt (LHsSigWcType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)
tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig :: UserTypeCtxt
-> LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo
-> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig UserTypeCtxt
ctxt LHsExpr (GhcPass 'Renamed)
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> Var
sig_bndr = Var
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { let poly_ty :: TcSigmaType
poly_ty = Var -> TcSigmaType
idType Var
poly_id
; (HsWrapper
wrap, GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall result.
UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ctxt TcSigmaType
poly_ty ((TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ \TcSigmaType
rho_ty ->
LHsExpr (GhcPass 'Renamed) -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr (GhcPass 'Renamed)
expr TcSigmaType
rho_ty
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) }
tcExprSig UserTypeCtxt
_ LHsExpr (GhcPass 'Renamed)
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tclvl, WantedConstraints
wanted, (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst))
<- TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM
(TcLevel, WantedConstraints,
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
do { TcIdSigInst
sig_inst <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- [(Name, Var)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ((InvisTVBinder -> Var) -> [(Name, InvisTVBinder)] -> [(Name, Var)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd InvisTVBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar ([(Name, InvisTVBinder)] -> [(Name, Var)])
-> [(Name, InvisTVBinder)] -> [(Name, Var)]
forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols TcIdSigInst
sig_inst) (TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
[(Name, Var)] -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, Var)]
sig_inst_wcs TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Renamed) -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr (GhcPass 'Renamed)
expr (TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst)
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst) }
; let tau :: TcSigmaType
tau = TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst
infer_mode :: InferMode
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
; (([Var]
qtvs, [Var]
givens, TcEvBinds
ev_binds, Bool
_), WantedConstraints
residual)
<- TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints))
-> TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcSigmaType)]
-> WantedConstraints
-> TcM ([Var], [Var], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcSigmaType
tau)] WantedConstraints
wanted
; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
residual
; TcSigmaType
tau <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
tau
; let inferred_theta :: [TcSigmaType]
inferred_theta = (Var -> TcSigmaType) -> [Var] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Var -> TcSigmaType
evVarPred [Var]
givens
tau_tvs :: TyCoVarSet
tau_tvs = TcSigmaType -> TyCoVarSet
tyCoVarsOfType TcSigmaType
tau
; ([InvisTVBinder]
binders, [TcSigmaType]
my_theta) <- WantedConstraints
-> [TcSigmaType]
-> TyCoVarSet
-> [Var]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [TcSigmaType])
chooseInferredQuantifiers WantedConstraints
residual [TcSigmaType]
inferred_theta
TyCoVarSet
tau_tvs [Var]
qtvs (TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
; let inferred_sigma :: TcSigmaType
inferred_sigma = [Var] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
(() :: Constraint) =>
[Var] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [Var]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
my_sigma :: TcSigmaType
my_sigma = [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
(() :: Constraint) => [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
my_theta TcSigmaType
tau)
; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma
then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else CtOrigin
-> UserTypeCtxt
-> TcSigmaType
-> TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma CtOrigin
ExprSigOrigin (ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt ReportRedundantConstraints
NoRRC) TcSigmaType
inferred_sigma TcSigmaType
my_sigma
; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
qtvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
givens SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpTyLams [Var]
qtvs
HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpEvLams [Var]
givens
HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
ev_binds
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
my_sigma) }
tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit :: HsOverLit (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, 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 { $sel:ol_rebindable:OverLitRn :: OverLitRn -> Bool
ol_rebindable = Bool
rebindable
, $sel:ol_from_fun:OverLitRn :: OverLitRn -> LIdP (GhcPass 'Renamed)
ol_from_fun = L SrcAnn NameAnn
loc Name
from_name } })
=
do { HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
; Var
from_id <- Name -> TcM Var
tcLookupId Name
from_name
; (HsWrapper
wrap1, TcSigmaType
from_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (HsOverLit (GhcPass 'Renamed) -> CtOrigin
LiteralOrigin HsOverLit (GhcPass 'Renamed)
lit) (Var -> TcSigmaType
idType Var
from_id)
; let
thing :: TypedThing
thing = Name -> TypedThing
NameThing Name
from_name
mb_thing :: Maybe TypedThing
mb_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just TypedThing
thing
herald :: ExpectedFunTyOrigin
herald = TypedThing -> HsExpr GhcTc -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg TypedThing
thing (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit)
; (HsWrapper
wrap2, Scaled TcSigmaType
sarg_ty, TcSigmaType
res_ty) <- ExpectedFunTyOrigin
-> Maybe TypedThing
-> (ThLevel, [Scaled TcSigmaType])
-> TcSigmaType
-> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)
matchActualFunTySigma ExpectedFunTyOrigin
herald Maybe TypedThing
mb_thing
(ThLevel
1, []) TcSigmaType
from_ty
; Coercion
co <- Maybe TypedThing -> TcSigmaType -> TcSigmaType -> TcM Coercion
unifyType Maybe TypedThing
mb_thing (HsLit GhcTc -> TcSigmaType
forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcTc
hs_lit) (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
sarg_ty)
; let lit_expr :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NameAnn -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
loc) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ Coercion -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo Coercion
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit
from_expr :: HsExpr GhcTc
from_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1) (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (SrcAnn NameAnn -> Var -> GenLocated (SrcAnn NameAnn) Var
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
loc Var
from_id)
witness :: HsExpr GhcTc
witness = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NameAnn -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
loc) HsExpr GhcTc
from_expr) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr
lit' :: HsOverLit GhcTc
lit' = HsOverLit (GhcPass 'Renamed)
lit { ol_ext = OverLitTc { ol_rebindable = rebindable
, ol_witness = witness
, ol_type = res_ty } }
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsOverLit GhcTc
lit', TcSigmaType
res_ty) }
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpRhoType
res_ty
= do { (HsExpr GhcTc
expr, TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
name
; String -> SDoc -> TcM ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty])
; HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
rn_fun [] TcSigmaType
actual_res_ty ExpRhoType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) HsExpr (GhcPass 'Renamed)
rn_fun HsExpr GhcTc
expr TcSigmaType
actual_res_ty ExpRhoType
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 (SrcAnn NameAnn) Name
forall a an. a -> LocatedAn an a
noLocA Name
name)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
id_name
| Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreAsserts DynFlags
dflags
then Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
else Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
id_name }
| Bool
otherwise
= do { (HsExpr GhcTc
expr, TcSigmaType
ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
; String -> SDoc -> TcM ()
traceTc String
"tcInferId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
id_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcSigmaType
ty) }
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
assert_name
= do { Var
assert_error_id <- Name -> TcM Var
tcLookupId Name
assertErrorName
; (HsWrapper
wrap, TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
(Var -> TcSigmaType
idType Var
assert_error_id)
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Var -> GenLocated (SrcAnn NameAnn) Var
forall a an. a -> LocatedAn an a
noLocA Var
assert_error_id)), TcSigmaType
id_rho)
}
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
= do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
; case TcTyThing
thing of
ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
id }
-> do { Var -> TcM ()
check_local_id Var
id
; Var -> TcM (HsExpr GhcTc, TcSigmaType)
forall {p} {an} {m :: * -> *}.
(IdP p ~ Var, XVar p ~ NoExtField,
XRec p Var ~ GenLocated (SrcAnn an) Var, Monad m) =>
Var -> m (HsExpr p, TcSigmaType)
return_id Var
id }
AGlobal (AnId Var
id) -> Var -> TcM (HsExpr GhcTc, TcSigmaType)
forall {p} {an} {m :: * -> *}.
(IdP p ~ Var, XVar p ~ NoExtField,
XRec p Var ~ GenLocated (SrcAnn an) Var, Monad m) =>
Var -> m (HsExpr p, TcSigmaType)
return_id Var
id
AGlobal (AConLike (RealDataCon DataCon
con)) -> DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon DataCon
con
AGlobal (AConLike (PatSynCon PatSyn
ps)) -> Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn Name
id_name PatSyn
ps
(TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tycon TyCon
tc
ATyVar Name
name Var
_ -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tyvar Name
name
TcTyThing
_ -> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
where
fail_tycon :: TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tycon TyCon
tc = do
GlobalRdrEnv
gre <- TcRn GlobalRdrEnv
getGlobalRdrEnv
let nm :: Name
nm = TyCon -> Name
tyConName TyCon
tc
pprov :: SDoc
pprov = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
gre Name
nm of
Just GlobalRdrElt
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
Maybe GlobalRdrElt
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
dataName Name
nm SDoc
pprov
fail_tyvar :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tyvar Name
nm =
let pprov :: SDoc
pprov = ThLevel -> SDoc -> SDoc
nest ThLevel
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bound at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
nm))
in NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
varName Name
nm SDoc
pprov
fail_with_msg :: NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
whatName Name
nm SDoc
pprov = do
([ImportError]
import_errs, [GhcHint]
hints) <- NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
whatName
UnitState
unit_state <- (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
let
hint_msg :: SDoc
hint_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
hints
import_err_msg :: SDoc
import_err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
import_errs
info :: ErrInfo
info = ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
hint_msg }
TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state (
ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
info (Name -> Bool -> TcRnMessage
TcRnIncorrectNameSpace Name
nm Bool
False))
get_suggestions :: NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
ns = do
let occ :: OccName
occ = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
ns (OccName -> FastString
occNameFS (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
id_name))
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
LocalRdrEnv
lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
ImportAvails
imp_info <- TcRn ImportAvails
getImports
Module
curr_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
HomePackageTable
hpt <- TcRnIf TcGblEnv TcLclEnv HomePackageTable
forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt
([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint]))
-> ([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall a b. (a -> b) -> a -> b
$ WhatLooking
-> DynFlags
-> HomePackageTable
-> Module
-> GlobalRdrEnv
-> LocalRdrEnv
-> ImportAvails
-> RdrName
-> ([ImportError], [GhcHint])
unknownNameSuggestions WhatLooking
WL_Anything DynFlags
dflags HomePackageTable
hpt Module
curr_mod GlobalRdrEnv
rdr_env
LocalRdrEnv
lcl_env ImportAvails
imp_info (OccName -> RdrName
mkRdrUnqual OccName
occ)
return_id :: Var -> m (HsExpr p, TcSigmaType)
return_id Var
id = (HsExpr p, TcSigmaType) -> m (HsExpr p, TcSigmaType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> LIdP p -> HsExpr p
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar p
NoExtField
noExtField (Var -> GenLocated (SrcAnn an) Var
forall a an. a -> LocatedAn an a
noLocA Var
id), Var -> TcSigmaType
idType Var
id)
check_local_id :: Id -> TcM ()
check_local_id :: Var -> TcM ()
check_local_id Var
id
= do { Var -> TcM ()
checkThLocalId Var
id
; UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ Name -> TcSigmaType -> UsageEnv
forall n. NamedThing n => n -> TcSigmaType -> UsageEnv
unitUE (Var -> Name
idName Var
id) TcSigmaType
OneTy }
check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> Var -> TcM ()
check_naughty OccName
lbl Var
id
| Var -> Bool
isNaughtyRecordSelector Var
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 ()
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon DataCon
con
= do { let tvbs :: [InvisTVBinder]
tvbs = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
con
tvs :: [Var]
tvs = [InvisTVBinder] -> [Var]
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 TcSigmaType]
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]
full_theta = [TcSigmaType]
stupid_theta [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
theta
all_arg_tys :: [Scaled TcSigmaType]
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
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (ConLike -> [Var] -> [Scaled TcSigmaType] -> XXExprGhcTc
ConLikeTc (DataCon -> ConLike
RealDataCon DataCon
con) [Var]
tvs [Scaled TcSigmaType]
all_arg_tys)
, [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
tvbs (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [TcSigmaType] -> TcSigmaType -> TcSigmaType
(() :: Constraint) => [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
full_theta (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
[Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
(() :: Constraint) =>
[Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkScaledFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
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 { TcSigmaType
mul_var <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
; 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 (TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mul_var TcSigmaType
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 :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn Name
id_name PatSyn
ps
= case PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc PatSyn
ps of
Just (HsExpr GhcTc
expr,TcSigmaType
ty) -> (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr,TcSigmaType
ty)
Maybe (HsExpr GhcTc, TcSigmaType)
Nothing -> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
nonBidirectionalErr Name
id_name)
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = Name -> TcRnMessage
TcRnPatSynNotBidirectional
checkThLocalId :: Id -> TcM ()
checkThLocalId :: Var -> TcM ()
checkThLocalId Var
id
= do { Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel (Var -> Name
idName Var
id)
; case Maybe (TopLevelFlag, ThLevel, ThStage)
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 -> Var -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Var
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 -> Var -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Var
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 = Var -> TcSigmaType
idType Var
id
; Bool -> TcRnMessage -> TcM ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (Var -> TcRnMessage
TcRnSplicePolymorphicLocalVar Var
id)
; HsExpr GhcTc
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
do { Var
sid <- Name -> TcM Var
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Var -> GenLocated (SrcAnn NameAnn) Var
forall a an. a -> LocatedAn an a
noLocA Var
sid)) }
else
TcRef WantedConstraints -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
Name
GHC.Builtin.Names.TH.liftName
[(() :: Constraint) => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]
; (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic (Name -> ErrInfo -> TcRnMessage
TcRnImplicitLift (Name -> ErrInfo -> TcRnMessage) -> Name -> ErrInfo -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ Var -> Name
idName Var
id)
; [PendingTcSplice]
ps <- TcRef [PendingTcSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingTcSplice]
forall a env. IORef a -> IOEnv env a
readMutVar TcRef [PendingTcSplice]
ps_var
; let pending_splice :: PendingTcSplice
pending_splice = Name -> LHsExpr GhcTc -> PendingTcSplice
PendingTcSplice Name
id_name
(LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
lift))
(IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
id))
; TcRef [PendingTcSplice] -> [PendingTcSplice] -> TcM ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar TcRef [PendingTcSplice]
ps_var (PendingTcSplice
pending_splice PendingTcSplice -> [PendingTcSplice] -> [PendingTcSplice]
forall a. a -> [a] -> [a]
: [PendingTcSplice]
ps)
; () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
id_name :: Name
id_name = Var -> Name
idName Var
id
checkCrossStageLifting TopLevelFlag
_ Var
_ ThStage
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt :: forall a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args TcSigmaType
fun_res_ty ExpRhoType
env_ty TcM a
thing_inside
= (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) SDoc -> TcM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg) TcM a
thing_inside
where
mk_msg :: IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg
= do { Maybe TcSigmaType
mb_env_ty <- ExpRhoType -> TcM (Maybe TcSigmaType)
readExpType_maybe ExpRhoType
env_ty
; TcSigmaType
fun_res' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
; TcSigmaType
env' <- case Maybe TcSigmaType
mb_env_ty of
Just TcSigmaType
env_ty -> TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
env_ty
Maybe TcSigmaType
Nothing ->
do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
; Bool -> TcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
dumping
; TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind }
; let
([Var]
_, [TcSigmaType]
_, TcSigmaType
fun_tau) = TcSigmaType -> ([Var], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
([Var]
_, [TcSigmaType]
_, TcSigmaType
env_tau) = TcSigmaType -> ([Var], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
env'
([Scaled TcSigmaType]
args_fun, TcSigmaType
res_fun) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
([Scaled TcSigmaType]
args_env, TcSigmaType
res_env) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
n_fun :: ThLevel
n_fun = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_fun
n_env :: ThLevel
n_env = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_env
info :: SDoc
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 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
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 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
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 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
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
; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
not_fun :: TcSigmaType -> Bool
not_fun TcSigmaType
ty
= case HasCallStack => 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
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))