{-# 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 "GhclibHsVersions.h"
import GHC.Prelude
data TcPass = TcpRn
| TcpInst
| TcpTc
data HsExprArg (p :: TcPass)
=
EValArg { HsExprArg p -> AppCtxt
eva_ctxt :: AppCtxt
, HsExprArg p -> EValArg p
eva_arg :: EValArg p
, HsExprArg p -> XEVAType p
eva_arg_ty :: !(XEVAType p) }
| ETypeArg { eva_ctxt :: AppCtxt
, HsExprArg p -> LHsWcType GhcRn
eva_hs_ty :: LHsWcType GhcRn
, 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 GhcRn
va_expr :: LHsExpr GhcRn
, EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun :: (HsExpr GhcTc, AppCtxt)
, EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args :: [HsExprArg 'TcpInst]
, EValArg 'TcpInst -> TcRhoType
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 GhcRn
_ SrcSpan
l) = SrcSpan
l
appCtxtLoc (VACall HsExpr GhcRn
_ Int
_ 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 GhcRn
e SrcSpan
_) = String -> SDoc
text String
"VAExpansion" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e
ppr (VACall HsExpr GhcRn
f Int
n SrcSpan
_) = String -> SDoc
text String
"VACall" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
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 GhcRn -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr GhcRn
e = EValArg :: forall (p :: TcPass).
AppCtxt -> EValArg p -> XEVAType p -> HsExprArg p
EValArg { eva_arg :: EValArg 'TcpRn
eva_arg = LHsExpr (GhcPass (XPass 'TcpRn)) -> EValArg 'TcpRn
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr GhcRn
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 -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType GhcRn
hs_ty = ETypeArg :: forall (p :: TcPass).
AppCtxt -> LHsWcType GhcRn -> XETAType p -> HsExprArg p
ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_hs_ty :: LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
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 GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
e = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
e (Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
0 HsExpr GhcRn
e) []
where
top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
n (HsPar XPar GhcRn
_ LHsExpr GhcRn
fun) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
fun
top_ctxt Int
n (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
fun) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
fun
top_ctxt Int
n (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
fun LHsWcType (NoGhcTc GhcRn)
_) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
fun
top_ctxt Int
n (HsApp XApp GhcRn
_ LHsExpr GhcRn
fun LHsExpr GhcRn
_) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
fun
top_ctxt Int
n (XExpr (HsExpanded orig _)) = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
orig Int
n SrcSpan
noSrcSpan
top_ctxt Int
n HsExpr GhcRn
other_fun = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
other_fun Int
n SrcSpan
noSrcSpan
top_lctxt :: Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n (L SrcSpanAnnA
_ HsExpr GhcRn
fun) = Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
n HsExpr GhcRn
fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go :: HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar GhcRn
_ (L l fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
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 GhcRn
_ HsPragE GhcRn
p (L l fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
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 GhcRn
HsPragE (GhcPass (XPass 'TcpRn))
p HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (HsAppType XAppTypeE GhcRn
_ (L l fun) LHsWcType (NoGhcTc GhcRn)
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType GhcRn
LHsWcType (NoGhcTc GhcRn)
ty HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (HsApp XApp GhcRn
_ (L l fun) LHsExpr GhcRn
arg) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr GhcRn
arg HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go (XExpr (HsExpanded orig fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
= HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (HsExpr GhcRn -> SrcSpan -> AppCtxt
VAExpansion HsExpr GhcRn
orig (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt)) (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr GhcRn -> EWrap
EExpand HsExpr GhcRn
orig) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
go e :: HsExpr GhcRn
e@(OpApp XOpApp GhcRn
_ LHsExpr GhcRn
arg1 (L l op) LHsExpr GhcRn
arg2) AppCtxt
_ [HsExprArg 'TcpRn]
args
= ( (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l))
, AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg (HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
1 SrcSpan
generatedSrcSpan) LHsExpr GhcRn
arg1
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg (HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
2 SrcSpan
generatedSrcSpan) LHsExpr GhcRn
arg2
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr GhcRn -> EWrap
EExpand HsExpr GhcRn
e)
HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args )
go HsExpr GhcRn
e AppCtxt
ctxt [HsExprArg 'TcpRn]
args = ((HsExpr GhcRn
e,AppCtxt
ctxt), [HsExprArg 'TcpRn]
args)
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l (VACall HsExpr GhcRn
f Int
n SrcSpan
_) = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
f Int
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 GhcRn
f Int
n SrcSpan
_) = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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]-> 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 (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
forall a. EpAnn' a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun LHsExpr GhcTc
LHsExpr (GhcPass (XPass 'TcpTc))
arg) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
ETypeArg { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
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 (XAppTypeE GhcTc
-> LHsExpr GhcTc -> LHsWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XETAType 'TcpTc
ty GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun LHsWcType GhcRn
LHsWcType (NoGhcTc GhcTc)
hs_ty) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE NoExtField
XPragE GhcTc
noExtField HsPragE GhcTc
HsPragE (GhcPass (XPass 'TcpTc))
p GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EPar AppCtxt
ctxt')
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcTc
forall a. EpAnn' a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EExpand HsExpr GhcRn
orig)
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr (HsExpr GhcRn
-> HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)
forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
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 = 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
isHsValArg :: HsExprArg id -> Bool
isHsValArg :: HsExprArg id -> Bool
isHsValArg (EValArg {}) = Bool
True
isHsValArg HsExprArg id
_ = Bool
False
countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs [] = Int
0
countLeadingValArgs (EValArg {} : [HsExprArg id]
args) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EWrap {} : [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EPrag {} : [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (ETypeArg {} : [HsExprArg id]
_) = Int
0
isValArg :: HsExprArg id -> Bool
isValArg :: HsExprArg id -> Bool
isValArg (EValArg {}) = Bool
True
isValArg HsExprArg id
_ = Bool
False
isVisibleArg :: HsExprArg id -> Bool
isVisibleArg :: 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
<+> EValArg p -> 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
<+> 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 GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty }) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
LHsWcType GhcRn
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
text String
"EPar"
ppr (EHsWrap HsWrapper
w) = String -> SDoc
text String
"EHsWrap" SDoc -> SDoc -> SDoc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
w
ppr (EExpand HsExpr GhcRn
orig) = String -> SDoc
text String
"EExpand" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
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 GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
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 -> TcRhoType
va_ty = TcRhoType
ty})
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"ValArgQL" SDoc -> SDoc -> SDoc
<+> (HsExpr GhcTc, AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcTc, AppCtxt)
fun)
Int
2 ([SDoc] -> SDoc
vcat [ [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
args, String -> SDoc
text String
"va_ty:" SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
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 -> Int -> SDoc -> SDoc
hang (EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
tm) Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Scaled TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcRhoType
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] -> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn]
-> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcRhoType)
tcInferAppHead (HsExpr GhcRn
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
= SrcSpan
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) (TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$
do { Maybe (HsExpr GhcTc, TcRhoType)
mb_tc_fun <- HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> Maybe TcRhoType
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
; case Maybe (HsExpr GhcTc, TcRhoType)
mb_tc_fun of
Just (HsExpr GhcTc
fun', TcRhoType
fun_sigma) -> (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcRhoType
fun_sigma)
Maybe (HsExpr GhcTc, TcRhoType)
Nothing -> HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (HsExpr GhcTc, TcRhoType)
forall a. HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args (TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$
(ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcRhoType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcRhoType)
tcInfer (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> Maybe TcRhoType
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
= case HsExpr GhcRn
fun of
HsVar XVar GhcRn
_ (L _ nm) -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcRhoType)
tcInferId Name
nm
HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbiguousFieldOcc GhcRn
-> [HsExprArg 'TcpRn]
-> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty -> HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall a. HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args (TcM (Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType)))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall a b. (a -> b) -> a -> b
$
(HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcRhoType)
tcExprWithSig LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty
HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferOverLit HsOverLit GhcRn
lit
HsExpr GhcRn
_ -> Maybe (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr GhcTc, TcRhoType)
forall a. Maybe a
Nothing
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args TcM a
thing_inside
| [HsExprArg 'TcpRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsExprArg 'TcpRn]
args = TcM a
thing_inside
| Bool
otherwise = HsExpr GhcRn -> TcM a -> TcM a
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
fun TcM a
thing_inside
tcInferRecSelId :: AmbiguousFieldOcc GhcRn
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: AmbiguousFieldOcc GhcRn
-> [HsExprArg 'TcpRn]
-> Maybe TcRhoType
-> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId (Unambiguous XUnambiguous GhcRn
sel_name LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
_args Maybe TcRhoType
_mb_res_ty
= do { TcId
sel_id <- LocatedN RdrName -> Name -> TcM TcId
tc_rec_sel_id LocatedN RdrName
lbl Name
XUnambiguous GhcRn
sel_name
; let expr :: HsExpr GhcTc
expr = XRecFld GhcTc -> AmbiguousFieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
XRecFld GhcTc
noExtField (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous TcId
XUnambiguous GhcTc
sel_id LocatedN RdrName
lbl)
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcId -> TcRhoType
idType TcId
sel_id) }
tcInferRecSelId (Ambiguous XAmbiguous GhcRn
_ LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
= do { Name
sel_name <- LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
; TcId
sel_id <- LocatedN RdrName -> Name -> TcM TcId
tc_rec_sel_id LocatedN RdrName
lbl Name
sel_name
; let expr :: HsExpr GhcTc
expr = XRecFld GhcTc -> AmbiguousFieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
XRecFld GhcTc
noExtField (XAmbiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Ambiguous TcId
XAmbiguous GhcTc
sel_id LocatedN RdrName
lbl)
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcId -> TcRhoType
idType TcId
sel_id) }
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId
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 -> TcId
tct_id = TcId
id }
-> do { OccName -> TcId -> TcM ()
check_naughty OccName
occ TcId
id
; TcId -> TcM ()
check_local_id TcId
id
; TcId -> TcM TcId
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
id }
AGlobal (AnId TcId
id)
-> do { OccName -> TcId -> TcM ()
check_naughty OccName
occ TcId
id
; TcId -> TcM TcId
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
id }
TcTyThing
_ -> SDoc -> TcM TcId
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM TcId) -> SDoc -> TcM TcId
forall a b. (a -> b) -> a -> b
$
TcTyThing -> SDoc
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 (LocatedN RdrName -> RdrName
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 TcRhoType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcRhoType
mb_res_ty
| HsExprArg 'TcpRn
arg1 : [HsExprArg 'TcpRn]
_ <- (HsExprArg 'TcpRn -> Bool)
-> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (HsExprArg 'TcpRn -> Bool) -> HsExprArg 'TcpRn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isVisibleArg) [HsExprArg 'TcpRn]
args
, EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg (L _ arg) } <- HsExprArg 'TcpRn
arg1
, Just LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig HsExpr GhcRn
arg
= do { TcRhoType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcRhoType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
; LocatedN RdrName -> TcRhoType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl TcRhoType
sig_tc_ty }
| Just TcRhoType
res_ty <- Maybe TcRhoType
mb_res_ty
, Just (Scaled TcRhoType
arg_ty,TcRhoType
_) <- TcRhoType -> Maybe (Scaled TcRhoType, TcRhoType)
tcSplitFunTy_maybe TcRhoType
res_ty
= LocatedN RdrName -> TcRhoType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl (Scaled TcRhoType -> TcRhoType
forall a. Scaled a -> a
scaledThing Scaled TcRhoType
arg_ty)
| Bool
otherwise
= LocatedN RdrName -> TcM Name
forall a. LocatedN RdrName -> TcM a
ambiguousSelector LocatedN RdrName
lbl
finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name
finish_ambiguous_selector :: LocatedN RdrName -> TcRhoType -> TcM Name
finish_ambiguous_selector lr :: LocatedN RdrName
lr@(L SrcSpanAnnN
_ RdrName
rdr) TcRhoType
parent_type
= do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case FamInstEnvs -> TcRhoType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcRhoType
parent_type of {
Maybe TyCon
Nothing -> LocatedN RdrName -> TcM Name
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 RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
parent [(RecSelParent, GlobalRdrElt)]
xs of {
Maybe GlobalRdrElt
Nothing -> SDoc -> TcM Name
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 (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"belonging to type" SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
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."
]
; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) } } } } }
ambiguousSelector :: LocatedN RdrName -> TcM a
ambiguousSelector :: LocatedN RdrName -> TcM a
ambiguousSelector (L SrcSpanAnnN
_ RdrName
rdr)
= do { RdrName -> TcM ()
addAmbiguousNameErr RdrName
rdr
; TcM a
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
[] -> String -> TcM ()
forall a. String -> a
panic String
"addAmbiguousNameErr: not found"
GlobalRdrElt
gre : [GlobalRdrElt]
gres -> [ErrCtxt] -> TcM () -> TcM ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ RdrName -> NonEmpty GlobalRdrElt -> TcM ()
addNameClashErrRn RdrName
rdr (NonEmpty GlobalRdrElt -> TcM ())
-> NonEmpty GlobalRdrElt -> TcM ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrElt
gre GlobalRdrElt -> [GlobalRdrElt] -> NonEmpty GlobalRdrElt
forall a. a -> [a] -> NonEmpty a
NE.:| [GlobalRdrElt]
gres}
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
_ LHsSigWcType (NoGhcTc GhcRn)
ty) = HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Maybe
(HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn)))
forall a. a -> Maybe a
Just HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
LHsSigWcType (NoGhcTc GhcRn)
ty
obviousSig (HsPar XPar GhcRn
_ LHsExpr GhcRn
p) = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
p)
obviousSig (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
p) = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
p)
obviousSig HsExpr GhcRn
_ = Maybe (LHsSigWcType GhcRn)
forall a. Maybe a
Nothing
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> TcRhoType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcRhoType
ty0
= case HasCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
tcSplitTyConApp_maybe TcRhoType
ty of
Just (TyCon
tc, [TcRhoType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcRhoType], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcRhoType] -> (TyCon, [TcRhoType], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcRhoType]
tys))
Maybe (TyCon, [TcRhoType])
Nothing -> Maybe TyCon
forall a. Maybe a
Nothing
where
([TcId]
_, [TcRhoType]
_, TcRhoType
ty) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpSigmaType
ty0 = FamInstEnvs -> TcRhoType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcRhoType -> Maybe TyCon) -> Maybe TcRhoType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcRhoType
checkingExpType_maybe ExpSigmaType
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)
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 { TcId
id <- Name -> TcM TcId
tcLookupId (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
; case TcId -> Maybe RecSelParent
recordSelectorTyCon_maybe TcId
id of
Just RecSelParent
rstc -> (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecSelParent
rstc, GlobalRdrElt
gre)
Maybe RecSelParent
Nothing -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
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 (RecSelParent -> SDoc
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 (Name -> SDoc
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 (OccName -> SDoc
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 GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcRhoType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
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 GhcRn -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty Maybe Name
forall a. Maybe a
Nothing
; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcRhoType
poly_ty) <- LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcRhoType)
tcExprSig LHsExpr GhcRn
expr TcIdSigInfo
sig_info
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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 NoExtField
XExprWithTySig GhcTc
noExtField GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcRhoType
poly_ty) }
where
loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcRhoType)
tcExprSig LHsExpr GhcRn
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall a b. (a -> b) -> a -> b
$
do { let poly_ty :: TcRhoType
poly_ty = TcId -> TcRhoType
idType TcId
poly_id
; (HsWrapper
wrap, GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- UserTypeCtxt
-> TcRhoType
-> (TcRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall result.
UserTypeCtxt
-> TcRhoType
-> (TcRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ExprSigCtxt TcRhoType
poly_ty ((TcRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (TcRhoType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ \TcRhoType
rho_ty ->
LHsExpr GhcRn -> TcRhoType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcRhoType
rho_ty
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr', TcRhoType
poly_ty) }
tcExprSig LHsExpr GhcRn
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
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, TcId)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, TcId)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ((VarBndr TcId Specificity -> TcId)
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar ([(Name, VarBndr TcId Specificity)] -> [(Name, TcId)])
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
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, TcId)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, TcId)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, TcId)]
sig_inst_wcs 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
$
LHsExpr GhcRn -> TcRhoType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr (TcIdSigInst -> TcRhoType
sig_inst_tau TcIdSigInst
sig_inst)
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst) }
; let tau :: TcRhoType
tau = TcIdSigInst -> TcRhoType
sig_inst_tau TcIdSigInst
sig_inst
infer_mode :: InferMode
infer_mode | [TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcRhoType]
sig_inst_theta TcIdSigInst
sig_inst)
, Maybe TcRhoType -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcRhoType
sig_inst_wcx TcIdSigInst
sig_inst)
= InferMode
ApplyMR
| Bool
otherwise
= InferMode
NoRestrictions
; ([TcId]
qtvs, [TcId]
givens, TcEvBinds
ev_binds, Bool
_)
<- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcRhoType)]
-> WantedConstraints
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcRhoType
tau)] WantedConstraints
wanted
; TcRhoType
tau <- TcRhoType -> TcM TcRhoType
zonkTcType TcRhoType
tau
; let inferred_theta :: [TcRhoType]
inferred_theta = (TcId -> TcRhoType) -> [TcId] -> [TcRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcId -> TcRhoType
evVarPred [TcId]
givens
tau_tvs :: TyCoVarSet
tau_tvs = TcRhoType -> TyCoVarSet
tyCoVarsOfType TcRhoType
tau
; ([VarBndr TcId Specificity]
binders, [TcRhoType]
my_theta) <- [TcRhoType]
-> TyCoVarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], [TcRhoType])
chooseInferredQuantifiers [TcRhoType]
inferred_theta
TyCoVarSet
tau_tvs [TcId]
qtvs (TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
; let inferred_sigma :: TcRhoType
inferred_sigma = [TcId] -> [TcRhoType] -> TcRhoType -> TcRhoType
mkInfSigmaTy [TcId]
qtvs [TcRhoType]
inferred_theta TcRhoType
tau
my_sigma :: TcRhoType
my_sigma = [VarBndr TcId Specificity] -> TcRhoType -> TcRhoType
mkInvisForAllTys [VarBndr TcId Specificity]
binders ([TcRhoType] -> TcRhoType -> TcRhoType
mkPhiTy [TcRhoType]
my_theta TcRhoType
tau)
; HsWrapper
wrap <- if TcRhoType
inferred_sigma TcRhoType -> TcRhoType -> Bool
`eqType` TcRhoType
my_sigma
then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else UserTypeCtxt
-> TcRhoType
-> TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma UserTypeCtxt
ExprSigCtxt TcRhoType
inferred_sigma TcRhoType
my_sigma
; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" ([TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
qtvs SDoc -> SDoc -> SDoc
$$ [TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
givens SDoc -> SDoc -> SDoc
$$ TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
my_sigma)
; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
HsWrapper -> HsWrapper -> HsWrapper
<.> [TcId] -> HsWrapper
mkWpTyLams [TcId]
qtvs
HsWrapper -> HsWrapper -> HsWrapper
<.> [TcId] -> HsWrapper
mkWpLams [TcId]
givens
HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
ev_binds
; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr', TcRhoType
my_sigma) }
tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferOverLit lit :: HsOverLit GhcRn
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 GhcRn
_ (L loc from_name)
, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit GhcRn
rebindable })
=
do { TcId
from_id <- Name -> TcM TcId
tcLookupId Name
from_name
; (HsWrapper
wrap1, TcRhoType
from_ty) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate CtOrigin
orig (TcId -> TcRhoType
idType TcId
from_id)
; (HsWrapper
wrap2, Scaled TcRhoType
sarg_ty, TcRhoType
res_ty) <- SDoc
-> Maybe SDoc
-> (Int, [Scaled TcRhoType])
-> TcRhoType
-> TcM (HsWrapper, Scaled TcRhoType, TcRhoType)
matchActualFunTySigma SDoc
herald Maybe SDoc
mb_doc
(Int
1, []) TcRhoType
from_ty
; HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
; Coercion
co <- Maybe SDoc -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe SDoc
mb_doc (HsLit GhcTc -> TcRhoType
forall (p :: Pass). HsLit (GhcPass p) -> TcRhoType
hsLitType HsLit GhcTc
hs_lit) (Scaled TcRhoType -> TcRhoType
forall a. Scaled a -> a
scaledThing Scaled TcRhoType
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 (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
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
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 NoExtField
XVar GhcTc
noExtField (SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcId
from_id)
lit' :: HsOverLit GhcTc
lit' = HsOverLit GhcRn
lit { ol_witness :: HsExpr GhcTc
ol_witness = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
forall a. EpAnn' a
noAnn (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) HsExpr GhcTc
from_expr) GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lit_expr
, ol_ext :: XOverLit GhcTc
ol_ext = Bool -> TcRhoType -> OverLitTc
OverLitTc Bool
XOverLit GhcRn
rebindable TcRhoType
res_ty }
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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
forall a. EpAnn' a
noAnn HsOverLit GhcTc
lit', TcRhoType
res_ty) }
where
orig :: CtOrigin
orig = HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit
mb_doc :: Maybe SDoc
mb_doc = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Name -> SDoc
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
from_name)
, String -> SDoc
text String
"is applied to"]
tcInferOverLit HsOverLit GhcRn
lit
= String -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInferOverLit" (HsOverLit GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcRn
lit)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpSigmaType
res_ty
= do { (HsExpr GhcTc
expr, TcRhoType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcRhoType)
tcInferId Name
name
; String -> SDoc -> TcM ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
actual_res_ty, ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty])
; HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM a
-> TcM a
addFunResCtxt HsExpr GhcRn
rn_fun [] TcRhoType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTc
-> TcRhoType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) HsExpr GhcRn
rn_fun HsExpr GhcTc
expr TcRhoType
actual_res_ty ExpSigmaType
res_ty }
where
rn_fun :: HsExpr GhcRn
rn_fun = XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (Name -> LocatedAn NameAnn Name
forall a an. a -> LocatedAn an a
noLocA Name
name)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcRhoType)
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, TcRhoType)
tc_infer_id Name
id_name
else Name -> TcM (HsExpr GhcTc, TcRhoType)
tc_infer_assert Name
id_name }
| Bool
otherwise
= do { (HsExpr GhcTc
expr, TcRhoType
ty) <- Name -> TcM (HsExpr GhcTc, TcRhoType)
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
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
ty)
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcRhoType
ty) }
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcRhoType)
tc_infer_assert Name
assert_name
= do { TcId
assert_error_id <- Name -> TcM TcId
tcLookupId Name
assertErrorName
; (HsWrapper
wrap, TcRhoType
id_rho) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
(TcId -> TcRhoType
idType TcId
assert_error_id)
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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 NoExtField
XVar GhcTc
noExtField (TcId -> GenLocated SrcSpanAnnN TcId
forall a an. a -> LocatedAn an a
noLocA TcId
assert_error_id)), TcRhoType
id_rho)
}
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcRhoType)
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 -> TcId
tct_id = TcId
id }
-> do { TcId -> TcM ()
check_local_id TcId
id
; TcId -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) p an.
(Monad m, XVar p ~ NoExtField,
XRec p (IdP p) ~ GenLocated (SrcAnn an) TcId) =>
TcId -> m (HsExpr p, TcRhoType)
return_id TcId
id }
AGlobal (AnId TcId
id)
-> TcId -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) p an.
(Monad m, XVar p ~ NoExtField,
XRec p (IdP p) ~ GenLocated (SrcAnn an) TcId) =>
TcId -> m (HsExpr p, TcRhoType)
return_id TcId
id
AGlobal (AConLike ConLike
cl) -> case ConLike
cl of
RealDataCon DataCon
con -> DataCon -> TcM (HsExpr GhcTc, TcRhoType)
return_data_con DataCon
con
PatSynCon PatSyn
ps
| Just (HsExpr GhcTc
expr, TcRhoType
ty) <- PatSyn -> Maybe (HsExpr GhcTc, TcRhoType)
patSynBuilderOcc PatSyn
ps
-> (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcRhoType
ty)
| Bool
otherwise
-> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
forall a. Outputable a => a -> SDoc
nonBidirectionalErr Name
id_name)
AGlobal (ATyCon TyCon
ty_con)
-> GlobalRdrEnv -> TyCon -> TcM (HsExpr GhcTc, TcRhoType)
forall a. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con
ATyVar Name
name TcId
_
-> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcRhoType))
-> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
name))
ATcTyCon TyCon
ty_con
-> GlobalRdrEnv -> TyCon -> TcM (HsExpr GhcTc, TcRhoType)
forall a. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con
TcTyThing
_ -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcRhoType))
-> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$
TcTyThing -> SDoc
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 -> Int -> SDoc -> SDoc
nest Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
Maybe GlobalRdrElt
Nothing -> SDoc
empty
in SDoc -> TcM a
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
ty_con))
return_id :: TcId -> m (HsExpr p, TcRhoType)
return_id TcId
id = (HsExpr p, TcRhoType) -> m (HsExpr p, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> XRec p (IdP p) -> HsExpr p
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar p
noExtField (TcId -> GenLocated (SrcAnn an) TcId
forall a an. a -> LocatedAn an a
noLocA TcId
id), TcId -> TcRhoType
idType TcId
id)
return_data_con :: DataCon -> TcM (HsExpr GhcTc, TcRhoType)
return_data_con DataCon
con
= do { let tvs :: [VarBndr TcId Specificity]
tvs = DataCon -> [VarBndr TcId Specificity]
dataConUserTyVarBinders DataCon
con
theta :: [TcRhoType]
theta = DataCon -> [TcRhoType]
dataConOtherTheta DataCon
con
args :: [Scaled TcRhoType]
args = DataCon -> [Scaled TcRhoType]
dataConOrigArgTys DataCon
con
res :: TcRhoType
res = DataCon -> TcRhoType
dataConOrigResTy DataCon
con
; [TcRhoType]
mul_vars <- Int -> TcRhoType -> TcM [TcRhoType]
newFlexiTyVarTys ([Scaled TcRhoType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcRhoType]
args) TcRhoType
multiplicityTy
; let scaleArgs :: [Scaled TcRhoType] -> [Scaled TcRhoType]
scaleArgs [Scaled TcRhoType]
args' = String
-> (TcRhoType -> Scaled TcRhoType -> Scaled TcRhoType)
-> [TcRhoType]
-> [Scaled TcRhoType]
-> [Scaled TcRhoType]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"return_data_con" TcRhoType -> Scaled TcRhoType -> Scaled TcRhoType
forall a. TcRhoType -> Scaled a -> Scaled a
combine [TcRhoType]
mul_vars [Scaled TcRhoType]
args'
combine :: TcRhoType -> Scaled a -> Scaled a
combine TcRhoType
var (Scaled TcRhoType
One a
ty) = TcRhoType -> a -> Scaled a
forall a. TcRhoType -> a -> Scaled a
Scaled TcRhoType
var a
ty
combine TcRhoType
_ Scaled a
scaled_ty = Scaled a
scaled_ty
etaWrapper :: t (Scaled TcRhoType) -> HsWrapper
etaWrapper t (Scaled TcRhoType)
arg_tys = (Scaled TcRhoType -> HsWrapper -> HsWrapper)
-> HsWrapper -> t (Scaled TcRhoType) -> HsWrapper
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Scaled TcRhoType
scaled_ty HsWrapper
wr -> HsWrapper -> HsWrapper -> Scaled TcRhoType -> SDoc -> HsWrapper
WpFun HsWrapper
WpHole HsWrapper
wr Scaled TcRhoType
scaled_ty SDoc
empty) HsWrapper
WpHole t (Scaled TcRhoType)
arg_tys
; let shouldInstantiate :: Bool
shouldInstantiate = (Bool -> Bool
not ([TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [TcRhoType]
dataConStupidTheta DataCon
con)) Bool -> Bool -> Bool
||
TcRhoType -> Bool
isKindLevPoly (TyCon -> TcRhoType
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con)))
; case Bool
shouldInstantiate of
Bool
True -> do { (TCvSubst
subst, [TcId]
tvs') <- [TcId] -> TcM (TCvSubst, [TcId])
newMetaTyVars ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
tvs)
; let tys' :: [TcRhoType]
tys' = [TcId] -> [TcRhoType]
mkTyVarTys [TcId]
tvs'
theta' :: [TcRhoType]
theta' = HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst [TcRhoType]
theta
args' :: [Scaled TcRhoType]
args' = HasCallStack =>
TCvSubst -> [Scaled TcRhoType] -> [Scaled TcRhoType]
TCvSubst -> [Scaled TcRhoType] -> [Scaled TcRhoType]
substScaledTys TCvSubst
subst [Scaled TcRhoType]
args
res' :: TcRhoType
res' = HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst TcRhoType
res
; HsWrapper
wrap <- CtOrigin
-> [TcRhoType]
-> [TcRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcRhoType]
tys' [TcRhoType]
theta'
; let scaled_arg_tys :: [Scaled TcRhoType]
scaled_arg_tys = [Scaled TcRhoType] -> [Scaled TcRhoType]
scaleArgs [Scaled TcRhoType]
args'
eta_wrap :: HsWrapper
eta_wrap = [Scaled TcRhoType] -> HsWrapper
forall (t :: * -> *).
Foldable t =>
t (Scaled TcRhoType) -> HsWrapper
etaWrapper [Scaled TcRhoType]
scaled_arg_tys
; DataCon -> [TcRhoType] -> TcM ()
addDataConStupidTheta DataCon
con [TcRhoType]
tys'
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap)
(XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [Scaled TcRhoType] -> TcRhoType -> TcRhoType
mkVisFunTys [Scaled TcRhoType]
scaled_arg_tys TcRhoType
res')
}
Bool
False -> let scaled_arg_tys :: [Scaled TcRhoType]
scaled_arg_tys = [Scaled TcRhoType] -> [Scaled TcRhoType]
scaleArgs [Scaled TcRhoType]
args
wrap1 :: HsWrapper
wrap1 = [TcRhoType] -> HsWrapper
mkWpTyApps ([TcId] -> [TcRhoType]
mkTyVarTys ([TcId] -> [TcRhoType]) -> [TcId] -> [TcRhoType]
forall a b. (a -> b) -> a -> b
$ [VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
tvs)
eta_wrap :: HsWrapper
eta_wrap = [Scaled TcRhoType] -> HsWrapper
forall (t :: * -> *).
Foldable t =>
t (Scaled TcRhoType) -> HsWrapper
etaWrapper ((TcRhoType -> Scaled TcRhoType)
-> [TcRhoType] -> [Scaled TcRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcRhoType -> Scaled TcRhoType
forall a. a -> Scaled a
unrestricted [TcRhoType]
theta [Scaled TcRhoType] -> [Scaled TcRhoType] -> [Scaled TcRhoType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcRhoType]
scaled_arg_tys)
wrap2 :: HsWrapper
wrap2 = [TcId] -> HsWrapper
mkWpTyLams ([TcId] -> HsWrapper) -> [TcId] -> HsWrapper
forall a b. (a -> b) -> a -> b
$ [VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
tvs
in (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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)
(XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [VarBndr TcId Specificity] -> TcRhoType -> TcRhoType
mkInvisForAllTys [VarBndr TcId Specificity]
tvs (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$ [TcRhoType] -> TcRhoType -> TcRhoType
mkInvisFunTysMany [TcRhoType]
theta (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$ [Scaled TcRhoType] -> TcRhoType -> TcRhoType
mkVisFunTys [Scaled TcRhoType]
scaled_arg_tys TcRhoType
res)
}
check_local_id :: Id -> TcM ()
check_local_id :: TcId -> TcM ()
check_local_id TcId
id
= do { TcId -> TcM ()
checkThLocalId TcId
id
; UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ Name -> TcRhoType -> UsageEnv
forall n. NamedThing n => n -> TcRhoType -> UsageEnv
unitUE (TcId -> Name
idName TcId
id) TcRhoType
One }
check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> TcId -> TcM ()
check_naughty OccName
lbl TcId
id
| TcId -> Bool
isNaughtyRecordSelector TcId
id = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (OccName -> SDoc
naughtyRecordSel OccName
lbl)
| Bool
otherwise = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
nonBidirectionalErr :: Outputable name => name -> SDoc
nonBidirectionalErr :: name -> SDoc
nonBidirectionalErr name
name = String -> SDoc
text String
"non-bidirectional pattern synonym"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (name -> SDoc
forall a. Outputable a => a -> SDoc
ppr name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used in an expression"
checkThLocalId :: Id -> TcM ()
checkThLocalId :: TcId -> TcM ()
checkThLocalId TcId
id
= do { Maybe (TopLevelFlag, Int, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel (TcId -> Name
idName TcId
id)
; case Maybe (TopLevelFlag, Int, ThStage)
mb_local_use of
Just (TopLevelFlag
top_lvl, Int
bind_lvl, ThStage
use_stage)
| ThStage -> Int
thLevel ThStage
use_stage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bind_lvl
-> TopLevelFlag -> TcId -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcId
id ThStage
use_stage
Maybe (TopLevelFlag, Int, ThStage)
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> TcId -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcId
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 :: TcRhoType
id_ty = TcId -> TcRhoType
idType TcId
id
; Bool -> SDoc -> TcM ()
checkTc (TcRhoType -> Bool
isTauTy TcRhoType
id_ty) (TcId -> SDoc
polySpliceErr TcId
id)
; HsExpr GhcTc
lift <- if TcRhoType -> Bool
isStringTy TcRhoType
id_ty then
do { TcId
sid <- Name -> TcM TcId
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (TcId -> GenLocated SrcSpanAnnN TcId
forall a an. a -> LocatedAn an a
noLocA TcId
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 -> [TcRhoType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
Name
GHC.Builtin.Names.TH.liftName
[HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
getRuntimeRep TcRhoType
id_ty, TcRhoType
id_ty]
; WarningFlag -> TcM () -> TcM ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitLift (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> SDoc -> TcM ()
addDiagnosticTc (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnImplicitLift)
(String -> SDoc
text String
"The variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is implicitly lifted in the TH quotation")
; [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 TcId
IdP GhcTc
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 (m :: * -> *) a. Monad m => a -> m a
return () }
where
id_name :: Name
id_name = TcId -> Name
idName TcId
id
checkCrossStageLifting TopLevelFlag
_ TcId
_ ThStage
_ = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
polySpliceErr :: Id -> SDoc
polySpliceErr :: TcId -> SDoc
polySpliceErr TcId
id
= String -> SDoc
text String
"Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id)
addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM a
-> TcM a
addFunResCtxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args TcRhoType
fun_res_ty ExpSigmaType
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 TcRhoType
mb_env_ty <- ExpSigmaType -> TcM (Maybe TcRhoType)
readExpType_maybe ExpSigmaType
env_ty
; TcRhoType
fun_res' <- TcRhoType -> TcM TcRhoType
zonkTcType TcRhoType
fun_res_ty
; TcRhoType
env' <- case Maybe TcRhoType
mb_env_ty of
Just TcRhoType
env_ty -> TcRhoType -> TcM TcRhoType
zonkTcType TcRhoType
env_ty
Maybe TcRhoType
Nothing ->
do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
; MASSERT( dumping )
; TcRhoType -> TcM TcRhoType
newFlexiTyVarTy TcRhoType
liftedTypeKind }
; let
([TcId]
_, [TcRhoType]
_, TcRhoType
fun_tau) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitNestedSigmaTys TcRhoType
fun_res'
([TcId]
_, [TcRhoType]
_, TcRhoType
env_tau) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
env'
([Scaled TcRhoType]
args_fun, TcRhoType
res_fun) = TcRhoType -> ([Scaled TcRhoType], TcRhoType)
tcSplitFunTys TcRhoType
fun_tau
([Scaled TcRhoType]
args_env, TcRhoType
res_env) = TcRhoType -> ([Scaled TcRhoType], TcRhoType)
tcSplitFunTys TcRhoType
env_tau
n_fun :: Int
n_fun = [Scaled TcRhoType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcRhoType]
args_fun
n_env :: Int
n_env = [Scaled TcRhoType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcRhoType]
args_env
info :: SDoc
info |
Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_env
, TcRhoType -> Bool
not_fun TcRhoType
res_env
= String -> SDoc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too few arguments"
|
Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n_env
, TcRhoType -> Bool
not_fun TcRhoType
res_fun
, (Int
n_fun Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
args) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n_env
= String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too many arguments"
| Bool
otherwise
= SDoc
Outputable.empty
; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
not_fun :: TcRhoType -> Bool
not_fun TcRhoType
ty
= case HasCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
tcSplitTyConApp_maybe TcRhoType
ty of
Just (TyCon
tc, [TcRhoType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
Maybe (TyCon, [TcRhoType])
Nothing -> Bool
False
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
e TcRn a
thing_inside
= case HsExpr GhcRn
e of
HsUnboundVar {} -> TcRn a
thing_inside
HsExpr GhcRn
_ -> SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
e) TcRn a
thing_inside
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
expr = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the expression:") Int
2 (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcRn -> HsExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr GhcRn
expr))