{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Sig(
TcSigInfo(..), TcIdSig(..), TcSigFun,
isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc,
completeSigPolyId_maybe, isCompleteHsSig,
lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,
tcTySigs, tcUserTypeSig, completeSigFromId,
tcInstSig,
TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
addInlinePrags, addInlinePragArity
) where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Driver.DynFlags
import GHC.Driver.Backend
import GHC.Hs
import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )
import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind )
import GHC.Tc.Zonk.Type
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType )
import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
import GHC.Tc.Utils.Env( tcLookupId )
import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
import GHC.Core( hasSomeUnfolding )
import GHC.Core.Type ( mkTyVarBinders )
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep( mkNakedFunTy )
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
import GHC.Types.Id ( Id, idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Builtin.Names( mkUnboundName )
import GHC.Unit.Module( getModule )
import GHC.Utils.Misc as Utils ( singleton )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe( orElse, whenIsJust )
import Data.Maybe( mapMaybe )
import qualified Data.List.NonEmpty as NE
import Control.Monad( unless )
tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig GhcRn]
hs_sigs
= TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall r. TcM r -> TcM r
checkNoErrs (TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun))
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a b. (a -> b) -> a -> b
$
do {
ty_sigs_s <- (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn [TcSigInfo])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [[TcSigInfo]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM LSig GhcRn -> TcRn [TcSigInfo]
GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn [TcSigInfo]
tcTySig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
hs_sigs
; let ty_sigs = [[TcSigInfo]] -> [TcSigInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TcSigInfo]]
ty_sigs_s
poly_ids = (TcSigInfo -> Maybe TcId) -> [TcSigInfo] -> [TcId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcSigInfo -> Maybe TcId
completeSigPolyId_maybe [TcSigInfo]
ty_sigs
env = [(Name, TcSigInfo)] -> NameEnv TcSigInfo
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(TcSigInfo -> Name
tcSigInfoName TcSigInfo
sig, TcSigInfo
sig) | TcSigInfo
sig <- [TcSigInfo]
ty_sigs]
; return (poly_ids, lookupNameEnv env) }
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
tcTySig :: LSig GhcRn -> TcRn [TcSigInfo]
tcTySig (L SrcSpanAnnA
_ (XSig (IdSig TcId
id)))
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt (TcId -> Name
idName TcId
id) ReportRedundantConstraints
NoRRC
sig :: TcCompleteSig
sig = UserTypeCtxt -> TcId -> TcCompleteSig
completeSigFromId UserTypeCtxt
ctxt TcId
id
; [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TcIdSig -> TcSigInfo
TcIdSig (TcCompleteSig -> TcIdSig
TcCompleteSig TcCompleteSig
sig)] }
tcTySig (L SrcSpanAnnA
loc (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
sig_ty))
= SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
do { sigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcIdSig]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcIdSig]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSig
tcUserTypeSig (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigWcType GhcRn
sig_ty (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name)
| L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names ]
; return (map TcIdSig sigs) }
tcTySig (L SrcSpanAnnA
loc (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
sig_ty))
= SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
do { tpsigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcPatSynSig]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcPatSynSig]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynSig
tcPatSynSig Name
name LHsSigType GhcRn
sig_ty
| L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names ]
; return (map TcPatSynSig tpsigs) }
tcTySig LSig GhcRn
_ = [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSig
tcUserTypeSig :: SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSig
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
hs_sig_ty Maybe Name
mb_name
| LHsSigWcType GhcRn -> Bool
isCompleteHsSig LHsSigWcType GhcRn
hs_sig_ty
= do { sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType UserTypeCtxt
ctxt_no_rrc LHsSigWcType GhcRn
hs_sig_ty
; traceTc "tcuser" (ppr sigma_ty)
; return $ TcCompleteSig $
CSig { sig_bndr = mkLocalId name ManyTy sigma_ty
, sig_ctxt = ctxt_rrc
, sig_loc = loc } }
| Bool
otherwise
= TcIdSig -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSig
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcIdSig -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSig)
-> TcIdSig -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSig
forall a b. (a -> b) -> a -> b
$ TcPartialSig -> TcIdSig
TcPartialSig (TcPartialSig -> TcIdSig) -> TcPartialSig -> TcIdSig
forall a b. (a -> b) -> a -> b
$
PSig { psig_name :: Name
psig_name = Name
name, psig_hs_ty :: LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_sig_ty
, psig_ctxt :: UserTypeCtxt
psig_ctxt = UserTypeCtxt
ctxt_no_rrc, psig_loc :: SrcSpan
psig_loc = SrcSpan
loc }
where
name :: Name
name = case Maybe Name
mb_name of
Just Name
n -> Name
n
Maybe Name
Nothing -> OccName -> Name
mkUnboundName (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"<expression>"))
ctxt_rrc :: UserTypeCtxt
ctxt_rrc = ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn (LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType GhcRn
hs_sig_ty)
ctxt_no_rrc :: UserTypeCtxt
ctxt_no_rrc = ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn ReportRedundantConstraints
NoRRC
ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn ReportRedundantConstraints
rcc = case Maybe Name
mb_name of
Just Name
n -> Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
n ReportRedundantConstraints
rcc
Maybe Name
Nothing -> ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt ReportRedundantConstraints
rcc
lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsSigType GhcRn
sigType }) = LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType GhcRn
sigType
lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan (L SrcSpanAnnA
_ HsSig { sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
sig_ty }) = GenLocated SrcSpanAnnA (HsType GhcRn) -> ReportRedundantConstraints
forall {pass} {l} {a}.
(XRec pass (HsType pass) ~ GenLocated l (HsType pass),
XRec pass [GenLocated l (HsType pass)]
~ GenLocated a [GenLocated l (HsType pass)],
HasLoc a) =>
GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
sig_ty
where
go :: GenLocated l (HsType pass) -> ReportRedundantConstraints
go (L l
_ (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L a
span [XRec pass (HsType pass)]
_ })) = SrcSpan -> ReportRedundantConstraints
WantRRC (SrcSpan -> ReportRedundantConstraints)
-> SrcSpan -> ReportRedundantConstraints
forall a b. (a -> b) -> a -> b
$ a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA a
span
go (L l
_ (HsForAllTy { hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec pass (HsType pass)
hs_ty })) = GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec pass (HsType pass)
GenLocated l (HsType pass)
hs_ty
go (L l
_ (HsParTy XParTy pass
_ XRec pass (HsType pass)
hs_ty)) = GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec pass (HsType pass)
GenLocated l (HsType pass)
hs_ty
go GenLocated l (HsType pass)
_ = ReportRedundantConstraints
NoRRC
completeSigFromId :: UserTypeCtxt -> Id -> TcCompleteSig
completeSigFromId :: UserTypeCtxt -> TcId -> TcCompleteSig
completeSigFromId UserTypeCtxt
ctxt TcId
id
= CSig { sig_bndr :: TcId
sig_bndr = TcId
id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = TcId -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TcId
id }
isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
isCompleteHsSig (HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC GhcRn (LHsSigType GhcRn)
wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsSigType GhcRn
hs_sig_ty })
= [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
XHsWC GhcRn (LHsSigType GhcRn)
wcs Bool -> Bool -> Bool
&& LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty LHsSigType GhcRn
hs_sig_ty
no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty (L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
body}))
= (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr Specificity GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (HsOuterSigTyVarBndrs GhcRn
-> [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs GhcRn
outer_bndrs)
Bool -> Bool -> Bool
&& XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
body
no_anon_wc_ty :: LHsType GhcRn -> Bool
no_anon_wc_ty :: XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
lty = GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
lty
where
go :: GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (L SrcSpanAnnA
_ HsType GhcRn
ty) = case HsType GhcRn
ty of
HsWildCardTy XWildCardTy GhcRn
_ -> Bool
False
HsAppTy XAppTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty1 XRec GhcRn (HsType GhcRn)
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
HsAppKindTy XAppKindTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty XRec GhcRn (HsType GhcRn)
ki -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ki
HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w XRec GhcRn (HsType GhcRn)
ty1 XRec GhcRn (HsType GhcRn)
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (HsArrow GhcRn -> XRec GhcRn (HsType GhcRn)
arrowToHsType HsArrow GhcRn
w)
HsListTy XListTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsTupleTy XTupleTy GhcRn
_ HsTupleSort
_ [XRec GhcRn (HsType GhcRn)]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsSumTy XSumTy GhcRn
_ [XRec GhcRn (HsType GhcRn)]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsOpTy XOpTy GhcRn
_ PromotionFlag
_ XRec GhcRn (HsType GhcRn)
ty1 LIdP GhcRn
_ XRec GhcRn (HsType GhcRn)
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
HsParTy XParTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsIParamTy XIParamTy GhcRn
_ XRec GhcRn HsIPName
_ XRec GhcRn (HsType GhcRn)
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsKindSig XKindSig GhcRn
_ XRec GhcRn (HsType GhcRn)
ty XRec GhcRn (HsType GhcRn)
kind -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
kind
HsDocTy XDocTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty LHsDoc GhcRn
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsBangTy XBangTy GhcRn
_ HsBang
_ XRec GhcRn (HsType GhcRn)
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsRecTy XRecTy GhcRn
_ [LConDeclField GhcRn]
flds -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (ConDeclField GhcRn -> XRec GhcRn (HsType GhcRn)
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [LConDeclField GhcRn]
[GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [XRec GhcRn (HsType GhcRn)]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [XRec GhcRn (HsType GhcRn)]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec GhcRn (HsType GhcRn)
ty } -> HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele HsForAllTelescope GhcRn
tele
Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcRn
ctxt
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec GhcRn (HsType GhcRn)
ty } -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
ctxt) Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsSpliceTy (HsUntypedSpliceTop ThModFinalizers
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ty) HsUntypedSplice GhcRn
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsSpliceTy (HsUntypedSpliceNested Name
_) HsUntypedSplice GhcRn
_ -> Bool
True
HsTyLit{} -> Bool
True
HsTyVar{} -> Bool
True
HsStarTy{} -> Bool
True
XHsType{} -> Bool
True
gos :: [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos = (GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go
no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele HsForAllTelescope GhcRn
tele = case HsForAllTelescope GhcRn
tele of
HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcRn]
ltvs } -> (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr () GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
ltvs
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcRn]
ltvs } -> (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr Specificity GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
ltvs
no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb :: forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (L SrcSpanAnnA
_ HsTyVarBndr flag GhcRn
tvb) = case HsTyVarBndr flag GhcRn -> HsBndrKind GhcRn
forall flag (pass :: Pass).
HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass)
hsBndrKind HsTyVarBndr flag GhcRn
tvb of
HsBndrNoKind XBndrNoKind GhcRn
_ -> Bool
True
HsBndrKind XBndrKind GhcRn
_ XRec GhcRn (HsType GhcRn)
ki -> XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
ki
tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynSig
tcPatSynSig :: Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynSig
tcPatSynSig Name
name sig_ty :: LHsSigType GhcRn
sig_ty@(L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
hs_ty}))
| (Maybe (LHsContext GhcRn)
hs_req, XRec GhcRn (HsType GhcRn)
hs_ty1) <- XRec GhcRn (HsType GhcRn)
-> (Maybe (LHsContext GhcRn), XRec GhcRn (HsType GhcRn))
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy XRec GhcRn (HsType GhcRn)
hs_ty
, ([LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs, Maybe (LHsContext GhcRn)
hs_prov, XRec GhcRn (HsType GhcRn)
hs_body_ty) <- XRec GhcRn (HsType GhcRn)
-> ([LHsTyVarBndr Specificity GhcRn], Maybe (LHsContext GhcRn),
XRec GhcRn (HsType GhcRn))
forall (p :: Pass).
LHsType (GhcPass p)
-> ([LHsTyVarBndr Specificity (GhcPass p)],
Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
splitLHsSigmaTyInvis XRec GhcRn (HsType GhcRn)
hs_ty1
= do { String -> SDoc -> TcRn ()
traceTc String
"tcPatSynSig 1" (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty)
; skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Name -> SkolemInfoAnon
DataConSkol Name
name)
; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))
<- pushLevelAndSolveEqualitiesX "tcPatSynSig" $
do { res_kind <- newOpenTypeKind
; tcOuterTKBndrs skol_info hs_outer_bndrs $
tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
do { req <- tcHsContext hs_req
; prov <- tcHsContext hs_prov
; body_ty <- tcCheckLHsType hs_body_ty res_kind
; return (req, prov, body_ty) } }
; let implicit_tvs :: [TcTyVar]
univ_bndrs :: [TcInvisTVBinder]
(implicit_tvs, univ_bndrs) = case outer_bndrs of
HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
implicit_tvs} -> ([TcId]
XHsOuterImplicit GhcTc
implicit_tvs, [])
HsOuterExplicit{hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc Specificity
univ_bndrs} -> ([], [VarBndr TcId Specificity]
XHsOuterExplicit GhcTc Specificity
univ_bndrs)
; implicit_tvs <- zonkAndScopedSort implicit_tvs
; let implicit_bndrs = Specificity -> [TcId] -> [VarBndr TcId Specificity]
forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
SpecifiedSpec [TcId]
implicit_tvs
; let ungen_patsyn_ty = [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Kind]
-> [VarBndr TcId Specificity]
-> [Kind]
-> Kind
-> Kind
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs
[Kind]
req [VarBndr TcId Specificity]
ex_bndrs [Kind]
prov Kind
body_ty
; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)
; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty
; reportUnsolvedEqualities skol_info kvs tclvl wanted
; (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, req, prov, body_ty) <-
initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX (mkTyVarBinders InferredSpec kvs)) $ \ [VarBndr TcId Specificity]
kv_bndrs ->
ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr TcId Specificity]
-> forall r.
([VarBndr TcId Specificity]
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr TcId Specificity]
-> ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr TcId Specificity]
forall vis. [VarBndr TcId vis] -> ZonkBndrTcM [VarBndr TcId vis]
zonkTyVarBindersX [VarBndr TcId Specificity]
implicit_bndrs) (([VarBndr TcId Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ([VarBndr TcId Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr TcId Specificity]
implicit_bndrs ->
ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr TcId Specificity]
-> forall r.
([VarBndr TcId Specificity]
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr TcId Specificity]
-> ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr TcId Specificity]
forall vis. [VarBndr TcId vis] -> ZonkBndrTcM [VarBndr TcId vis]
zonkTyVarBindersX [VarBndr TcId Specificity]
univ_bndrs) (([VarBndr TcId Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ([VarBndr TcId Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([VarBndr TcId Specificity], [VarBndr TcId Specificity],
[VarBndr TcId Specificity], [VarBndr TcId Specificity], [Kind],
[Kind], Kind)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr TcId Specificity]
univ_bndrs ->
do { req <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
req
; runZonkBndrT (zonkTyVarBindersX ex_bndrs) $ \ [VarBndr TcId Specificity]
ex_bndrs ->
do { prov <- [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX [Kind]
prov
; body_ty <- zonkTcTypeToTypeX body_ty
; return (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs,
req, prov, body_ty) } }
; checkValidType ctxt $
build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty
; let (arg_tys, res_ty) = tcSplitFunTys body_ty
; mapM_
(\(Scaled Kind
_ Kind
arg_ty) -> FixedRuntimeRepProvenance -> Kind -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepPatSynSigArg Kind
arg_ty)
arg_tys
; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty
; traceTc "tcTySig }" $
vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs)
, text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs)
, text "univ_tvs" <+> ppr_tvs (binderVars univ_bndrs)
, text "req" <+> ppr req
, text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs)
, text "prov" <+> ppr prov
, text "body_ty" <+> ppr body_ty ]
; return $
PatSig { patsig_name = name
, patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs
, patsig_univ_bndrs = univ_bndrs
, patsig_req = req
, patsig_ex_bndrs = ex_bndrs
, patsig_prov = prov
, patsig_body_ty = body_ty } }
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
PatSynCtxt Name
name
build_patsyn_type :: [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Kind]
-> [VarBndr TcId Specificity]
-> [Kind]
-> Kind
-> Kind
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs [Kind]
req [VarBndr TcId Specificity]
ex_bndrs [Kind]
prov Kind
body
= [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
implicit_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
univ_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
req (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
ex_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
prov (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
Kind
body
mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType
mk_naked_phi_ty :: [Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
theta Kind
body = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FunTyFlag -> Kind -> Kind -> Kind
mkNakedFunTy FunTyFlag
invisArgTypeLike) Kind
body [Kind]
theta
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs :: [TcId] -> SDoc
ppr_tvs [TcId]
tvs = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
tyVarKind TcId
tv)
| TcId
tv <- [TcId]
tvs])
tcInstSig :: TcIdSig -> TcM TcIdSigInst
tcInstSig :: TcIdSig -> TcM TcIdSigInst
tcInstSig hs_sig :: TcIdSig
hs_sig@(TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id, sig_loc :: TcCompleteSig -> SrcSpan
sig_loc = SrcSpan
loc }))
= SrcSpan -> TcM TcIdSigInst -> TcM TcIdSigInst
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcIdSigInst -> TcM TcIdSigInst)
-> TcM TcIdSigInst -> TcM TcIdSigInst
forall a b. (a -> b) -> a -> b
$
do { (tv_prs, theta, tau) <- Kind -> TcM ([(Name, VarBndr TcId Specificity)], [Kind], Kind)
tcInstTypeBndrs (TcId -> Kind
idType TcId
poly_id)
; return (TISI { sig_inst_sig = hs_sig
, sig_inst_skols = tv_prs
, sig_inst_wcs = []
, sig_inst_wcx = Nothing
, sig_inst_theta = theta
, sig_inst_tau = tau }) }
tcInstSig hs_sig :: TcIdSig
hs_sig@(TcPartialSig (PSig { psig_hs_ty :: TcPartialSig -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty
, psig_ctxt :: TcPartialSig -> UserTypeCtxt
psig_ctxt = UserTypeCtxt
ctxt
, psig_loc :: TcPartialSig -> SrcSpan
psig_loc = SrcSpan
loc }))
= SrcSpan -> TcM TcIdSigInst -> TcM TcIdSigInst
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcIdSigInst -> TcM TcIdSigInst)
-> TcM TcIdSigInst -> TcM TcIdSigInst
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Staring partial sig {" (TcIdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSig
hs_sig)
; (wcs, wcx, tv_prs, theta, tau) <- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM
([(Name, TcId)], Maybe Kind, [(Name, VarBndr TcId Specificity)],
[Kind], Kind)
tcHsPartialSigType UserTypeCtxt
ctxt LHsSigWcType GhcRn
hs_ty
; let inst_sig = TISI { sig_inst_sig :: TcIdSig
sig_inst_sig = TcIdSig
hs_sig
, sig_inst_skols :: [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
tv_prs
, sig_inst_wcs :: [(Name, TcId)]
sig_inst_wcs = [(Name, TcId)]
wcs
, sig_inst_wcx :: Maybe Kind
sig_inst_wcx = Maybe Kind
wcx
, sig_inst_theta :: [Kind]
sig_inst_theta = [Kind]
theta
, sig_inst_tau :: Kind
sig_inst_tau = Kind
tau }
; traceTc "End partial sig }" (ppr inst_sig)
; return inst_sig }
type TcPragEnv = NameEnv [LSig GhcRn]
emptyPragEnv :: TcPragEnv
emptyPragEnv :: TcPragEnv
emptyPragEnv = TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a
emptyNameEnv
lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
n = NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Name -> Maybe [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_fn Name
n Maybe [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. Maybe a -> a -> a
`orElse` []
extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
extendPragEnv TcPragEnv
prag_fn (Name
n, LSig GhcRn
sig) = (GenLocated SrcSpanAnnA (Sig GhcRn)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> (GenLocated SrcSpanAnnA (Sig GhcRn)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) GenLocated SrcSpanAnnA (Sig GhcRn)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. a -> [a]
Utils.singleton TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_fn Name
n LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs LHsBinds GhcRn
binds
= (NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
extendPragEnv NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a
emptyNameEnv [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs
where
prs :: [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs = (GenLocated SrcSpanAnnA (Sig GhcRn)
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn)))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LSig GhcRn -> Maybe (Name, LSig GhcRn)
GenLocated SrcSpanAnnA (Sig GhcRn)
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
get_sig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (SpecSig XSpecSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) [LHsSigType GhcRn]
_ InlinePragma
_)) = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (InlineSig XInlineSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) InlinePragma
_)) = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (SCCFunSig XSCCFunSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) Maybe (XRec GhcRn StringLiteral)
_)) = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
get_sig LSig GhcRn
_ = Maybe (Name, LSig GhcRn)
Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. Maybe a
Nothing
add_arity :: Name -> GenLocated SrcSpanAnnA (Sig GhcRn) -> LSig GhcRn
add_arity Name
n GenLocated SrcSpanAnnA (Sig GhcRn)
sig
= case NameEnv Arity -> Name -> Maybe Arity
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Arity
ar_env Name
n of
Just Arity
ar -> Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Arity
ar LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig
Maybe Arity
Nothing -> LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig
ar_env :: NameEnv Arity
ar_env :: NameEnv Arity
ar_env = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> NameEnv Arity -> NameEnv Arity)
-> NameEnv Arity
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> NameEnv Arity
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> NameEnv Arity -> NameEnv Arity
lhsBindArity NameEnv Arity
forall a. NameEnv a
emptyNameEnv LHsBinds GhcRn
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds
addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Arity
ar (L SrcSpanAnnA
l (InlineSig XInlineSig GhcRn
x LIdP GhcRn
nm InlinePragma
inl)) = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XInlineSig GhcRn -> LIdP GhcRn -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcRn
x LIdP GhcRn
nm (Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar InlinePragma
inl))
addInlinePragArity Arity
ar (L SrcSpanAnnA
l (SpecSig XSpecSig GhcRn
x LIdP GhcRn
nm [LHsSigType GhcRn]
ty InlinePragma
inl)) = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XSpecSig GhcRn
-> LIdP GhcRn -> [LHsSigType GhcRn] -> InlinePragma -> Sig GhcRn
forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass
SpecSig XSpecSig GhcRn
x LIdP GhcRn
nm [LHsSigType GhcRn]
ty (Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar InlinePragma
inl))
addInlinePragArity Arity
_ LSig GhcRn
sig = LSig GhcRn
sig
add_inl_arity :: Arity -> InlinePragma -> InlinePragma
add_inl_arity :: Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar prag :: InlinePragma
prag@(InlinePragma { inl_inline :: InlinePragma -> InlineSpec
inl_inline = InlineSpec
inl_spec })
| Inline {} <- InlineSpec
inl_spec
= InlinePragma
prag { inl_sat = Just ar }
| Bool
otherwise
= InlinePragma
prag
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
id, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
ms })) NameEnv Arity
env
= NameEnv Arity -> Name -> Arity -> NameEnv Arity
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv Arity
env (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
id) (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
ms)
lhsBindArity LHsBind GhcRn
_ NameEnv Arity
env = NameEnv Arity
env
addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prags_for_me
| inl :: GenLocated SrcSpanAnnA InlinePragma
inl@(L SrcSpanAnnA
_ InlinePragma
prag) : [GenLocated SrcSpanAnnA InlinePragma]
inls <- [GenLocated SrcSpanAnnA InlinePragma]
inl_prags
= do { String -> SDoc -> TcRn ()
traceTc String
"addInlinePrag" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ InlinePragma -> SDoc
forall a. Outputable a => a -> SDoc
ppr InlinePragma
prag)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA InlinePragma] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA InlinePragma]
inls) (GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
inl [GenLocated SrcSpanAnnA InlinePragma]
inls)
; TcId -> TcM TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
poly_id TcId -> InlinePragma -> TcId
`setInlinePragma` InlinePragma
prag) }
| Bool
otherwise
= TcId -> TcM TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
poly_id
where
inl_prags :: [GenLocated SrcSpanAnnA InlinePragma]
inl_prags = [SrcSpanAnnA -> InlinePragma -> GenLocated SrcSpanAnnA InlinePragma
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc InlinePragma
prag | L SrcSpanAnnA
loc (InlineSig XInlineSig GhcRn
_ LIdP GhcRn
_ InlinePragma
prag) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prags_for_me]
warn_multiple_inlines :: GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
_ [] = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
warn_multiple_inlines inl1 :: GenLocated SrcSpanAnnA InlinePragma
inl1@(L SrcSpanAnnA
loc InlinePragma
prag1) (inl2 :: GenLocated SrcSpanAnnA InlinePragma
inl2@(L SrcSpanAnnA
_ InlinePragma
prag2) : [GenLocated SrcSpanAnnA InlinePragma]
inls)
| InlinePragma -> Activation
inlinePragmaActivation InlinePragma
prag1 Activation -> Activation -> Bool
forall a. Eq a => a -> a -> Bool
== InlinePragma -> Activation
inlinePragmaActivation InlinePragma
prag2
, InlineSpec -> Bool
noUserInlineSpec (InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
prag1)
=
GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
inl2 [GenLocated SrcSpanAnnA InlinePragma]
inls
| Bool
otherwise
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
let dia :: TcRnMessage
dia = TcId
-> GenLocated SrcSpanAnnA InlinePragma
-> NonEmpty (GenLocated SrcSpanAnnA InlinePragma)
-> TcRnMessage
TcRnMultipleInlinePragmas TcId
poly_id GenLocated SrcSpanAnnA InlinePragma
inl1 (GenLocated SrcSpanAnnA InlinePragma
inl2 GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma]
-> NonEmpty (GenLocated SrcSpanAnnA InlinePragma)
forall a. a -> [a] -> NonEmpty a
NE.:| [GenLocated SrcSpanAnnA InlinePragma]
inls)
in TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia
tcSpecPrags :: Id -> [LSig GhcRn]
-> TcM [LTcSpecPrag]
tcSpecPrags :: TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig GhcRn]
prag_sigs
= do { String -> SDoc -> TcRn ()
traceTc String
"tcSpecPrags" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs)
; Maybe (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)))
-> (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ([GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Maybe (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs) NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ()
warn_discarded_sigs
; pss <- (GenLocated SrcSpanAnnA (Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag]))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> TcRn [GenLocated SrcSpanAnnA [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM ((Sig GhcRn -> TcM [TcSpecPrag])
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag])
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA (TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id)) [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs
; return $ concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> (TcSpecPrag -> LTcSpecPrag) -> [TcSpecPrag] -> [LTcSpecPrag]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) pss }
where
spec_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs = (GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecLSig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_sigs
bad_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs = (GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
is_bad_sig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_sigs
is_bad_sig :: XRec p (Sig p) -> Bool
is_bad_sig XRec p (Sig p)
s = Bool -> Bool
not (XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isInlineLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSCCFunSig XRec p (Sig p)
s)
warn_discarded_sigs :: NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ()
warn_discarded_sigs NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn))
bad_sigs_ne
= let dia :: TcRnMessage
dia = TcId -> NonEmpty (LSig GhcRn) -> TcRnMessage
TcRnUnexpectedPragmas TcId
poly_id NonEmpty (LSig GhcRn)
NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn))
bad_sigs_ne
in TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id prag :: Sig GhcRn
prag@(SpecSig XSpecSig GhcRn
_ LIdP GhcRn
fun_name [LHsSigType GhcRn]
hs_tys InlinePragma
inl)
= SDoc -> TcM [TcSpecPrag] -> TcM [TcSpecPrag]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
spec_ctxt Sig GhcRn
prag) (TcM [TcSpecPrag] -> TcM [TcSpecPrag])
-> TcM [TcSpecPrag] -> TcM [TcSpecPrag]
forall a b. (a -> b) -> a -> b
$
do { Bool -> TcRnMessage -> TcRn ()
warnIf (Bool -> Bool
not (Kind -> Bool
isOverloadedTy Kind
poly_ty Bool -> Bool -> Bool
|| InlinePragma -> Bool
isInlinePragma InlinePragma
inl)) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
LIdP GhcRn -> TcRnMessage
TcRnNonOverloadedSpecialisePragma LIdP GhcRn
fun_name
; spec_prags <- (GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag)
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)] -> TcM [TcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
hs_tys
; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
; return spec_prags }
where
name :: Name
name = TcId -> Name
idName TcId
poly_id
poly_ty :: Kind
poly_ty = TcId -> Kind
idType TcId
poly_id
spec_ctxt :: a -> SDoc
spec_ctxt a
prag = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the pragma:") Arity
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag)
tc_one :: GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
= do { spec_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Kind
tcHsSigType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
; return (SpecPrag poly_id wrap inl) }
tcSpecPrag TcId
_ Sig GhcRn
prag = String -> SDoc -> TcM [TcSpecPrag]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSpecPrag" (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
prag)
tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
tcSpecWrapper :: UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSpecWrapper UserTypeCtxt
ctxt Kind
poly_ty Kind
spec_ty
= do { (sk_wrap, inst_wrap)
<- DeepSubsumptionFlag
-> UserTypeCtxt
-> Kind
-> (Kind -> TcM HsWrapper)
-> TcM (HsWrapper, HsWrapper)
forall result.
DeepSubsumptionFlag
-> UserTypeCtxt
-> Kind
-> (Kind -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise DeepSubsumptionFlag
Shallow UserTypeCtxt
ctxt Kind
spec_ty ((Kind -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper))
-> (Kind -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \Kind
spec_tau ->
do { (inst_wrap, tau) <- CtOrigin -> Kind -> TcM (HsWrapper, Kind)
topInstantiate CtOrigin
orig Kind
poly_ty
; _ <- unifyType Nothing spec_tau tau
; return inst_wrap }
; return (sk_wrap <.> inst_wrap) }
where
orig :: CtOrigin
orig = UserTypeCtxt -> CtOrigin
SpecPragOrigin UserTypeCtxt
ctxt
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
tcImpPrags [LSig GhcRn]
prags
= do { this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; dflags <- getDynFlags
; if (not_specialising dflags) then
return []
else do
{ pss <- mapAndRecoverM (wrapLocMA tcImpSpec)
[L loc (name,prag)
| (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
, not (nameIsLocalOrFrom this_mod name) ]
; return $ concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> (TcSpecPrag -> LTcSpecPrag) -> [TcSpecPrag] -> [LTcSpecPrag]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) pss } }
where
not_specialising :: DynFlags -> Bool
not_specialising DynFlags
dflags =
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise DynFlags
dflags) Bool -> Bool -> Bool
|| Bool -> Bool
not (Backend -> Bool
backendRespectsSpecialise (DynFlags -> Backend
backend DynFlags
dflags))
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (Name
name, Sig GhcRn
prag)
= do { id <- Name -> TcM TcId
tcLookupId Name
name
; if hasSomeUnfolding (realIdUnfolding id)
then tcSpecPrag id prag
else do { let dia = Name -> TcRnMessage
TcRnSpecialiseNotVisible Name
name
; addDiagnosticTc dia
; return [] } }