{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Head
( HsExprArg(..), EValArg(..), TcPass(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, countLeadingValArgs, isVisibleArg, pprHsExprArgTc
, countVisAndInvisValArgs, countHsWrapperInvisArgs
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId
, obviousSig
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
, addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( unitUE )
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
import GHC.Unit.Module ( getModule )
import GHC.Tc.Errors.Types
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.PatSyn( PatSyn )
import GHC.Core.ConLike( 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.Env
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 GHC.Utils.Panic.Plain
import Control.Monad
import Data.Function
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
_ LHsToken "(" GhcRn
_ LHsExpr GhcRn
fun LHsToken ")" GhcRn
_) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun
top_ctxt Int
n (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
fun) = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr 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) LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr 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) LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr 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
_ LHsToken "(" GhcRn
_ (L l fun) LHsToken ")" GhcRn
_) 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsExpr GhcTc
LHsExpr (GhcPass (XPass 'TcpTc))
arg) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
ETypeArg { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EPar AppCtxt
ctxt')
-> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (LHsExpr GhcTc -> HsExpr GhcTc
forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
EWrap (EExpand HsExpr 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 orig expanded. orig -> expanded -> HsExpansion orig expanded
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
countVisAndInvisValArgs :: [HsExprArg id] -> Arity
countVisAndInvisValArgs :: [HsExprArg id] -> Int
countVisAndInvisValArgs [] = Int
0
countVisAndInvisValArgs (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
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (EWrap EWrap
wrap : [HsExprArg id]
args) =
case EWrap
wrap of { EHsWrap HsWrapper
hsWrap -> HsWrapper -> Int
countHsWrapperInvisArgs HsWrapper
hsWrap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
; EPar {} -> [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
; EExpand {} -> [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args }
countVisAndInvisValArgs (EPrag {} : [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (ETypeArg {}: [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
countHsWrapperInvisArgs :: HsWrapper -> Arity
countHsWrapperInvisArgs :: HsWrapper -> Int
countHsWrapperInvisArgs = HsWrapper -> Int
forall p. Num p => HsWrapper -> p
go
where
go :: HsWrapper -> p
go HsWrapper
WpHole = p
0
go (WpCompose HsWrapper
wrap1 HsWrapper
wrap2) = HsWrapper -> p
go HsWrapper
wrap1 p -> p -> p
forall a. Num a => a -> a -> a
+ HsWrapper -> p
go HsWrapper
wrap2
go fun :: HsWrapper
fun@(WpFun {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
fun
go (WpCast {}) = p
0
go evLam :: HsWrapper
evLam@(WpEvLam {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
evLam
go (WpEvApp EvTerm
_) = p
1
go tyLam :: HsWrapper
tyLam@(WpTyLam {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
tyLam
go (WpTyApp TcRhoType
_) = p
0
go (WpLet TcEvBinds
_) = p
0
go (WpMultCoercion {}) = p
0
nope :: a -> a
nope a
x = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countHsWrapperInvisApps" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr :: HsExprArg p -> SDoc
ppr (EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg p
arg }) = String -> SDoc
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 LHsWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType 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 LHsExpr (GhcPass (XPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
e
ppr (ValArgQL { va_fun :: EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc, AppCtxt)
fun, va_args :: EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
args, va_ty :: EValArg 'TcpInst -> 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]
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcRhoType)
tcInferAppHead (HsExpr GhcRn
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args
= 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] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args
; 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]
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args
= 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
HsRecSel XRecSel GhcRn
_ FieldOcc 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
<$> FieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId FieldOcc GhcRn
f
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
HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedExpr HsExpr GhcRn
e))
-> HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
e [HsExprArg 'TcpRn]
args
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 :: FieldOcc GhcRn
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: FieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId (FieldOcc XCFieldOcc GhcRn
sel_name XRec GhcRn RdrName
lbl)
= do { TcId
sel_id <- TcM TcId
tc_rec_sel_id
; let expr :: HsExpr GhcTc
expr = XRecSel GhcTc -> FieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecSel p -> FieldOcc p -> HsExpr p
HsRecSel NoExtField
XRecSel GhcTc
noExtField (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
TcId
sel_id XRec GhcTc RdrName
XRec GhcRn 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)
}
where
occ :: OccName
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
GenLocated SrcSpanAnnN RdrName
lbl)
tc_rec_sel_id :: TcM TcId
tc_rec_sel_id :: TcM TcId
tc_rec_sel_id
= do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup XCFieldOcc GhcRn
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
_ -> TcRnMessage -> TcM TcId
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TcId) -> TcRnMessage -> TcM TcId
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
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
_ LHsToken "(" GhcRn
_ LHsExpr GhcRn
p LHsToken ")" GhcRn
_) = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr 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 -> TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
notSelector (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)) }
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType RecSelParent
p RdrName
rdr
= RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope RdrName
rdr (NotInScopeError -> TcRnMessage) -> NotInScopeError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> NotInScopeError
UnknownSubordinate (String -> SDoc
text String
"field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p))
notSelector :: Name -> TcRnMessage
notSelector :: Name -> TcRnMessage
notSelector = Name -> TcRnMessage
TcRnNotARecordSelector
tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr 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) <- UserTypeCtxt
-> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcRhoType)
tcExprSig UserTypeCtxt
ctxt 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsSigWcType (NoGhcTc GhcTc)
LHsSigWcType (NoGhcTc GhcRn)
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)
ctxt :: UserTypeCtxt
ctxt = ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt (LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)
tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig :: UserTypeCtxt
-> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcRhoType)
tcExprSig UserTypeCtxt
ctxt 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
ctxt 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcRhoType
poly_ty) }
tcExprSig UserTypeCtxt
_ 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
_), WantedConstraints
residual)
<- TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints))
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ 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
; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
residual
; 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) <- WantedConstraints
-> [TcRhoType]
-> TyCoVarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], [TcRhoType])
chooseInferredQuantifiers WantedConstraints
residual [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 CtOrigin
-> UserTypeCtxt
-> TcRhoType
-> TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma CtOrigin
ExprSigOrigin (ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt ReportRedundantConstraints
NoRRC) 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 LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr 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_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitRn { ol_rebindable = rebindable
, ol_from_fun = L loc from_name } })
=
do { HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
; TcId
from_id <- Name -> TcM TcId
tcLookupId Name
from_name
; (HsWrapper
wrap1, TcRhoType
from_ty) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate (HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit) (TcId -> TcRhoType
idType TcId
from_id)
; let
thing :: TypedThing
thing = Name -> TypedThing
NameThing Name
from_name
mb_thing :: Maybe TypedThing
mb_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just TypedThing
thing
herald :: ExpectedFunTyOrigin
herald = TypedThing -> HsExpr GhcTc -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg TypedThing
thing (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit)
; (HsWrapper
wrap2, Scaled TcRhoType
sarg_ty, TcRhoType
res_ty) <- ExpectedFunTyOrigin
-> Maybe TypedThing
-> (Int, [Scaled TcRhoType])
-> TcRhoType
-> TcM (HsWrapper, Scaled TcRhoType, TcRhoType)
matchActualFunTySigma ExpectedFunTyOrigin
herald Maybe TypedThing
mb_thing
(Int
1, []) TcRhoType
from_ty
; Coercion
co <- Maybe TypedThing -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe TypedThing
mb_thing (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)
witness :: HsExpr GhcTc
witness = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
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) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr
lit' :: HsOverLit GhcTc
lit' = HsOverLit GhcRn
lit { ol_ext :: XOverLit GhcTc
ol_ext = OverLitTc :: Bool -> HsExpr GhcTc -> TcRhoType -> OverLitTc
OverLitTc { $sel:ol_rebindable:OverLitTc :: Bool
ol_rebindable = Bool
rebindable
, $sel:ol_witness:OverLitTc :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
witness
, $sel:ol_type:OverLitTc :: TcRhoType
ol_type = 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) }
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
; 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 (RealDataCon DataCon
con)) -> DataCon -> TcM (HsExpr GhcTc, TcRhoType)
tcInferDataCon DataCon
con
AGlobal (AConLike (PatSynCon PatSyn
ps)) -> Name -> PatSyn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferPatSyn Name
id_name PatSyn
ps
(TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> TyCon -> TcM (HsExpr GhcTc, TcRhoType)
fail_tycon TyCon
tc
ATyVar Name
name TcId
_ -> Name -> TcM (HsExpr GhcTc, TcRhoType)
fail_tyvar Name
name
TcTyThing
_ -> TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
where
fail_tycon :: TyCon -> TcM (HsExpr GhcTc, TcRhoType)
fail_tycon TyCon
tc = do
GlobalRdrEnv
gre <- TcRn GlobalRdrEnv
getGlobalRdrEnv
let nm :: Name
nm = TyCon -> Name
tyConName TyCon
tc
pprov :: SDoc
pprov = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
gre Name
nm of
Just GlobalRdrElt
gre -> Int -> SDoc -> SDoc
nest Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
Maybe GlobalRdrElt
Nothing -> SDoc
empty
NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
fail_with_msg NameSpace
dataName Name
nm SDoc
pprov
fail_tyvar :: Name -> TcM (HsExpr GhcTc, TcRhoType)
fail_tyvar Name
nm =
let pprov :: SDoc
pprov = 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
nm))
in NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
fail_with_msg NameSpace
varName Name
nm SDoc
pprov
fail_with_msg :: NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
fail_with_msg NameSpace
whatName Name
nm SDoc
pprov = do
([ImportError]
import_errs, [GhcHint]
hints) <- NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
whatName
UnitState
unit_state <- HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
let
hint_msg :: SDoc
hint_msg = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
hints
import_err_msg :: SDoc
import_err_msg = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
import_errs
info :: ErrInfo
info = ErrInfo :: SDoc -> SDoc -> ErrInfo
ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
$$ SDoc
hint_msg }
msg :: TcRnMessage
msg = UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state
(TcRnMessageDetailed -> TcRnMessage)
-> TcRnMessageDetailed -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ ErrInfo -> TcRnMessage -> TcRnMessageDetailed
TcRnMessageDetailed ErrInfo
info (Name -> Bool -> TcRnMessage
TcRnIncorrectNameSpace Name
nm Bool
False)
TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
msg
get_suggestions :: NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
ns = do
let occ :: OccName
occ = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
ns (OccName -> FastString
occNameFS (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
id_name))
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
LocalRdrEnv
lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
ImportAvails
imp_info <- TcRn ImportAvails
getImports
Module
curr_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
HomePackageTable
hpt <- TcRnIf TcGblEnv TcLclEnv HomePackageTable
forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt
([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall (m :: * -> *) a. Monad m => a -> m a
return (([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint]))
-> ([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall a b. (a -> b) -> a -> b
$ WhatLooking
-> DynFlags
-> HomePackageTable
-> Module
-> GlobalRdrEnv
-> LocalRdrEnv
-> ImportAvails
-> RdrName
-> ([ImportError], [GhcHint])
unknownNameSuggestions WhatLooking
WL_Anything DynFlags
dflags HomePackageTable
hpt Module
curr_mod GlobalRdrEnv
rdr_env
LocalRdrEnv
lcl_env ImportAvails
imp_info (OccName -> RdrName
mkRdrUnqual OccName
occ)
return_id :: 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)
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 = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (OccName -> TcRnMessage
TcRnRecSelectorEscapedTyVar OccName
lbl)
| Bool
otherwise = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcRhoType)
tcInferDataCon DataCon
con
= do { let tvbs :: [VarBndr TcId Specificity]
tvbs = DataCon -> [VarBndr TcId Specificity]
dataConUserTyVarBinders DataCon
con
tvs :: [TcId]
tvs = [VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
tvbs
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
stupid_theta :: [TcRhoType]
stupid_theta = DataCon -> [TcRhoType]
dataConStupidTheta DataCon
con
; [Scaled TcRhoType]
scaled_arg_tys <- (Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType))
-> [Scaled TcRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled TcRhoType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
linear_to_poly [Scaled TcRhoType]
args
; let full_theta :: [TcRhoType]
full_theta = [TcRhoType]
stupid_theta [TcRhoType] -> [TcRhoType] -> [TcRhoType]
forall a. [a] -> [a] -> [a]
++ [TcRhoType]
theta
all_arg_tys :: [Scaled TcRhoType]
all_arg_tys = (TcRhoType -> Scaled TcRhoType)
-> [TcRhoType] -> [Scaled TcRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcRhoType -> Scaled TcRhoType
forall a. a -> Scaled a
unrestricted [TcRhoType]
full_theta [Scaled TcRhoType] -> [Scaled TcRhoType] -> [Scaled TcRhoType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcRhoType]
scaled_arg_tys
; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (ConLike -> [TcId] -> [Scaled TcRhoType] -> XXExprGhcTc
ConLikeTc (DataCon -> ConLike
RealDataCon DataCon
con) [TcId]
tvs [Scaled TcRhoType]
all_arg_tys)
, [VarBndr TcId Specificity] -> TcRhoType -> TcRhoType
mkInvisForAllTys [VarBndr TcId Specificity]
tvbs (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$ [TcRhoType] -> TcRhoType -> TcRhoType
mkPhiTy [TcRhoType]
full_theta (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$
[Scaled TcRhoType] -> TcRhoType -> TcRhoType
mkVisFunTys [Scaled TcRhoType]
scaled_arg_tys TcRhoType
res ) }
where
linear_to_poly :: Scaled Type -> TcM (Scaled Type)
linear_to_poly :: Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
linear_to_poly (Scaled TcRhoType
One TcRhoType
ty) = do { TcRhoType
mul_var <- TcRhoType -> TcM TcRhoType
newFlexiTyVarTy TcRhoType
multiplicityTy
; Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType -> TcRhoType -> Scaled TcRhoType
forall a. TcRhoType -> a -> Scaled a
Scaled TcRhoType
mul_var TcRhoType
ty) }
linear_to_poly Scaled TcRhoType
scaled_ty = Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return Scaled TcRhoType
scaled_ty
tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferPatSyn Name
id_name PatSyn
ps
= case PatSyn -> Maybe (HsExpr GhcTc, TcRhoType)
patSynBuilderOcc PatSyn
ps of
Just (HsExpr GhcTc
expr,TcRhoType
ty) -> (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr,TcRhoType
ty)
Maybe (HsExpr GhcTc, TcRhoType)
Nothing -> TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
nonBidirectionalErr Name
id_name)
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = Name -> TcRnMessage
TcRnPatSynNotBidirectional
checkThLocalId :: Id -> TcM ()
checkThLocalId :: 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 -> TcRnMessage -> TcM ()
checkTc (TcRhoType -> Bool
isTauTy TcRhoType
id_ty) (TcId -> TcRnMessage
TcRnSplicePolymorphicLocalVar 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]
; (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic (TcId -> ErrInfo -> TcRnMessage
forall var. Outputable var => var -> ErrInfo -> TcRnMessage
TcRnImplicitLift TcId
id)
; [PendingTcSplice]
ps <- TcRef [PendingTcSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingTcSplice]
forall a env. IORef a -> IOEnv env a
readMutVar TcRef [PendingTcSplice]
ps_var
; let pending_splice :: PendingTcSplice
pending_splice = Name -> LHsExpr GhcTc -> PendingTcSplice
PendingTcSplice Name
id_name
(LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
lift))
(IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
TcId
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 ()
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
; Bool -> TcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
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))