{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Head
( HsExprArg(..), EValArg(..), TcPass(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, countLeadingValArgs, isVisibleArg, pprHsExprArgTc
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId
, obviousSig, addAmbiguousNameErr
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
, addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
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.Types.Basic
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( unitUE )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Zonk ( hsLitType )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Hs
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad
import Data.Function
import qualified Data.List.NonEmpty as NE
#include "HsVersions.h"
import GHC.Prelude
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 -> 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
text String
"VAExpansion" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e
ppr (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_) = String -> SDoc
text String
"VACall" SDoc -> SDoc -> SDoc
<+> ThLevel -> SDoc
int ThLevel
n SDoc -> SDoc -> 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 = forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass 'Renamed)
e, eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt
, eva_arg_ty :: XEVAType 'TcpRn
eva_arg_ty = NoExtField
noExtField }
mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType (GhcPass 'Renamed)
hs_ty = ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_hs_ty :: LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty
, eva_ty :: XETAType 'TcpRn
eva_ty = NoExtField
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 = forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsWrapper -> EWrap
EHsWrap HsWrapper
wrap) 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 :: ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun) = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n LHsExpr (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
top_lctxt ThLevel
n LHsExpr (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
top_lctxt (ThLevel
nforall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (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
top_lctxt (ThLevel
nforall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (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 SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n (L SrcSpanAnnA
_ 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)
_ (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) (forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (AppCtxt -> EWrap
EPar AppCtxt
ctxt) 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) (forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
ctxt HsPragE (GhcPass 'Renamed)
p 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]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty 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 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)) (forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand HsExpr (GhcPass 'Renamed)
orig) 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 (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
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
forall a. a -> [a] -> [a]
: forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand HsExpr (GhcPass 'Renamed)
e)
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 (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
nforall a. Num a => a -> a -> a
-ThLevel
1) (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
dec SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt
rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
fun AppCtxt
_ [] = HsExpr GhcTc
fun
rebuildHsApps 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
rebuildHsApps (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun 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_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
rebuildHsApps (forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XETAType 'TcpTc
ty GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun 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
rebuildHsApps (forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE NoExtField
noExtField HsPragE (GhcPass (XPass 'TcpTc))
p GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EPar AppCtxt
ctxt')
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EExpand HsExpr (GhcPass 'Renamed)
orig)
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
-> XXExprGhcTc
ExpansionExpr (forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr GhcTc
fun))) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
EWrap (EHsWrap HsWrapper
wrap)
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fun) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
where
lfun :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun = forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan forall a b. (a -> b) -> a -> b
$ AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) HsExpr GhcTc
fun
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 forall a. Num a => a -> a -> a
+ forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EWrap {} : [HsExprArg id]
args) = forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EPrag {} : [HsExprArg id]
args) = 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
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
text String
"EValArg" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr EValArg p
arg
ppr (EPrag AppCtxt
_ HsPragE (GhcPass (XPass p))
p) = String -> SDoc
text String
"EPrag" SDoc -> SDoc -> 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
char Char
'@' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass 'Renamed)
hs_ty
ppr (EWrap EWrap
wrap) = forall a. Outputable a => a -> SDoc
ppr EWrap
wrap
instance Outputable EWrap where
ppr :: EWrap -> SDoc
ppr (EPar AppCtxt
_) = String -> SDoc
text String
"EPar"
ppr (EHsWrap HsWrapper
w) = String -> SDoc
text String
"EHsWrap" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsWrapper
w
ppr (EExpand HsExpr (GhcPass 'Renamed)
orig) = String -> SDoc
text String
"EExpand" SDoc -> SDoc -> 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) = forall a. Outputable a => a -> SDoc
ppr LHsExpr (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
text String
"ValArgQL" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcTc, AppCtxt)
fun)
ThLevel
2 ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
args, String -> SDoc
text String
"va_ty:" SDoc -> SDoc -> 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
text String
"EValArg" SDoc -> SDoc -> SDoc
<+> SDoc -> ThLevel -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
tm) ThLevel
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr XEVAType 'TcpInst
ty)
pprHsExprArgTc HsExprArg 'TcpInst
arg = forall a. Outputable a => a -> SDoc
ppr HsExprArg 'TcpInst
arg
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: (HsExpr (GhcPass 'Renamed), AppCtxt)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) forall a b. (a -> b) -> a -> b
$
do { Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
; case Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun of
Just (HsExpr GhcTc
fun', TcSigmaType
fun_sigma) -> forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcSigmaType
fun_sigma)
Maybe (HsExpr GhcTc, TcSigmaType)
Nothing -> forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args forall a b. (a -> b) -> a -> b
$
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] -> Maybe TcRhoType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
= case HsExpr (GhcPass 'Renamed)
fun of
HsVar XVar (GhcPass 'Renamed)
_ (L SrcAnn NameAnn
_ Name
nm) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
nm
HsRecFld XRecFld (GhcPass 'Renamed)
_ AmbiguousFieldOcc (GhcPass 'Renamed)
f -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbiguousFieldOcc (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc (GhcPass 'Renamed)
f [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty -> forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just 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 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
HsSpliceE XSpliceE (GhcPass 'Renamed)
_ (HsSpliced XSpliced (GhcPass 'Renamed)
_ ThModFinalizers
_ (HsSplicedExpr HsExpr (GhcPass 'Renamed)
e))
-> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
e [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
HsExpr (GhcPass 'Renamed)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt :: forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args TcM a
thing_inside
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsExprArg 'TcpRn]
args = TcM a
thing_inside
| Bool
otherwise = forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
fun TcM a
thing_inside
tcInferRecSelId :: AmbiguousFieldOcc GhcRn
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: AmbiguousFieldOcc (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId (Unambiguous XUnambiguous (GhcPass 'Renamed)
sel_name LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
_args Maybe TcSigmaType
_mb_res_ty
= do { Id
sel_id <- LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl XUnambiguous (GhcPass 'Renamed)
sel_name
; let expr :: HsExpr GhcTc
expr = forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous Id
sel_id LocatedN RdrName
lbl)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Id -> TcSigmaType
idType Id
sel_id) }
tcInferRecSelId (Ambiguous XAmbiguous (GhcPass 'Renamed)
_ LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
= do { Name
sel_name <- LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcSigmaType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
; Id
sel_id <- LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl Name
sel_name
; let expr :: HsExpr GhcTc
expr = forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Ambiguous Id
sel_id LocatedN RdrName
lbl)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Id -> TcSigmaType
idType Id
sel_id) }
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl Name
sel_name
= do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
sel_name
; case TcTyThing
thing of
ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id }
-> do { OccName -> Id -> TcM ()
check_naughty OccName
occ Id
id
; Id -> TcM ()
check_local_id Id
id
; forall (m :: * -> *) a. Monad m => a -> m a
return Id
id }
AGlobal (AnId Id
id)
-> do { OccName -> Id -> TcM ()
check_naughty OccName
occ Id
id
; forall (m :: * -> *) a. Monad m => a -> m a
return Id
id }
TcTyThing
_ -> forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used where a value identifier was expected" }
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lbl)
tcInferAmbiguousRecSelId :: LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-> TcM Name
tcInferAmbiguousRecSelId :: LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcSigmaType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
| HsExprArg 'TcpRn
arg1 : [HsExprArg 'TcpRn]
_ <- forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: TcPass). HsExprArg id -> Bool
isVisibleArg) [HsExprArg 'TcpRn]
args
, EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg (L SrcSpanAnnA
_ HsExpr (GhcPass 'Renamed)
arg) } <- HsExprArg 'TcpRn
arg1
, Just LHsSigWcType (GhcPass 'Renamed)
sig_ty <- HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig HsExpr (GhcPass 'Renamed)
arg
= do { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType (GhcPass 'Renamed) -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType (GhcPass 'Renamed)
sig_ty
; LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl TcSigmaType
sig_tc_ty }
| Just TcSigmaType
res_ty <- Maybe TcSigmaType
mb_res_ty
, Just (Scaled TcSigmaType
arg_ty,TcSigmaType
_) <- TcSigmaType -> Maybe (Scaled TcSigmaType, TcSigmaType)
tcSplitFunTy_maybe TcSigmaType
res_ty
= LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl (forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg_ty)
| Bool
otherwise
= forall a. LocatedN RdrName -> TcM a
ambiguousSelector LocatedN RdrName
lbl
finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name
finish_ambiguous_selector :: LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector lr :: LocatedN RdrName
lr@(L SrcAnn NameAnn
_ RdrName
rdr) TcSigmaType
parent_type
= do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
parent_type of {
Maybe TyCon
Nothing -> forall a. LocatedN RdrName -> TcM a
ambiguousSelector LocatedN RdrName
lr ;
Just TyCon
p ->
do { [(RecSelParent, GlobalRdrElt)]
xs <- Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
True RdrName
rdr
; let parent :: RecSelParent
parent = TyCon -> RecSelParent
RecSelData TyCon
p
; case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
parent [(RecSelParent, GlobalRdrElt)]
xs of {
Maybe GlobalRdrElt
Nothing -> forall a. SDoc -> TcM a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) ;
Just GlobalRdrElt
gre ->
do { Bool -> GlobalRdrElt -> TcM ()
addUsedGRE Bool
True GlobalRdrElt
gre
; Name -> TcM ()
keepAlive (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
; WarningFlag -> Bool -> SDoc -> TcM ()
warnIfFlag WarningFlag
Opt_WarnAmbiguousFields Bool
True forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RdrName
rdr)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"belonging to type" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcSigmaType
parent_type
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
, String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
, if GlobalRdrElt -> Bool
isLocalGRE GlobalRdrElt
gre
then String -> SDoc
text String
"You can use explicit case analysis to resolve the ambiguity."
else String -> SDoc
text String
"You can use a qualified import or explicit case analysis to resolve the ambiguity."
]
; forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) } } } } }
ambiguousSelector :: LocatedN RdrName -> TcM a
ambiguousSelector :: forall a. LocatedN RdrName -> TcM a
ambiguousSelector (L SrcAnn NameAnn
_ RdrName
rdr)
= do { RdrName -> TcM ()
addAmbiguousNameErr RdrName
rdr
; forall env a. IOEnv env a
failM }
addAmbiguousNameErr :: RdrName -> TcM ()
addAmbiguousNameErr :: RdrName -> TcM ()
addAmbiguousNameErr RdrName
rdr
= do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
; case [GlobalRdrElt]
gres of
[] -> forall a. String -> a
panic String
"addAmbiguousNameErr: not found"
GlobalRdrElt
gre : [GlobalRdrElt]
gres -> forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] forall a b. (a -> b) -> a -> b
$ RdrName -> NonEmpty GlobalRdrElt -> TcM ()
addNameClashErrRn RdrName
rdr forall a b. (a -> b) -> a -> b
$ GlobalRdrElt
gre forall a. a -> [a] -> NonEmpty a
NE.:| [GlobalRdrElt]
gres}
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) = forall a. a -> Maybe a
Just LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
ty
obviousSig (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p) = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
p)
obviousSig (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p) = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
p)
obviousSig HsExpr (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])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (TyCon
tc, [TcSigmaType]
tys) -> forall a. a -> Maybe a
Just (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 -> forall a. Maybe a
Nothing
where
([Id]
_, [TcSigmaType]
_, TcSigmaType
ty) = TcSigmaType -> ([Id], [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 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 = forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isFieldSelectorGRE [GlobalRdrElt]
all_gres
| Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isRecFldGRE [GlobalRdrElt]
all_gres
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent [GlobalRdrElt]
gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent GlobalRdrElt
gre = do { Id
id <- Name -> TcM Id
tcLookupId (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
; case Id -> Maybe RecSelParent
recordSelectorTyCon_maybe Id
id of
Just RecSelParent
rstc -> forall (m :: * -> *) a. Monad m => a -> m a
return (RecSelParent
rstc, GlobalRdrElt
gre)
Maybe RecSelParent
Nothing -> forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
notSelector (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)) }
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p RdrName
rdr
= SDoc -> RdrName -> SDoc
unknownSubordinateErr (String -> SDoc
text String
"field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RecSelParent
p)) RdrName
rdr
notSelector :: Name -> SDoc
notSelector :: Name -> SDoc
notSelector Name
field
= [SDoc] -> SDoc
hsep [SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
field), String -> SDoc
text String
"is not a record selector"]
naughtyRecordSel :: OccName -> SDoc
naughtyRecordSel :: OccName -> SDoc
naughtyRecordSel OccName
lbl
= String -> SDoc
text String
"Cannot use record selector" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr OccName
lbl) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"as a function due to escaped type variables" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Probable fix: use pattern-matching syntax instead"
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 <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty forall a. Maybe a
Nothing
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) <- LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig LHsExpr (GhcPass 'Renamed)
expr TcIdSigInfo
sig_info
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty, TcSigmaType
poly_ty) }
where
loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig :: LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig LHsExpr (GhcPass 'Renamed)
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> Id
sig_bndr = Id
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { let poly_ty :: TcSigmaType
poly_ty = Id -> TcSigmaType
idType Id
poly_id
; (HsWrapper
wrap, GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- forall result.
UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ExprSigCtxt TcSigmaType
poly_ty 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) }
tcExprSig LHsExpr (GhcPass 'Renamed)
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tclvl, WantedConstraints
wanted, (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst))
<- forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints forall a b. (a -> b) -> a -> b
$
do { TcIdSigInst
sig_inst <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd forall tv argf. VarBndr tv argf -> tv
binderVar forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols TcIdSigInst
sig_inst) forall a b. (a -> b) -> a -> b
$
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, Id)]
sig_inst_wcs TcIdSigInst
sig_inst) 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)
; 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcSigmaType]
sig_inst_theta TcIdSigInst
sig_inst)
, forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcSigmaType
sig_inst_wcx TcIdSigInst
sig_inst)
= InferMode
ApplyMR
| Bool
otherwise
= InferMode
NoRestrictions
; ([Id]
qtvs, [Id]
givens, TcEvBinds
ev_binds, Bool
_)
<- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcSigmaType)]
-> WantedConstraints
-> TcM ([Id], [Id], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcSigmaType
tau)] WantedConstraints
wanted
; TcSigmaType
tau <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
tau
; let inferred_theta :: [TcSigmaType]
inferred_theta = forall a b. (a -> b) -> [a] -> [b]
map Id -> TcSigmaType
evVarPred [Id]
givens
tau_tvs :: TyCoVarSet
tau_tvs = TcSigmaType -> TyCoVarSet
tyCoVarsOfType TcSigmaType
tau
; ([InvisTVBinder]
binders, [TcSigmaType]
my_theta) <- [TcSigmaType]
-> TyCoVarSet
-> [Id]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [TcSigmaType])
chooseInferredQuantifiers [TcSigmaType]
inferred_theta
TyCoVarSet
tau_tvs [Id]
qtvs (forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
; let inferred_sigma :: TcSigmaType
inferred_sigma = [Id] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [Id]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
my_sigma :: TcSigmaType
my_sigma = [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
my_theta TcSigmaType
tau)
; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma
then forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else CtOrigin
-> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubTypeSigma CtOrigin
ExprSigOrigin UserTypeCtxt
ExprSigCtxt TcSigmaType
inferred_sigma TcSigmaType
my_sigma
; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" (forall a. Outputable a => a -> SDoc
ppr [Id]
qtvs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Id]
givens SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpTyLams [Id]
qtvs
HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpLams [Id]
givens
HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
ev_binds
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap 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_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsVar XVar (GhcPass 'Renamed)
_ (L SrcAnn NameAnn
loc Name
from_name)
, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit (GhcPass 'Renamed)
rebindable })
=
do { Id
from_id <- Name -> TcM Id
tcLookupId Name
from_name
; (HsWrapper
wrap1, TcSigmaType
from_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig (Id -> TcSigmaType
idType Id
from_id)
; (HsWrapper
wrap2, Scaled TcSigmaType
sarg_ty, TcSigmaType
res_ty) <- SDoc
-> Maybe SDoc
-> (ThLevel, [Scaled TcSigmaType])
-> TcSigmaType
-> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)
matchActualFunTySigma SDoc
herald Maybe SDoc
mb_doc
(ThLevel
1, []) TcSigmaType
from_ty
; HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
; Coercion
co <- Maybe SDoc -> TcSigmaType -> TcSigmaType -> TcM Coercion
unifyType Maybe SDoc
mb_doc (forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcTc
hs_lit) (forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
sarg_ty)
; let lit_expr :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr = forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
loc) forall a b. (a -> b) -> a -> b
$ Coercion -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo Coercion
co forall a b. (a -> b) -> a -> b
$
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit 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) forall a b. (a -> b) -> a -> b
$
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
loc Id
from_id)
lit' :: HsOverLit GhcTc
lit' = HsOverLit (GhcPass 'Renamed)
lit { ol_witness :: HsExpr GhcTc
ol_witness = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
loc) HsExpr GhcTc
from_expr) GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr
, ol_ext :: XOverLit GhcTc
ol_ext = Bool -> TcSigmaType -> OverLitTc
OverLitTc XOverLit (GhcPass 'Renamed)
rebindable TcSigmaType
res_ty }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit forall a. EpAnn a
noAnn HsOverLit GhcTc
lit', TcSigmaType
res_ty) }
where
orig :: CtOrigin
orig = HsOverLit (GhcPass 'Renamed) -> CtOrigin
LiteralOrigin HsOverLit (GhcPass 'Renamed)
lit
mb_doc :: Maybe SDoc
mb_doc = forall a. a -> Maybe a
Just (forall a. Outputable a => a -> SDoc
ppr Name
from_name)
herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
from_name)
, String -> SDoc
text String
"is applied to"]
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInferOverLit" (forall a. Outputable a => a -> SDoc
ppr HsOverLit (GhcPass 'Renamed)
lit)
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
vcat [forall a. Outputable a => a -> SDoc
ppr Name
name, forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty])
; 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 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 = forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
= do { DynFlags
dflags <- 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" (forall a. Outputable a => a -> SDoc
ppr Name
id_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
; 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 { Id
assert_error_id <- Name -> TcM Id
tcLookupId Name
assertErrorName
; (HsWrapper
wrap, TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
(Id -> TcSigmaType
idType Id
assert_error_id)
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Id
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
; GlobalRdrEnv
global_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; case TcTyThing
thing of
ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id }
-> do { Id -> TcM ()
check_local_id Id
id
; forall {p} {an} {m :: * -> *}.
(XVar p ~ NoExtField, XRec p (IdP p) ~ GenLocated (SrcAnn an) Id,
Monad m) =>
Id -> m (HsExpr p, TcSigmaType)
return_id Id
id }
AGlobal (AnId Id
id)
-> forall {p} {an} {m :: * -> *}.
(XVar p ~ NoExtField, XRec p (IdP p) ~ GenLocated (SrcAnn an) Id,
Monad m) =>
Id -> m (HsExpr p, TcSigmaType)
return_id Id
id
AGlobal (AConLike ConLike
cl) -> case ConLike
cl of
RealDataCon DataCon
con -> DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
PatSynCon PatSyn
ps
| Just (HsExpr GhcTc
expr, TcSigmaType
ty) <- PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc PatSyn
ps
-> forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcSigmaType
ty)
| Bool
otherwise
-> forall a. SDoc -> TcM a
failWithTc (forall a. Outputable a => a -> SDoc
nonBidirectionalErr Name
id_name)
AGlobal (ATyCon TyCon
ty_con)
-> forall {a}. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con
ATyVar Name
name Id
_
-> forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Illegal term-level use of the type variable"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name)
SDoc -> SDoc -> SDoc
$$ ThLevel -> SDoc -> SDoc
nest ThLevel
2 (String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
name))
ATcTyCon TyCon
ty_con
-> forall {a}. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con
TcTyThing
_ -> forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used where a value identifier was expected" }
where
fail_tycon :: GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con =
let pprov :: SDoc
pprov = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
global_env (TyCon -> Name
tyConName TyCon
ty_con) of
Just GlobalRdrElt
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
Maybe GlobalRdrElt
Nothing -> SDoc
empty
in forall a. SDoc -> TcM a
failWithTc (TyCon -> SDoc
term_level_tycons TyCon
ty_con SDoc -> SDoc -> SDoc
$$ SDoc
pprov)
term_level_tycons :: TyCon -> SDoc
term_level_tycons TyCon
ty_con
= String -> SDoc
text String
"Illegal term-level use of the type constructor"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
ty_con))
return_id :: Id -> m (HsExpr p, TcSigmaType)
return_id Id
id = forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Id
id), Id -> TcSigmaType
idType Id
id)
return_data_con :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
= do { let tvs :: [InvisTVBinder]
tvs = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
con
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
; [TcSigmaType]
mul_vars <- ThLevel -> TcSigmaType -> TcM [TcSigmaType]
newFlexiTyVarTys (forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args) TcSigmaType
multiplicityTy
; let scaleArgs :: [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args' = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"return_data_con" forall {a}. TcSigmaType -> Scaled a -> Scaled a
combine [TcSigmaType]
mul_vars [Scaled TcSigmaType]
args'
combine :: TcSigmaType -> Scaled a -> Scaled a
combine TcSigmaType
var (Scaled TcSigmaType
One a
ty) = forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
var a
ty
combine TcSigmaType
_ Scaled a
scaled_ty = Scaled a
scaled_ty
etaWrapper :: t (Scaled TcSigmaType) -> HsWrapper
etaWrapper t (Scaled TcSigmaType)
arg_tys = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Scaled TcSigmaType
scaled_ty HsWrapper
wr -> HsWrapper -> HsWrapper -> Scaled TcSigmaType -> SDoc -> HsWrapper
WpFun HsWrapper
WpHole HsWrapper
wr Scaled TcSigmaType
scaled_ty SDoc
empty) HsWrapper
WpHole t (Scaled TcSigmaType)
arg_tys
; let shouldInstantiate :: Bool
shouldInstantiate = (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con)) Bool -> Bool -> Bool
||
TcSigmaType -> Bool
isKindLevPoly (TyCon -> TcSigmaType
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con)))
; case Bool
shouldInstantiate of
Bool
True -> do { (TCvSubst
subst, [Id]
tvs') <- [Id] -> TcM (TCvSubst, [Id])
newMetaTyVars (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs)
; let tys' :: [TcSigmaType]
tys' = [Id] -> [TcSigmaType]
mkTyVarTys [Id]
tvs'
theta' :: [TcSigmaType]
theta' = HasCallStack => TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substTheta TCvSubst
subst [TcSigmaType]
theta
args' :: [Scaled TcSigmaType]
args' = HasCallStack =>
TCvSubst -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
substScaledTys TCvSubst
subst [Scaled TcSigmaType]
args
res' :: TcSigmaType
res' = HasCallStack => TCvSubst -> TcSigmaType -> TcSigmaType
substTy TCvSubst
subst TcSigmaType
res
; HsWrapper
wrap <- CtOrigin -> [TcSigmaType] -> [TcSigmaType] -> TcM HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcSigmaType]
tys' [TcSigmaType]
theta'
; let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args'
eta_wrap :: HsWrapper
eta_wrap = forall {t :: * -> *}.
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper [Scaled TcSigmaType]
scaled_arg_tys
; DataCon -> [TcSigmaType] -> TcM ()
addDataConStupidTheta DataCon
con [TcSigmaType]
tys'
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap)
(forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res')
}
Bool
False -> let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args
wrap1 :: HsWrapper
wrap1 = [TcSigmaType] -> HsWrapper
mkWpTyApps ([Id] -> [TcSigmaType]
mkTyVarTys forall a b. (a -> b) -> a -> b
$ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs)
eta_wrap :: HsWrapper
eta_wrap = forall {t :: * -> *}.
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Scaled a
unrestricted [TcSigmaType]
theta forall a. [a] -> [a] -> [a]
++ [Scaled TcSigmaType]
scaled_arg_tys)
wrap2 :: HsWrapper
wrap2 = [Id] -> HsWrapper
mkWpTyLams forall a b. (a -> b) -> a -> b
$ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs
in forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1)
(forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
tvs forall a b. (a -> b) -> a -> b
$ [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInvisFunTysMany [TcSigmaType]
theta forall a b. (a -> b) -> a -> b
$ [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res)
}
check_local_id :: Id -> TcM ()
check_local_id :: Id -> TcM ()
check_local_id Id
id
= do { Id -> TcM ()
checkThLocalId Id
id
; UsageEnv -> TcM ()
tcEmitBindingUsage forall a b. (a -> b) -> a -> b
$ forall n. NamedThing n => n -> TcSigmaType -> UsageEnv
unitUE (Id -> Name
idName Id
id) TcSigmaType
One }
check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> Id -> TcM ()
check_naughty OccName
lbl Id
id
| Id -> Bool
isNaughtyRecordSelector Id
id = forall a. SDoc -> TcM a
failWithTc (OccName -> SDoc
naughtyRecordSel OccName
lbl)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
nonBidirectionalErr :: Outputable name => name -> SDoc
nonBidirectionalErr :: forall a. Outputable a => a -> SDoc
nonBidirectionalErr name
name = String -> SDoc
text String
"non-bidirectional pattern synonym"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used in an expression"
checkThLocalId :: Id -> TcM ()
checkThLocalId :: Id -> TcM ()
checkThLocalId Id
id
= do { Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel (Id -> Name
idName Id
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 forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
-> TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Id
id ThStage
use_stage
Maybe (TopLevelFlag, ThLevel, ThStage)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Id
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
= 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 = Id -> TcSigmaType
idType Id
id
; Bool -> SDoc -> TcM ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (Id -> SDoc
polySpliceErr Id
id)
; HsExpr GhcTc
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
do { Id
sid <- Name -> TcM Id
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Id
sid)) }
else
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var 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
[HasDebugCallStack => TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]
; forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitLift forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcM ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitLift)
(String -> SDoc
text String
"The variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
id) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is implicitly lifted in the TH quotation")
; [PendingTcSplice]
ps <- 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
(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) (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
lift))
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Id
id))
; forall a env. IORef a -> a -> IOEnv env ()
writeMutVar TcRef [PendingTcSplice]
ps_var (PendingTcSplice
pending_splice forall a. a -> [a] -> [a]
: [PendingTcSplice]
ps)
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
id_name :: Name
id_name = Id -> Name
idName Id
id
checkCrossStageLifting TopLevelFlag
_ Id
_ ThStage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
polySpliceErr :: Id -> SDoc
polySpliceErr :: Id -> SDoc
polySpliceErr Id
id
= String -> SDoc
text String
"Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
id)
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
= forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv
env, ) 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 <- forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
; MASSERT( dumping )
; TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind }
; let
([Id]
_, [TcSigmaType]
_, TcSigmaType
fun_tau) = TcSigmaType -> ([Id], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
([Id]
_, [TcSigmaType]
_, TcSigmaType
env_tau) = TcSigmaType -> ([Id], [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 = forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_fun
n_env :: ThLevel
n_env = forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_env
info :: SDoc
info |
ThLevel
n_fun forall a. Ord a => a -> a -> Bool
> ThLevel
n_env
, TcSigmaType -> Bool
not_fun TcSigmaType
res_env
= String -> SDoc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too few arguments"
|
ThLevel
n_fun forall a. Ord a => a -> a -> Bool
< ThLevel
n_env
, TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
, (ThLevel
n_fun forall a. Num a => a -> a -> a
+ forall a. (a -> Bool) -> [a] -> ThLevel
count forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
args) forall a. Ord a => a -> a -> Bool
>= ThLevel
n_env
= String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too many arguments"
| Bool
otherwise
= SDoc
Outputable.empty
; 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])
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)
_ -> 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
text String
"In the expression:") ThLevel
2 (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr (GhcPass 'Renamed)
expr))