{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Sig(
TcSigInfo(..),
TcIdSigInfo(..), TcIdSigInst,
TcPatSynInfo(..),
TcSigFun,
isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
completeSigPolyId_maybe, isCompleteHsSig,
lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,
tcTySigs, tcUserTypeSig, completeSigFromId,
tcInstSig,
TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags
) where
import GHC.Prelude
import GHC.Driver.Session
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 )
import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Unify( 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.Types.Error
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )
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.Utils.Trace
import GHC.Data.Maybe( orElse )
import Data.Maybe( mapMaybe )
import Control.Monad( unless )
tcIdSigName :: TcIdSigInfo -> Name
tcIdSigName :: TcIdSigInfo -> Name
tcIdSigName (CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
id }) = TcId -> Name
idName TcId
id
tcIdSigName (PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
n }) = Name
n
tcSigInfoName :: TcSigInfo -> Name
tcSigInfoName :: TcSigInfo -> Name
tcSigInfoName (TcIdSig TcIdSigInfo
idsi) = TcIdSigInfo -> Name
tcIdSigName TcIdSigInfo
idsi
tcSigInfoName (TcPatSynSig TcPatSynInfo
tpsi) = TcPatSynInfo -> Name
patsig_name TcPatSynInfo
tpsi
completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe TcSigInfo
sig
| TcIdSig TcIdSigInfo
sig_info <- TcSigInfo
sig
, CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
id } <- TcIdSigInfo
sig_info = TcId -> Maybe TcId
forall a. a -> Maybe a
Just TcId
id
| Bool
otherwise = Maybe TcId
forall a. Maybe a
Nothing
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 {
[[TcSigInfo]]
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]
ty_sigs = [[TcSigInfo]] -> [TcSigInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TcSigInfo]]
ty_sigs_s
poly_ids :: [TcId]
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 :: NameEnv TcSigInfo
env = [(Name, TcSigInfo)] -> NameEnv TcSigInfo
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(TcSigInfo -> Name
tcSigInfoName TcSigInfo
sig, TcSigInfo
sig) | TcSigInfo
sig <- [TcSigInfo]
ty_sigs]
; ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
poly_ids, NameEnv TcSigInfo -> TcSigFun
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcSigInfo
env) }
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
tcTySig :: LSig GhcRn -> TcRn [TcSigInfo]
tcTySig (L _ (IdSig _ id))
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt (TcId -> Name
idName TcId
id) ReportRedundantConstraints
NoRRC
sig :: TcIdSigInfo
sig = UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
; [TcSigInfo] -> TcRn [TcSigInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TcIdSigInfo -> TcSigInfo
TcIdSig TcIdSigInfo
sig] }
tcTySig (L loc (TypeSig _ names sig_ty))
= SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
do { [TcIdSigInfo]
sigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcIdSigInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
tcUserTypeSig (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' 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 ]
; [TcSigInfo] -> TcRn [TcSigInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ((TcIdSigInfo -> TcSigInfo) -> [TcIdSigInfo] -> [TcSigInfo]
forall a b. (a -> b) -> [a] -> [b]
map TcIdSigInfo -> TcSigInfo
TcIdSig [TcIdSigInfo]
sigs) }
tcTySig (L loc (PatSynSig _ names sig_ty))
= SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
do { [TcPatSynInfo]
tpsigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcPatSynInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig Name
name LHsSigType GhcRn
sig_ty
| L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names ]
; [TcSigInfo] -> TcRn [TcSigInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ((TcPatSynInfo -> TcSigInfo) -> [TcPatSynInfo] -> [TcSigInfo]
forall a b. (a -> b) -> [a] -> [b]
map TcPatSynInfo -> TcSigInfo
TcPatSynSig [TcPatSynInfo]
tpsigs) }
tcTySig LSig GhcRn
_ = [TcSigInfo] -> TcRn [TcSigInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
-> TcM TcIdSigInfo
tcUserTypeSig :: SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
hs_sig_ty Maybe Name
mb_name
| LHsSigWcType GhcRn -> Bool
isCompleteHsSig LHsSigWcType GhcRn
hs_sig_ty
= do { Type
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType UserTypeCtxt
ctxt_no_rrc LHsSigWcType GhcRn
hs_sig_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcuser" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sigma_ty)
; TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo)
-> TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall a b. (a -> b) -> a -> b
$
CompleteSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { sig_bndr :: TcId
sig_bndr = HasDebugCallStack => Name -> Type -> Type -> TcId
Name -> Type -> Type -> TcId
mkLocalId Name
name Type
Many Type
sigma_ty
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt_rrc
, sig_loc :: SrcSpan
sig_loc = SrcSpan
loc } }
| Bool
otherwise
= TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialSig :: Name
-> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
PartialSig { psig_name :: Name
psig_name = Name
name, psig_hs_ty :: LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_sig_ty
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt_no_rrc, sig_loc :: SrcSpan
sig_loc = SrcSpan
loc })
where
name :: Name
name = case Maybe Name
mb_name of
Just Name
n -> Name
n
Maybe Name
Nothing -> OccName -> Name
mkUnboundName (String -> OccName
mkVarOcc 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 _ HsSig { sig_body = sig_ty }) = GenLocated SrcSpanAnnA (HsType GhcRn) -> ReportRedundantConstraints
forall pass a l.
(XRec pass [XRec pass (HsType pass)]
~ GenLocated (SrcSpanAnn' a) [XRec pass (HsType pass)],
XRec pass (HsType pass) ~ GenLocated l (HsType pass)) =>
GenLocated l (HsType pass) -> ReportRedundantConstraints
go LHsType 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 span _ })) = SrcSpan -> ReportRedundantConstraints
WantRRC (SrcSpan -> ReportRedundantConstraints)
-> SrcSpan -> ReportRedundantConstraints
forall a b. (a -> b) -> a -> b
$ SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' 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 -> TcIdSigInfo
completeSigFromId :: UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
= CompleteSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { 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 (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 _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
= (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (HsOuterTyVarBndrs Specificity GhcRn
-> [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs)
Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
no_anon_wc_ty LHsType GhcRn
body
no_anon_wc_ty :: LHsType GhcRn -> Bool
no_anon_wc_ty :: LHsType GhcRn -> Bool
no_anon_wc_ty LHsType GhcRn
lty = GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType 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
_ LHsType GhcRn
ty1 LHsType GhcRn
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
HsAppKindTy XAppKindTy GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
ki -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ki
HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w LHsType GhcRn
ty1 LHsType GhcRn
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (HsArrow GhcRn -> LHsType GhcRn
arrowToHsType HsArrow GhcRn
w)
HsListTy XListTy GhcRn
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsTupleTy XTupleTy GhcRn
_ HsTupleSort
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsSumTy XSumTy GhcRn
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsOpTy XOpTy GhcRn
_ PromotionFlag
_ LHsType GhcRn
ty1 LIdP GhcRn
_ LHsType GhcRn
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
HsParTy XParTy GhcRn
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsIParamTy XIParamTy GhcRn
_ XRec GhcRn HsIPName
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsKindSig XKindSig GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
kind -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
kind
HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDoc GhcRn
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsBangTy XBangTy GhcRn
_ HsSrcBang
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType 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 -> 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
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType 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 = LHsType GhcRn
ty } -> HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele HsForAllTelescope GhcRn
tele
Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType 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 = LHsType 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 LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedTy HsType GhcRn
ty)) -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA HsType GhcRn
ty
HsSpliceTy{} -> 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 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 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 :: LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (L _ tvb) = case HsTyVarBndr flag GhcRn
tvb of
UserTyVar XUserTyVar GhcRn
_ flag
_ LIdP GhcRn
_ -> Bool
True
KindedTyVar XKindedTyVar GhcRn
_ flag
_ LIdP GhcRn
_ LHsType GhcRn
ki -> LHsType GhcRn -> Bool
no_anon_wc_ty LHsType GhcRn
ki
tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
tcPatSynSig :: Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig Name
name sig_ty :: LHsSigType GhcRn
sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty}))
| (Maybe (LHsContext GhcRn)
hs_req, LHsType GhcRn
hs_ty1) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
hs_ty
, ([LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs, Maybe (LHsContext GhcRn)
hs_prov, LHsType GhcRn
hs_body_ty) <- LHsType GhcRn
-> ([LHsTyVarBndr Specificity GhcRn], Maybe (LHsContext GhcRn),
LHsType GhcRn)
forall (p :: Pass).
LHsType (GhcPass p)
-> ([LHsTyVarBndr Specificity (GhcPass p)],
Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
splitLHsSigmaTyInvis LHsType 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)
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Name -> SkolemInfoAnon
DataConSkol Name
name)
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, ([VarBndr TcId Specificity]
ex_bndrs, ([Type]
req, [Type]
prov, Type
body_ty))))
<- String
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type))))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcPatSynSig" (TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type))))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterTyVarBndrs Specificity GhcRn
-> TcM ([VarBndr TcId Specificity], ([Type], [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterTyVarBndrs Specificity GhcRn
hs_outer_bndrs (TcM ([VarBndr TcId Specificity], ([Type], [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type))))
-> TcM ([VarBndr TcId Specificity], ([Type], [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([VarBndr TcId Specificity], ([Type], [Type], Type)))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> [LHsTyVarBndr Specificity GhcRn]
-> TcM ([Type], [Type], Type)
-> TcM ([VarBndr TcId Specificity], ([Type], [Type], Type))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TcId flag], a)
tcExplicitTKBndrs SkolemInfo
skol_info [LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs (TcM ([Type], [Type], Type)
-> TcM ([VarBndr TcId Specificity], ([Type], [Type], Type)))
-> TcM ([Type], [Type], Type)
-> TcM ([VarBndr TcId Specificity], ([Type], [Type], Type))
forall a b. (a -> b) -> a -> b
$
do { [Type]
req <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_req
; [Type]
prov <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_prov
; Type
body_ty <- LHsType GhcRn -> TcM Type
tcHsOpenType LHsType GhcRn
hs_body_ty
; ([Type], [Type], Type) -> TcM ([Type], [Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
req, [Type]
prov, Type
body_ty) }
; let implicit_tvs :: [TcTyVar]
univ_bndrs :: [TcInvisTVBinder]
([TcId]
implicit_tvs, [VarBndr TcId Specificity]
univ_bndrs) = case HsOuterTyVarBndrs Specificity GhcTc
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)
; [TcId]
implicit_tvs <- [TcId] -> TcM [TcId]
zonkAndScopedSort [TcId]
implicit_tvs
; let implicit_bndrs :: [VarBndr TcId Specificity]
implicit_bndrs = Specificity -> [TcId] -> [VarBndr TcId Specificity]
forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
SpecifiedSpec [TcId]
implicit_tvs
; let ungen_patsyn_ty :: Type
ungen_patsyn_ty = [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Type]
-> [VarBndr TcId Specificity]
-> [Type]
-> Type
-> Type
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs
[Type]
req [VarBndr TcId Specificity]
ex_bndrs [Type]
prov Type
body_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynSig" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ungen_patsyn_ty)
; [TcId]
kvs <- SkolemInfo -> Type -> TcM [TcId]
kindGeneralizeAll SkolemInfo
skol_info Type
ungen_patsyn_ty
; SkolemInfo -> [TcId] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TcId]
kvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [VarBndr TcId Specificity]
kv_bndrs) <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze (Specificity -> [TcId] -> [VarBndr TcId Specificity]
forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
InferredSpec [TcId]
kvs)
; (ZonkEnv
ze, [VarBndr TcId Specificity]
implicit_bndrs) <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TcId Specificity]
implicit_bndrs
; (ZonkEnv
ze, [VarBndr TcId Specificity]
univ_bndrs) <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TcId Specificity]
univ_bndrs
; (ZonkEnv
ze, [VarBndr TcId Specificity]
ex_bndrs) <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TcId Specificity]
ex_bndrs
; [Type]
req <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
req
; [Type]
prov <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
prov
; Type
body_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
body_ty
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Type -> TcRn ()) -> Type -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Type]
-> [VarBndr TcId Specificity]
-> [Type]
-> Type
-> Type
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs [Type]
req [VarBndr TcId Specificity]
ex_bndrs [Type]
prov Type
body_ty
; let ([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
body_ty
; (Scaled Type -> TcRn ()) -> [Scaled Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
(\(Scaled Type
_ Type
arg_ty) -> FixedRuntimeRepProvenance -> Type -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepPatSynSigArg Type
arg_ty)
[Scaled Type]
arg_tys
; FixedRuntimeRepProvenance -> Type -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepPatSynSigRes Type
res_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcTySig }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"kvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
kv_bndrs)
, String -> SDoc
text String
"implicit_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
implicit_bndrs)
, String -> SDoc
text String
"univ_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
univ_bndrs)
, String -> SDoc
text String
"req" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
req
, String -> SDoc
text String
"ex_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
ex_bndrs)
, String -> SDoc
text String
"prov" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
prov
, String -> SDoc
text String
"body_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty ]
; TcPatSynInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TPSI :: Name
-> [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Type]
-> [VarBndr TcId Specificity]
-> [Type]
-> Type
-> TcPatSynInfo
TPSI { patsig_name :: Name
patsig_name = Name
name
, patsig_implicit_bndrs :: [VarBndr TcId Specificity]
patsig_implicit_bndrs = [VarBndr TcId Specificity]
kv_bndrs [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr TcId Specificity]
implicit_bndrs
, patsig_univ_bndrs :: [VarBndr TcId Specificity]
patsig_univ_bndrs = [VarBndr TcId Specificity]
univ_bndrs
, patsig_req :: [Type]
patsig_req = [Type]
req
, patsig_ex_bndrs :: [VarBndr TcId Specificity]
patsig_ex_bndrs = [VarBndr TcId Specificity]
ex_bndrs
, patsig_prov :: [Type]
patsig_prov = [Type]
prov
, patsig_body_ty :: Type
patsig_body_ty = Type
body_ty }) }
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
PatSynCtxt Name
name
build_patsyn_type :: [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Type]
-> [VarBndr TcId Specificity]
-> [Type]
-> Type
-> Type
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs [Type]
req [VarBndr TcId Specificity]
ex_bndrs [Type]
prov Type
body
= [VarBndr TcId Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TcId Specificity]
implicit_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TcId Specificity]
univ_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
req (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TcId Specificity]
ex_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
prov (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
body
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs :: [TcId] -> SDoc
ppr_tvs [TcId]
tvs = SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Type
tyVarKind TcId
tv)
| TcId
tv <- [TcId]
tvs])
tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
tcInstSig sig :: TcIdSigInfo
sig@(CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id, sig_loc :: TcIdSigInfo -> 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 { ([(Name, VarBndr TcId Specificity)]
tv_prs, [Type]
theta, Type
tau) <- TcId -> TcM ([(Name, VarBndr TcId Specificity)], [Type], Type)
tcInstTypeBndrs TcId
poly_id
; TcIdSigInst -> TcM TcIdSigInst
forall (m :: * -> *) a. Monad m => a -> m a
return (TISI :: TcIdSigInfo
-> [(Name, VarBndr TcId Specificity)]
-> [Type]
-> Type
-> [(Name, TcId)]
-> Maybe Type
-> TcIdSigInst
TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig = TcIdSigInfo
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 = []
, sig_inst_wcx :: Maybe Type
sig_inst_wcx = Maybe Type
forall a. Maybe a
Nothing
, sig_inst_theta :: [Type]
sig_inst_theta = [Type]
theta
, sig_inst_tau :: Type
sig_inst_tau = Type
tau }) }
tcInstSig hs_sig :: TcIdSigInfo
hs_sig@(PartialSig { psig_hs_ty :: TcIdSigInfo -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty
, sig_ctxt :: TcIdSigInfo -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: TcIdSigInfo -> 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 { String -> SDoc -> TcRn ()
traceTc String
"Staring partial sig {" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
hs_sig)
; ([(Name, TcId)]
wcs, Maybe Type
wcx, [(Name, VarBndr TcId Specificity)]
tv_prs, [Type]
theta, Type
tau) <- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM
([(Name, TcId)], Maybe Type, [(Name, VarBndr TcId Specificity)],
[Type], Type)
tcHsPartialSigType UserTypeCtxt
ctxt LHsSigWcType GhcRn
hs_ty
; let inst_sig :: TcIdSigInst
inst_sig = TISI :: TcIdSigInfo
-> [(Name, VarBndr TcId Specificity)]
-> [Type]
-> Type
-> [(Name, TcId)]
-> Maybe Type
-> TcIdSigInst
TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig = TcIdSigInfo
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 Type
sig_inst_wcx = Maybe Type
wcx
, sig_inst_theta :: [Type]
sig_inst_theta = [Type]
theta
, sig_inst_tau :: Type
sig_inst_tau = Type
tau }
; String -> SDoc -> TcRn ()
traceTc String
"End partial sig }" (TcIdSigInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
inst_sig)
; TcIdSigInst -> TcM TcIdSigInst
forall (m :: * -> *) a. Monad m => a -> m a
return TcIdSigInst
inst_sig }
type TcPragEnv = NameEnv [LSig GhcRn]
emptyPragEnv :: TcPragEnv
emptyPragEnv :: TcPragEnv
emptyPragEnv = TcPragEnv
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 (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 (L l (SpecSig x lnm@(L _ nm) ty inl))
= (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ 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
lnm [LHsSigType GhcRn]
ty (Name -> InlinePragma -> InlinePragma
add_arity Name
nm InlinePragma
inl))
get_sig (L l (InlineSig x lnm@(L _ nm) inl))
= (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XInlineSig GhcRn -> LIdP GhcRn -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcRn
x LIdP GhcRn
lnm (Name -> InlinePragma -> InlinePragma
add_arity Name
nm InlinePragma
inl))
get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
= (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XSCCFunSig GhcRn
-> SourceText
-> LIdP GhcRn
-> Maybe (XRec GhcRn StringLiteral)
-> Sig GhcRn
forall pass.
XSCCFunSig pass
-> SourceText
-> LIdP pass
-> Maybe (XRec pass StringLiteral)
-> Sig pass
SCCFunSig XSCCFunSig GhcRn
x SourceText
st LIdP GhcRn
lnm Maybe (XRec GhcRn StringLiteral)
str)
get_sig LSig GhcRn
_ = Maybe (Name, LSig GhcRn)
forall a. Maybe a
Nothing
add_arity :: Name -> InlinePragma -> InlinePragma
add_arity Name
n InlinePragma
inl_prag
| InlinePragma -> Bool
isInlinePragma InlinePragma
inl_prag
= case NameEnv Arity -> Name -> Maybe Arity
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Arity
ar_env Name
n of
Just Arity
ar -> InlinePragma
inl_prag { inl_sat :: Maybe Arity
inl_sat = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
ar }
Maybe Arity
Nothing -> Bool -> String -> SDoc -> InlinePragma -> InlinePragma
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"mkPragEnv no arity" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) (InlinePragma -> InlinePragma) -> InlinePragma -> InlinePragma
forall a b. (a -> b) -> a -> b
$
InlinePragma
inl_prag
| Bool
otherwise
= InlinePragma
inl_prag
ar_env :: NameEnv Arity
ar_env :: NameEnv Arity
ar_env = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> NameEnv Arity -> NameEnv Arity)
-> NameEnv Arity
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> NameEnv Arity
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
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = 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
$$ 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (TcId
poly_id TcId -> InlinePragma -> TcId
`setInlinePragma` InlinePragma
prag) }
| Bool
otherwise
= TcId -> TcM TcId
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 (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. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Multiple INLINE pragmas for" SDoc -> SDoc -> SDoc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id)
Arity
2 ([SDoc] -> SDoc
vcat (String -> SDoc
text String
"Ignoring all but the first"
SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA InlinePragma -> SDoc)
-> [GenLocated SrcSpanAnnA InlinePragma] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA InlinePragma -> SDoc
forall a a. (Outputable a, Outputable a) => GenLocated a a -> SDoc
pp_inl (GenLocated SrcSpanAnnA InlinePragma
inl1GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma]
-> [GenLocated SrcSpanAnnA InlinePragma]
forall a. a -> [a] -> [a]
:GenLocated SrcSpanAnnA InlinePragma
inl2GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma]
-> [GenLocated SrcSpanAnnA InlinePragma]
forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA InlinePragma]
inls))))
in TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia
pp_inl :: GenLocated a a -> SDoc
pp_inl (L a
loc a
prag) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)
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
<+> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs) TcRn ()
warn_discarded_sigs
; [GenLocated SrcSpanAnnA [TcSpecPrag]]
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 (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id)) [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs
; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
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. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) [GenLocated SrcSpanAnnA [TcSpecPrag]]
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 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 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 :: TcRn ()
warn_discarded_sigs
= let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Discarding unexpected pragmas for" SDoc -> SDoc -> SDoc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id)
Arity
2 ([SDoc] -> SDoc
vcat ((GenLocated SrcSpanAnnA (Sig GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpanAnnA -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanAnnA -> SDoc)
-> (GenLocated SrcSpanAnnA (Sig GhcRn) -> SrcSpanAnnA)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Sig GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc) [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs)))
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 (Type -> Bool
isOverloadedTy Type
poly_ty Bool -> Bool -> Bool
|| InlinePragma -> Bool
isInlinePragma InlinePragma
inl)) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints
(String -> SDoc
text String
"SPECIALISE pragma for non-overloaded function"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcRn
GenLocated SrcSpanAnnN Name
fun_name))
; [TcSpecPrag]
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)
mapM GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
hs_tys
; String -> SDoc -> TcRn ()
traceTc String
"tcSpecPrag" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
$$ Arity -> SDoc -> SDoc
nest Arity
2 ([SDoc] -> SDoc
vcat ((TcSpecPrag -> SDoc) -> [TcSpecPrag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TcSpecPrag -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcSpecPrag]
spec_prags)))
; [TcSpecPrag] -> TcM [TcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [TcSpecPrag]
spec_prags }
where
name :: Name
name = TcId -> Name
idName TcId
poly_id
poly_ty :: Type
poly_ty = TcId -> Type
idType TcId
poly_id
spec_ctxt :: a -> SDoc
spec_ctxt a
prag = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
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 { Type
spec_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
; HsWrapper
wrap <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSpecWrapper (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name (LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty)) Type
poly_ty Type
spec_ty
; TcSpecPrag -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag TcId
poly_id HsWrapper
wrap InlinePragma
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 -> Type -> Type -> TcM HsWrapper
tcSpecWrapper UserTypeCtxt
ctxt Type
poly_ty Type
spec_ty
= do { (HsWrapper
sk_wrap, HsWrapper
inst_wrap)
<- UserTypeCtxt
-> Type -> (Type -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall result.
UserTypeCtxt
-> Type -> (Type -> TcM result) -> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
ctxt Type
spec_ty ((Type -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper))
-> (Type -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ Type
spec_tau ->
do { (HsWrapper
inst_wrap, Type
tau) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
poly_ty
; TcCoercionN
_ <- Maybe TypedThing -> Type -> Type -> TcM TcCoercionN
unifyType Maybe TypedThing
forall a. Maybe a
Nothing Type
spec_tau Type
tau
; HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
inst_wrap }
; HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
sk_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
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 { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if (DynFlags -> Bool
not_specialising DynFlags
dflags) then
[LTcSpecPrag] -> TcM [LTcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
{ [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss <- (GenLocated SrcSpanAnnA (Name, Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag]))
-> [GenLocated SrcSpanAnnA (Name, Sig GhcRn)]
-> TcRn [GenLocated SrcSpanAnnA [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (((Name, Sig GhcRn) -> TcM [TcSpecPrag])
-> GenLocated SrcSpanAnnA (Name, Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag])
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec)
[SrcSpanAnnA
-> (Name, Sig GhcRn) -> GenLocated SrcSpanAnnA (Name, Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Name
name,Sig GhcRn
prag)
| (L SrcSpanAnnA
loc prag :: Sig GhcRn
prag@(SpecSig XSpecSig GhcRn
_ (L _ name) [LHsSigType GhcRn]
_ InlinePragma
_)) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prags
, Bool -> Bool
not (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) ]
; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
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. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss } }
where
not_specialising :: DynFlags -> Bool
not_specialising DynFlags
dflags
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise DynFlags
dflags) = Bool
True
| Bool
otherwise = case DynFlags -> Backend
backend DynFlags
dflags of
Backend
NoBackend -> Bool
True
Backend
Interpreter -> Bool
True
Backend
_other -> Bool
False
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (Name
name, Sig GhcRn
prag)
= do { TcId
id <- Name -> TcM TcId
tcLookupId Name
name
; if Unfolding -> Bool
hasSomeUnfolding (TcId -> Unfolding
realIdUnfolding TcId
id)
then TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
id Sig GhcRn
prag
else do { let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (Name -> SDoc
impSpecErr Name
name)
; TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia
; [TcSpecPrag] -> TcM [TcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [] } }
impSpecErr :: Name -> SDoc
impSpecErr :: Name -> SDoc
impSpecErr Name
name
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"You cannot SPECIALISE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))
Arity
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"because its definition is not visible in this module"
, String -> SDoc
text String
"Hint: make sure" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is compiled with -O"
, String -> SDoc
text String
" and that" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has an INLINABLE pragma" ])
where
mod :: Module
mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name