{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Sig(
TcSigInfo(..),
TcIdSigInfo(..), TcIdSigInst,
TcPatSynInfo(..),
TcSigFun,
isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
completeSigPolyId_maybe, isCompleteHsSig,
tcTySigs, tcUserTypeSig, completeSigFromId,
tcInstSig,
TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
addInlinePrags, addInlinePragArity
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Unify( tcTopSkolemise, 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.Driver.Session
import GHC.Driver.Backend
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )
import GHC.Types.Id ( Id, idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
import GHC.Builtin.Names( mkUnboundName )
import GHC.Types.Basic
import GHC.Unit.Module( getModule )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Utils.Misc as Utils ( singleton )
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 = forall a. a -> Maybe a
Just TcId
id
| Bool
otherwise = forall a. Maybe a
Nothing
tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig GhcRn]
hs_sigs
= forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
do {
[[TcSigInfo]]
ty_sigs_s <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM LSig GhcRn -> TcM [TcSigInfo]
tcTySig [LSig GhcRn]
hs_sigs
; let ty_sigs :: [TcSigInfo]
ty_sigs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TcSigInfo]]
ty_sigs_s
poly_ids :: [TcId]
poly_ids = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcSigInfo -> Maybe TcId
completeSigPolyId_maybe [TcSigInfo]
ty_sigs
env :: NameEnv TcSigInfo
env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(TcSigInfo -> Name
tcSigInfoName TcSigInfo
sig, TcSigInfo
sig) | TcSigInfo
sig <- [TcSigInfo]
ty_sigs]
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
poly_ids, forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcSigInfo
env) }
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
tcTySig (L SrcSpanAnnA
_ (IdSig XIdSig GhcRn
_ TcId
id))
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt (TcId -> Name
idName TcId
id) Bool
False
sig :: TcIdSigInfo
sig = UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
; forall (m :: * -> *) a. Monad m => a -> m a
return [TcIdSigInfo -> TcSigInfo
TcIdSig TcIdSigInfo
sig] }
tcTySig (L SrcSpanAnnA
loc (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
sig_ty))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { [TcIdSigInfo]
sigs <- 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 (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigWcType GhcRn
sig_ty (forall a. a -> Maybe a
Just Name
name)
| L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
names ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map TcIdSigInfo -> TcSigInfo
TcIdSig [TcIdSigInfo]
sigs) }
tcTySig (L SrcSpanAnnA
loc (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
sig_ty))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { [TcPatSynInfo]
tpsigs <- 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]
names ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map TcPatSynInfo -> TcSigInfo
TcPatSynSig [TcPatSynInfo]
tpsigs) }
tcTySig LSig GhcRn
_ = 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 { Kind
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType UserTypeCtxt
ctxt_F LHsSigWcType GhcRn
hs_sig_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcuser" (forall a. Outputable a => a -> SDoc
ppr Kind
sigma_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
CompleteSig { sig_bndr :: TcId
sig_bndr = HasDebugCallStack => Name -> Kind -> Kind -> TcId
mkLocalId Name
name Kind
Many Kind
sigma_ty
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt_T
, sig_loc :: SrcSpan
sig_loc = SrcSpan
loc } }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (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_F, 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_F :: UserTypeCtxt
ctxt_F = case Maybe Name
mb_name of
Just Name
n -> Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
n Bool
False
Maybe Name
Nothing -> UserTypeCtxt
ExprSigCtxt
ctxt_T :: UserTypeCtxt
ctxt_T = case Maybe Name
mb_name of
Just Name
n -> Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
n Bool
True
Maybe Name
Nothing -> UserTypeCtxt
ExprSigCtxt
completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId :: UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
= CompleteSig { sig_bndr :: TcId
sig_bndr = TcId
id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = 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 })
= forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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 = LHsType GhcRn
body}))
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs 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
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
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty2
HsAppKindTy XAppKindTy GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
ki -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ki
HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w LHsType GhcRn
ty1 LHsType GhcRn
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType 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
ty
HsTupleTy XTupleTy GhcRn
_ HsTupleSort
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
tys
HsSumTy XSumTy GhcRn
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
tys
HsOpTy XOpTy GhcRn
_ LHsType GhcRn
ty1 LIdP GhcRn
_ LHsType GhcRn
ty2 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty2
HsParTy XParTy GhcRn
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty
HsIParamTy XIParamTy GhcRn
_ XRec GhcRn HsIPName
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty
HsKindSig XKindSig GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
kind -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
kind
HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDocString
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty
HsBangTy XBangTy GhcRn
_ HsSrcBang
_ LHsType GhcRn
ty -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty
HsRecTy XRecTy GhcRn
_ [LConDeclField GhcRn]
flds -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall pass. ConDeclField pass -> LBangType pass
cd_fld_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LConDeclField GhcRn]
flds
HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType GhcRn]
tys
HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [LHsType GhcRn]
tys -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [LHsType 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
ty
HsQualTy { hst_ctxt :: forall pass. HsType pass -> Maybe (LHsContext pass)
hst_ctxt = Maybe (LHsContext GhcRn)
ctxt
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty } -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
ctxt) Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go LHsType GhcRn
ty
HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedTy HsType GhcRn
ty)) -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L 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 = 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 } -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr () GhcRn]
ltvs
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcRn]
ltvs } -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr 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
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 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 = LHsType GhcRn
hs_ty}))
| (Maybe (LHsContext GhcRn)
hs_req, LHsType GhcRn
hs_ty1) <- 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) <- 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" (forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
sig_ty)
; let skol_info :: SkolemInfo
skol_info = Name -> SkolemInfo
DataConSkol Name
name
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, ([VarBndr TcId Specificity]
ex_bndrs, ([Kind]
req, [Kind]
prov, Kind
body_ty))))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcPatSynSig" forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TcId flag], a)
tcExplicitTKBndrs [LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs forall a b. (a -> b) -> a -> b
$
do { [Kind]
req <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsContext Maybe (LHsContext GhcRn)
hs_req
; [Kind]
prov <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsContext Maybe (LHsContext GhcRn)
hs_prov
; Kind
body_ty <- LHsType GhcRn -> TcM Kind
tcHsOpenType LHsType GhcRn
hs_body_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind]
req, [Kind]
prov, Kind
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} -> (XHsOuterImplicit GhcTc
implicit_tvs, [])
HsOuterExplicit{hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc Specificity
univ_bndrs} -> ([], XHsOuterExplicit GhcTc Specificity
univ_bndrs)
; [TcId]
implicit_tvs <- [TcId] -> TcM [TcId]
zonkAndScopedSort [TcId]
implicit_tvs
; let implicit_bndrs :: [VarBndr TcId Specificity]
implicit_bndrs = forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
SpecifiedSpec [TcId]
implicit_tvs
; let ungen_patsyn_ty :: Kind
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
; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynSig" (forall a. Outputable a => a -> SDoc
ppr Kind
ungen_patsyn_ty)
; [TcId]
kvs <- Kind -> TcM [TcId]
kindGeneralizeAll Kind
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) <- forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze (forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
InferredSpec [TcId]
kvs)
; (ZonkEnv
ze, [VarBndr TcId Specificity]
implicit_bndrs) <- 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) <- 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) <- forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TcId Specificity]
ex_bndrs
; [Kind]
req <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
req
; [Kind]
prov <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
prov
; Kind
body_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
body_ty
; UserTypeCtxt -> Kind -> TcRn ()
checkValidType UserTypeCtxt
ctxt forall a b. (a -> b) -> a -> b
$
[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
; let ([Scaled Kind]
arg_tys, Kind
_) = Kind -> ([Scaled Kind], Kind)
tcSplitFunTys Kind
body_ty
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Kind -> TcRn ()
checkForLevPoly SDoc
empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Scaled a -> a
scaledThing) [Scaled Kind]
arg_tys
; String -> SDoc -> TcRn ()
traceTc String
"tcTySig }" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"kvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs (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 (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 (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
univ_bndrs)
, String -> SDoc
text String
"req" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Kind]
req
, String -> SDoc
text String
"ex_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
ex_bndrs)
, String -> SDoc
text String
"prov" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Kind]
prov
, String -> SDoc
text String
"body_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
body_ty ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (TPSI { patsig_name :: Name
patsig_name = Name
name
, patsig_implicit_bndrs :: [VarBndr TcId Specificity]
patsig_implicit_bndrs = [VarBndr TcId Specificity]
kv_bndrs 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 :: [Kind]
patsig_req = [Kind]
req
, patsig_ex_bndrs :: [VarBndr TcId Specificity]
patsig_ex_bndrs = [VarBndr TcId Specificity]
ex_bndrs
, patsig_prov :: [Kind]
patsig_prov = [Kind]
prov
, patsig_body_ty :: Kind
patsig_body_ty = Kind
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 forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
univ_bndrs forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkPhiTy [Kind]
req forall a b. (a -> b) -> a -> b
$
[VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
ex_bndrs forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkPhiTy [Kind]
prov forall a b. (a -> b) -> a -> b
$
Kind
body
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs :: [TcId] -> SDoc
ppr_tvs [TcId]
tvs = SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TcId
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
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 })
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { ([(Name, VarBndr TcId Specificity)]
tv_prs, [Kind]
theta, Kind
tau) <- TcId -> TcM ([(Name, VarBndr TcId Specificity)], [Kind], Kind)
tcInstTypeBndrs TcId
poly_id
; forall (m :: * -> *) a. Monad m => a -> m a
return (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 Kind
sig_inst_wcx = forall a. Maybe a
Nothing
, sig_inst_theta :: [Kind]
sig_inst_theta = [Kind]
theta
, sig_inst_tau :: Kind
sig_inst_tau = Kind
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 })
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Staring partial sig {" (forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
hs_sig)
; ([(Name, TcId)]
wcs, Maybe Kind
wcx, [(Name, VarBndr TcId Specificity)]
tv_prs, [Kind]
theta, Kind
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 :: TcIdSigInst
inst_sig = 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 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 }
; String -> SDoc -> TcRn ()
traceTc String
"End partial sig }" (forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
inst_sig)
; forall (m :: * -> *) a. Monad m => a -> m a
return TcIdSigInst
inst_sig }
type TcPragEnv = NameEnv [LSig GhcRn]
emptyPragEnv :: TcPragEnv
emptyPragEnv :: TcPragEnv
emptyPragEnv = forall a. NameEnv a
emptyNameEnv
lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
n = forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcPragEnv
prag_fn Name
n 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) = forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) forall a. a -> [a]
Utils.singleton TcPragEnv
prag_fn Name
n LSig GhcRn
sig
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs LHsBinds GhcRn
binds
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
extendPragEnv forall a. NameEnv a
emptyNameEnv [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs
where
prs :: [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig [LSig 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
_)) = forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
sig)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (InlineSig XInlineSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) InlinePragma
_)) = forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
sig)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (SCCFunSig XSCCFunSig GhcRn
_ SourceText
_ (L SrcSpanAnnN
_ Name
nm) Maybe (XRec GhcRn StringLiteral)
_)) = forall a. a -> Maybe a
Just (Name
nm, LSig GhcRn
sig)
get_sig LSig 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 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 GenLocated SrcSpanAnnA (Sig GhcRn)
sig
Maybe Arity
Nothing -> GenLocated SrcSpanAnnA (Sig GhcRn)
sig
ar_env :: NameEnv Arity
ar_env :: NameEnv Arity
ar_env = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity forall a. NameEnv a
emptyNameEnv LHsBinds 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)) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (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)) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (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 :: Maybe Arity
inl_sat = forall a. a -> Maybe a
Just Arity
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
= forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv Arity
env (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
id) (forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr 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" (forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr InlinePragma
prag)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
poly_id TcId -> InlinePragma -> TcId
`setInlinePragma` InlinePragma
prag) }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return TcId
poly_id
where
inl_prags :: [GenLocated SrcSpanAnnA InlinePragma]
inl_prags = [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]
prags_for_me]
warn_multiple_inlines :: GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
_ [] = 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 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
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason
(SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Multiple INLINE pragmas for" SDoc -> SDoc -> 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"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
(Outputable a, Outputable a) =>
GenLocated a a -> SDoc
pp_inl (GenLocated SrcSpanAnnA InlinePragma
inl1forall a. a -> [a] -> [a]
:GenLocated SrcSpanAnnA InlinePragma
inl2forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA InlinePragma]
inls))))
pp_inl :: GenLocated a a -> SDoc
pp_inl (L a
loc a
prag) = forall a. Outputable a => a -> SDoc
ppr a
prag SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (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" (forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs) TcRn ()
warn_discarded_sigs
; [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (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
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss }
where
spec_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs = forall a. (a -> Bool) -> [a] -> [a]
filter forall p. UnXRec p => LSig p -> Bool
isSpecLSig [LSig GhcRn]
prag_sigs
bad_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs = forall a. (a -> Bool) -> [a] -> [a]
filter forall p. UnXRec p => LSig p -> Bool
is_bad_sig [LSig GhcRn]
prag_sigs
is_bad_sig :: XRec p (Sig p) -> Bool
is_bad_sig XRec p (Sig p)
s = Bool -> Bool
not (forall p. UnXRec p => LSig p -> Bool
isSpecLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| forall p. UnXRec p => LSig p -> Bool
isInlineLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| forall p. UnXRec p => LSig p -> Bool
isSCCFunSig XRec p (Sig p)
s)
warn_discarded_sigs :: TcRn ()
warn_discarded_sigs
= WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason
(SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Discarding unexpected pragmas for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcId
poly_id)
Arity
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc) [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs)))
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)
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall a. Outputable a => a -> SDoc
spec_ctxt Sig GhcRn
prag) forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> TcRn ()
warnIf (Bool -> Bool
not (Kind -> Bool
isOverloadedTy Kind
poly_ty Bool -> Bool -> Bool
|| InlinePragma -> Bool
isInlinePragma InlinePragma
inl))
(String -> SDoc
text String
"SPECIALISE pragma for non-overloaded function"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LIdP GhcRn
fun_name))
; [TcSpecPrag]
spec_prags <- 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]
hs_tys
; String -> SDoc -> TcRn ()
traceTc String
"tcSpecPrag" (forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
$$ Arity -> SDoc -> SDoc
nest Arity
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [TcSpecPrag]
spec_prags)))
; forall (m :: * -> *) a. Monad m => a -> m a
return [TcSpecPrag]
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
text String
"In the pragma:") Arity
2 (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 { Kind
spec_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Kind
tcHsSigType (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name Bool
False) GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
; HsWrapper
wrap <- UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSpecWrapper (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name Bool
True) Kind
poly_ty Kind
spec_ty
; 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 = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSpecPrag" (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 { (HsWrapper
sk_wrap, HsWrapper
inst_wrap)
<- forall result.
UserTypeCtxt
-> Kind -> (Kind -> TcM result) -> TcM (HsWrapper, result)
tcTopSkolemise UserTypeCtxt
ctxt Kind
spec_ty forall a b. (a -> b) -> a -> b
$ \ Kind
spec_tau ->
do { (HsWrapper
inst_wrap, Kind
tau) <- CtOrigin -> Kind -> TcM (HsWrapper, Kind)
topInstantiate CtOrigin
orig Kind
poly_ty
; TcCoercionN
_ <- Maybe SDoc -> Kind -> Kind -> TcM TcCoercionN
unifyType forall a. Maybe a
Nothing Kind
spec_tau Kind
tau
; forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
inst_wrap }
; 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 <- forall (m :: * -> *). HasModule m => m Module
getModule
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if (DynFlags -> Bool
not_specialising DynFlags
dflags) then
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
{ [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec)
[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 SrcSpanAnnN
_ Name
name) [LHsSigType GhcRn]
_ InlinePragma
_)) <- [LSig GhcRn]
prags
, Bool -> Bool
not (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) ]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (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 { WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Name -> SDoc
impSpecErr Name
name)
; 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 (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
<+> 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 (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
nameModule Name
name