{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,
rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType, rnHsTyLit, rnHsArrowWith,
HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind,
newTyVarNameRn,
rnConDeclFields,
lookupField, mkHsOpTyRn,
rnLTyVar,
rnScaledLHsType,
NegationHandling(..),
mkOpAppRn, mkNegAppRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars, filterInScopeM,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
nubL, nubN,
badKindSigErr
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType, checkThLocalTyName )
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.TyCon ( isKindName )
import GHC.Hs
import GHC.Rename.Env
import GHC.Rename.Doc
import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV
, typeAppErr, newLocalBndrRn, checkDupRdrNames
, checkShadowedRdrNames )
import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Ppr ( pprHsDocContext )
import GHC.Tc.Utils.Monad
import GHC.Unit.Module ( getModule )
import GHC.Types.Name.Reader
import GHC.Builtin.Names
import GHC.Types.Hint ( UntickedPromotedThing(..) )
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
import GHC.Types.FieldLabel
import GHC.Types.Error
import GHC.Utils.Misc
import GHC.Types.Fixity ( compareFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..) )
import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.List (nubBy, partition)
import Control.Monad
data HsPatSigTypeScoping
= AlwaysBind
| NeverBind
rnHsSigWcType :: HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType :: HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
doc (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body =
sig_ty :: LHsSigType GhcPs
sig_ty@(L SrcSpanAnnA
loc (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcPs
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcPs
body_ty })) })
= do { free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsSigType GhcPs -> FreeKiTyVars
extract_lhs_sig_ty LHsSigType GhcPs
sig_ty)
; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars
; let nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a l. Eq a => [GenLocated l a] -> [GenLocated l a]
nubL FreeKiTyVars
nwc_rdrs'
; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
do { (wcs, body_ty', fvs) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyType HsDocContext
doc FreeKiTyVars
nwc_rdrs LHsType GhcPs
body_ty
; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $
HsSig { sig_ext = noExtField
, sig_bndrs = outer_bndrs', sig_body = body_ty' }}
, fvs) } }
rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType :: forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType = TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigTyKi TypeOrKind
TypeLevel
rnHsPatSigKind :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigKind :: forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigKind = TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigTyKi TypeOrKind
KindLevel
rnHsPatSigTyKi :: TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigTyKi :: forall a.
TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigTyKi TypeOrKind
level HsPatSigTypeScoping
scoping HsDocContext
ctx HsPatSigType GhcPs
sig_ty HsPatSigType GhcRn -> RnM (a, FreeVars)
thing_inside
= do { ty_sig_okay <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)
; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty)
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [LocatedN a] -> [LocatedN a]
nubN FreeKiTyVars
nwc_rdrs'
implicit_bndrs = case HsPatSigTypeScoping
scoping of
HsPatSigTypeScoping
AlwaysBind -> FreeKiTyVars
tv_rdrs
HsPatSigTypeScoping
NeverBind -> []
; rnImplicitTvOccs Nothing implicit_bndrs $ \ [Name]
imp_tvs ->
do { (nwcs, pat_sig_ty', fvs1) <- TypeOrKind
-> HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyTyKi TypeOrKind
level HsDocContext
ctx FreeKiTyVars
nwc_rdrs LHsType GhcPs
pat_sig_ty
; let sig_names = HsPSRn { hsps_nwcs :: [Name]
hsps_nwcs = [Name]
nwcs, hsps_imp_tvs :: [Name]
hsps_imp_tvs = [Name]
imp_tvs }
sig_ty' = HsPS { hsps_ext :: XHsPS GhcRn
hsps_ext = XHsPS GhcRn
HsPSRn
sig_names, hsps_body :: LHsType GhcRn
hsps_body = LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
pat_sig_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
where
pat_sig_ty :: LHsType GhcPs
pat_sig_ty = HsPatSigType GhcPs -> LHsType GhcPs
forall (p :: Pass). HsPatSigType (GhcPass p) -> LHsType (GhcPass p)
hsPatSigType HsPatSigType GhcPs
sig_ty
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
ctxt (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType GhcPs
hs_ty })
= do { free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
hs_ty)
; (nwc_rdrs', _) <- partition_nwcs free_vars
; let nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a l. Eq a => [GenLocated l a] -> [GenLocated l a]
nubL FreeKiTyVars
nwc_rdrs'
; (wcs, hs_ty', fvs) <- rnWcBodyType ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext :: XHsWC GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
hswc_ext = [Name]
XHsWC GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
wcs, hswc_body :: GenLocated SrcSpanAnnA (HsType GhcRn)
hswc_body = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ty' }
; return (sig_ty', fvs) }
rnWcBodyType :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyType :: HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyType = TypeOrKind
-> HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyTyKi TypeOrKind
TypeLevel
rnWcBodyTyKi :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyTyKi :: TypeOrKind
-> HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBodyTyKi TypeOrKind
level HsDocContext
ctxt FreeKiTyVars
nwc_rdrs LHsType GhcPs
hs_ty
= do { nwcs <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn FreeKiTyVars
nwc_rdrs
; let env = RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
level
, rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnTypeBody
, rtke_nwcs :: FreeVars
rtke_nwcs = [Name] -> FreeVars
mkNameSet [Name]
nwcs
, rtke_ctxt :: HsDocContext
rtke_ctxt = HsDocContext
ctxt }
; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
rn_lty env hs_ty
; return (nwcs, hs_ty', fvs) }
where
rn_lty :: RnTyKiEnv
-> GenLocated (EpAnn ann) (HsType GhcPs)
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
rn_lty RnTyKiEnv
env (L EpAnn ann
loc HsType GhcPs
hs_ty)
= EpAnn ann
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars))
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$
do { (hs_ty', fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env HsType GhcPs
hs_ty
; return (L loc hs_ty', fvs) }
rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env (HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_body })
= HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) HsForAllTelescope GhcPs
tele ((HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars))
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsForAllTelescope GhcRn
tele' ->
do { (hs_body', fvs) <- RnTyKiEnv
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
forall {ann}.
RnTyKiEnv
-> GenLocated (EpAnn ann) (HsType GhcPs)
-> TcRn (GenLocated (EpAnn ann) (HsType GhcRn), FreeVars)
rn_lty RnTyKiEnv
env LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_body
; return (HsForAllTy { hst_xforall = noExtField
, hst_tele = tele', hst_body = hs_body' }
, fvs) }
rn_ty RnTyKiEnv
env (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L SrcSpanAnnC
cx [GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_ty })
| Just ([GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt1, GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ctxt_last) <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
([GenLocated SrcSpanAnnA (HsType GhcPs)],
GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. [a] -> Maybe ([a], a)
snocView [GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt
, L SrcSpanAnnA
lx (HsWildCardTy XWildCardTy GhcPs
_) <- LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
rn_top_constraint RnTyKiEnv
env) [GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt1
; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1
; let hs_ctxt' = [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_ctxt1' [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a. [a] -> [a] -> [a]
++ [SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lx (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcRn
NoExtField
noExtField)]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, hst_ctxt = L cx hs_ctxt'
, hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
| Bool
otherwise
= do { (hs_ctxt', fvs1) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
rn_top_constraint RnTyKiEnv
env) [GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, hst_ctxt = L cx hs_ctxt'
, hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
rn_ty RnTyKiEnv
env HsType GhcPs
hs_ty = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env HsType GhcPs
hs_ty
rn_top_constraint :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rn_top_constraint RnTyKiEnv
env = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env { rtke_what = RnTopConstraint })
checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
RnTyKiEnv
env HsContext GhcPs
hs_ctxt
= RnTyKiEnv -> Maybe Name -> Maybe BadAnonWildcardContext -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe Name
forall a. Maybe a
Nothing Maybe BadAnonWildcardContext
mb_bad
where
mb_bad :: Maybe BadAnonWildcardContext
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed RnTyKiEnv
env)
= BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just (BadAnonWildcardContext -> Maybe BadAnonWildcardContext)
-> BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a b. (a -> b) -> a -> b
$ SoleExtraConstraintWildcardAllowed -> BadAnonWildcardContext
ExtraConstraintWildcardNotAllowed
SoleExtraConstraintWildcardAllowed
SoleExtraConstraintWildcardNotAllowed
| DerivDeclCtx {} <- RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env
, Bool -> Bool
not ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
hs_ctxt)
= BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just (BadAnonWildcardContext -> Maybe BadAnonWildcardContext)
-> BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a b. (a -> b) -> a -> b
$ SoleExtraConstraintWildcardAllowed -> BadAnonWildcardContext
ExtraConstraintWildcardNotAllowed
SoleExtraConstraintWildcardAllowed
SoleExtraConstraintWildcardAllowed
| Bool
otherwise
= Maybe BadAnonWildcardContext
forall a. Maybe a
Nothing
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
RnTyKiEnv
env
= case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
TypeSigCtx {} -> Bool
True
ExprWithTySigCtx {} -> Bool
True
DerivDeclCtx {} -> Bool
True
StandaloneKindSigCtx {} -> Bool
False
HsDocContext
_ -> Bool
False
partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars)
partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
= do { wildcards_enabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedWildCards
; return $
if wildcards_enabled
then partition is_wildcard free_vars
else ([], free_vars) }
where
is_wildcard :: LocatedN RdrName -> Bool
is_wildcard :: GenLocated SrcSpanAnnN RdrName -> Bool
is_wildcard GenLocated SrcSpanAnnN RdrName
rdr = OccName -> Bool
startsWithUnderscore (RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
rdr))
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
ctx TypeOrKind
level
(L SrcSpanAnnA
loc sig_ty :: HsSigType GhcPs
sig_ty@(HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcPs
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcPs
body }))
= SrcSpanAnnA
-> RnM (LHsSigType GhcRn, FreeVars)
-> RnM (LHsSigType GhcRn, FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (RnM (LHsSigType GhcRn, FreeVars)
-> RnM (LHsSigType GhcRn, FreeVars))
-> RnM (LHsSigType GhcRn, FreeVars)
-> RnM (LHsSigType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceRn String
"rnHsSigType" (HsSigType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSigType GhcPs
sig_ty)
; case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
HsOuterExplicit{} -> RnTyKiEnv -> HsTypeOrSigType GhcPs -> TcRn ()
checkPolyKinds RnTyKiEnv
env (HsSigType GhcPs -> HsTypeOrSigType GhcPs
forall p. HsSigType p -> HsTypeOrSigType p
HsSigType HsSigType GhcPs
sig_ty)
HsOuterImplicit{} -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; imp_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (FreeKiTyVars -> RnM FreeKiTyVars)
-> FreeKiTyVars -> RnM FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
body
; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
do { (body', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
body
; return ( L loc $ HsSig { sig_ext = noExtField
, sig_bndrs = outer_bndrs', sig_body = body' }
, fvs ) } }
where
env :: RnTyKiEnv
env = HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctx TypeOrKind
level RnTyKiWhat
RnTypeBody
rnImplicitTvOccs :: Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvOccs :: forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvOccs Maybe assoc
mb_assoc FreeKiTyVars
implicit_vs_with_dups [Name] -> RnM (a, FreeVars)
thing_inside
= do { let implicit_vs :: FreeKiTyVars
implicit_vs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [LocatedN a] -> [LocatedN a]
nubN FreeKiTyVars
implicit_vs_with_dups
; String -> SDoc -> TcRn ()
traceRn String
"rnImplicitTvOccs" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ FreeKiTyVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeKiTyVars
implicit_vs_with_dups, FreeKiTyVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeKiTyVars
implicit_vs ]
; loc <- TcRn SrcSpan
getSrcSpanM
; let loc' = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
; vars <- mapM (newTyVarNameRnImplicit mb_assoc . L loc' . unLoc) implicit_vs
; bindLocalNamesFV vars $
thing_inside vars }
data RnTyKiEnv
= RTKE { RnTyKiEnv -> HsDocContext
rtke_ctxt :: HsDocContext
, RnTyKiEnv -> TypeOrKind
rtke_level :: TypeOrKind
, RnTyKiEnv -> RnTyKiWhat
rtke_what :: RnTyKiWhat
, RnTyKiEnv -> FreeVars
rtke_nwcs :: NameSet
}
data RnTyKiWhat = RnTypeBody
| RnTopConstraint
| RnConstraint
instance Outputable RnTyKiEnv where
ppr :: RnTyKiEnv -> SDoc
ppr (RTKE { rtke_level :: RnTyKiEnv -> TypeOrKind
rtke_level = TypeOrKind
lev, rtke_what :: RnTyKiEnv -> RnTyKiWhat
rtke_what = RnTyKiWhat
what
, rtke_nwcs :: RnTyKiEnv -> FreeVars
rtke_nwcs = FreeVars
wcs, rtke_ctxt :: RnTyKiEnv -> HsDocContext
rtke_ctxt = HsDocContext
ctxt })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RTKE"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ TypeOrKind -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeOrKind
lev, RnTyKiWhat -> SDoc
forall a. Outputable a => a -> SDoc
ppr RnTyKiWhat
what, FreeVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeVars
wcs
, HsDocContext -> SDoc
pprHsDocContext HsDocContext
ctxt ])
instance Outputable RnTyKiWhat where
ppr :: RnTyKiWhat -> SDoc
ppr RnTyKiWhat
RnTypeBody = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RnTypeBody"
ppr RnTyKiWhat
RnTopConstraint = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RnTopConstraint"
ppr RnTyKiWhat
RnConstraint = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RnConstraint"
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
cxt TypeOrKind
level RnTyKiWhat
what
= RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
level, rtke_nwcs :: FreeVars
rtke_nwcs = FreeVars
emptyNameSet
, rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
what, rtke_ctxt :: HsDocContext
rtke_ctxt = HsDocContext
cxt }
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel (RTKE { rtke_level :: RnTyKiEnv -> TypeOrKind
rtke_level = TypeOrKind
KindLevel }) = Bool
True
isRnKindLevel RnTyKiEnv
_ = Bool
False
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
ty = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) LHsType GhcPs
ty
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes :: HsDocContext -> HsContext GhcPs -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes HsDocContext
doc HsContext GhcPs
tys = (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc) HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType :: HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc (HsScaled HsArrow GhcPs
w LHsType GhcPs
ty) = do
(w' , fvs_w) <- RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
doc TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) HsArrow GhcPs
w
(ty', fvs) <- rnLHsType doc ty
return (HsScaled w' ty', fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType HsDocContext
ctxt HsType GhcPs
ty = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) HsType GhcPs
ty
rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
rnLHsKind :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
ctxt LHsType GhcPs
kind = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
KindLevel RnTyKiWhat
RnTypeBody) LHsType GhcPs
kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg :: HsDocContext
-> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg HsDocContext
ctxt (HsValArg XValArg GhcPs
_ LHsType GhcPs
ty)
= do { (tys_rn, fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
ty
; return (HsValArg noExtField tys_rn, fvs) }
rnLHsTypeArg HsDocContext
ctxt (HsTypeArg XTypeArg GhcPs
_ LHsType GhcPs
ki)
= do { (kis_rn, fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
ctxt LHsType GhcPs
ki
; return (HsTypeArg noExtField kis_rn, fvs) }
rnLHsTypeArg HsDocContext
_ (HsArgPar XArgPar GhcPs
sp)
= (HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn)),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn)),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XArgPar GhcRn
-> HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall p tm ty. XArgPar p -> HsArg p tm ty
HsArgPar XArgPar GhcPs
XArgPar GhcRn
sp, FreeVars
emptyFVs)
rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
-> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs :: HsDocContext
-> [LHsTypeArg GhcPs] -> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs HsDocContext
doc [LHsTypeArg GhcPs]
args = (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn)),
FreeVars))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> RnM
([HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))],
FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsDocContext
-> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg HsDocContext
doc) [LHsTypeArg GhcPs]
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
args
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env (L SrcSpanAnnC
loc [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt)
= do { String -> SDoc -> TcRn ()
traceRn String
"rncontext" ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt)
; let env' :: RnTyKiEnv
env' = RnTyKiEnv
env { rtke_what = RnConstraint }
; (cxt', fvs) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env') [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt
; return (L loc cxt', fvs) }
rnContext :: HsDocContext -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnContext :: HsDocContext
-> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnContext HsDocContext
doc LHsContext GhcPs
theta = RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
doc TypeOrKind
TypeLevel RnTyKiWhat
RnConstraint) LHsContext GhcPs
theta
rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext :: HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext HsDocContext
_ Maybe (LHsContext GhcPs)
Nothing = (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
forall a. Maybe a
Nothing, FreeVars
emptyFVs)
rnMaybeContext HsDocContext
doc (Just LHsContext GhcPs
theta)
= do { (theta', fvs) <- HsDocContext
-> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnContext HsDocContext
doc LHsContext GhcPs
theta
; return (Just theta', fvs)
}
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env (L SrcSpanAnnA
loc HsType GhcPs
ty)
= SrcSpanAnnA
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
do { (ty', fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env HsType GhcPs
ty
; return (L loc ty', fvs) }
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
tau })
= do { RnTyKiEnv -> HsTypeOrSigType GhcPs -> TcRn ()
checkPolyKinds RnTyKiEnv
env (HsType GhcPs -> HsTypeOrSigType GhcPs
forall p. HsType p -> HsTypeOrSigType p
HsType HsType GhcPs
ty)
; HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) HsForAllTelescope GhcPs
tele ((HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars))
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsForAllTelescope GhcRn
tele' ->
do { (tau', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
; return ( HsForAllTy { hst_xforall = noExtField
, hst_tele = tele' , hst_body = tau' }
, fvs) } }
rnHsTyKi RnTyKiEnv
env (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcPs
lctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
tau })
= do {
(ctxt', fvs1) <- RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env LHsContext GhcPs
lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'
, hst_body = tau' }
, fvs1 `plusFV` fvs2) }
rnHsTyKi RnTyKiEnv
env tv :: HsType GhcPs
tv@(HsTyVar XTyVar GhcPs
_ PromotionFlag
ip (L SrcSpanAnnN
loc RdrName
rdr_name))
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env Bool -> Bool -> Bool
&& RdrName -> Bool
isRdrTyVar RdrName
rdr_name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.PolyKinds (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
RdrName -> TcRnMessage
TcRnUnexpectedKindVar RdrName
rdr_name
; name <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
rdr_name
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalTyName name
; when (isDataConName name && not (isKindName name)) $
checkDataKinds env tv
; when (isDataConName name && not (isPromoted ip)) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
; return (HsTyVar noAnn ip (L loc name), unitFV name) }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsOpTy XOpTy GhcPs
_ PromotionFlag
prom LHsType GhcPs
ty1 LIdP GhcPs
l_op LHsType GhcPs
ty2)
= SrcSpan
-> RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
l_op) (RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
do { (l_op', fvs1) <- RnTyKiEnv
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name, FreeVars)
rnHsTyOp RnTyKiEnv
env (HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcPs
ty) LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
l_op
; let op_name = GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
l_op'
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'
; when (isDataConName op_name && not (isPromoted prom)) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi RnTyKiEnv
env (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)
= do { (ty', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; return (HsParTy noAnn ty', fvs) }
rnHsTyKi RnTyKiEnv
env (HsBangTy XBangTy GhcPs
x HsBang
b LHsType GhcPs
ty)
= do { (ty', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; return (HsBangTy x b ty', fvs) }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
flds)
= do { let ctxt :: HsDocContext
ctxt = RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env
; fls <- HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields HsDocContext
ctxt
; (flds', fvs) <- rnConDeclFields ctxt fls flds
; return (HsRecTy noExtField flds', fvs) }
where
get_fields :: HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields ctxt :: HsDocContext
ctxt@(ConDeclCtx [GenLocated SrcSpanAnnN Name]
names)
= do res <- (GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (HasDebugCallStack =>
Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
lookupConstructorFields (Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> (GenLocated SrcSpanAnnN Name -> Name)
-> GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN Name]
names
if equalLength res names
then return res
else err ctxt
get_fields HsDocContext
ctxt = HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
err HsDocContext
ctxt
err :: HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
err HsDocContext
ctxt =
do { TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
ctxt (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage
TcRnIllegalRecordSyntax (HsType GhcPs -> Either (HsType GhcPs) (HsType GhcRn)
forall a b. a -> Either a b
Left HsType GhcPs
ty)
; [FieldLabel] -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
rnHsTyKi RnTyKiEnv
env (HsFunTy XFunTy GhcPs
u HsArrow GhcPs
mult LHsType GhcPs
ty1 LHsType GhcPs
ty2)
= do { (ty1', fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; (mult', w_fvs) <- rnHsArrow env mult
; return (HsFunTy u mult' ty1' ty2'
, plusFVs [fvs1, fvs2, w_fvs]) }
rnHsTyKi RnTyKiEnv
env listTy :: HsType GhcPs
listTy@(HsListTy XListTy GhcPs
x LHsType GhcPs
ty)
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
listTy
; (ty', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; return (HsListTy x ty', fvs) }
rnHsTyKi RnTyKiEnv
env (HsKindSig XKindSig GhcPs
x LHsType GhcPs
ty LHsType GhcPs
k)
= do { kind_sigs_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) k)
; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
; (ty', lhs_fvs) <- bindSigTyVarsFV (hsScopedKvs k') $
rnLHsTyKi env ty
; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) }
rnHsTyKi RnTyKiEnv
env tupleTy :: HsType GhcPs
tupleTy@(HsTupleTy XTupleTy GhcPs
x HsTupleSort
tup_con HsContext GhcPs
tys)
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
tupleTy
; (tys', fvs) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
; return (HsTupleTy x tup_con tys', fvs) }
rnHsTyKi RnTyKiEnv
env sumTy :: HsType GhcPs
sumTy@(HsSumTy XSumTy GhcPs
x HsContext GhcPs
tys)
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
sumTy
; (tys', fvs) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
; return (HsSumTy x tys', fvs) }
rnHsTyKi RnTyKiEnv
env tyLit :: HsType GhcPs
tyLit@(HsTyLit XTyLit GhcPs
src HsTyLit GhcPs
t)
= do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
tyLit
; t' <- HsTyLit GhcPs -> RnM (HsTyLit GhcRn)
rnHsTyLit HsTyLit GhcPs
t
; return (HsTyLit src t', emptyFVs) }
rnHsTyKi RnTyKiEnv
env (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2)
= do { (ty1', fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi RnTyKiEnv
env (HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k)
= do { kind_app <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr KindLevel k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi RnTyKiEnv
env t :: HsType GhcPs
t@(HsIParamTy XIParamTy GhcPs
x XRec GhcPs HsIPName
n LHsType GhcPs
ty)
= do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
notInKinds RnTyKiEnv
env HsType GhcPs
t
; (ty', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; return (HsIParamTy x n ty', fvs) }
rnHsTyKi RnTyKiEnv
_ (HsStarTy XStarTy GhcPs
_ Bool
isUni)
= (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XStarTy GhcRn -> Bool -> HsType GhcRn
forall pass. XStarTy pass -> Bool -> HsType pass
HsStarTy XStarTy GhcRn
NoExtField
noExtField Bool
isUni, FreeVars
emptyFVs)
rnHsTyKi RnTyKiEnv
_ (HsSpliceTy XSpliceTy GhcPs
_ HsUntypedSplice GhcPs
sp)
= HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType HsUntypedSplice GhcPs
sp
rnHsTyKi RnTyKiEnv
env (HsDocTy XDocTy GhcPs
x LHsType GhcPs
ty LHsDoc GhcPs
haddock_doc)
= do { (ty', fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; haddock_doc' <- rnLHsDoc haddock_doc
; return (HsDocTy x ty' haddock_doc', fvs) }
rnHsTyKi RnTyKiEnv
env (XHsType XXType GhcPs
ty)
= do (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RdrName -> TcRn ()
check_in_scope (RdrName -> TcRn ()) -> (Name -> RdrName) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName) [Name]
fvs_list
(HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType XXType GhcPs
XXType GhcRn
ty, FreeVars
fvs)
where
fvs_list :: [Name]
fvs_list = (TyCoVar -> Name) -> [TyCoVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Name
forall a. NamedThing a => a -> Name
getName ([TyCoVar] -> [Name]) -> [TyCoVar] -> [Name]
forall a b. (a -> b) -> a -> b
$ Type -> [TyCoVar]
tyCoVarsOfTypeList XXType GhcPs
Type
ty
fvs :: FreeVars
fvs = [Name] -> FreeVars
mkFVs [Name]
fvs_list
check_in_scope :: RdrName -> RnM ()
check_in_scope :: RdrName -> TcRn ()
check_in_scope RdrName
rdr_name = do
mb_name <- RdrName -> RnM (Maybe Name)
lookupLocalOccRn_maybe RdrName
rdr_name
when (isNothing mb_name) $
addErr $
TcRnWithHsDocContext (rtke_ctxt env) $
TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] []
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
ip HsContext GhcPs
tys)
= do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
ty
; (tys', fvs) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
; unless (isPromoted ip) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
; return (HsExplicitListTy noExtField ip tys', fvs) }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
tys)
= do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
ty
; (tys', fvs) <- (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
; return (HsExplicitTupleTy noExtField tys', fvs) }
rnHsTyKi RnTyKiEnv
env (HsWildCardTy XWildCardTy GhcPs
_)
= do { RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcRn
NoExtField
noExtField, FreeVars
emptyFVs) }
rnHsTyLit :: HsTyLit GhcPs -> RnM (HsTyLit GhcRn)
rnHsTyLit :: HsTyLit GhcPs -> RnM (HsTyLit GhcRn)
rnHsTyLit (HsStrTy XStrTy GhcPs
x FastString
s) = HsTyLit GhcRn -> RnM (HsTyLit GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XStrTy GhcRn -> FastString -> HsTyLit GhcRn
forall pass. XStrTy pass -> FastString -> HsTyLit pass
HsStrTy XStrTy GhcPs
XStrTy GhcRn
x FastString
s)
rnHsTyLit tyLit :: HsTyLit GhcPs
tyLit@(HsNumTy XNumTy GhcPs
x Integer
i) = do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsTyLit GhcPs -> TcRnMessage
TcRnNegativeNumTypeLiteral HsTyLit GhcPs
tyLit
HsTyLit GhcRn -> RnM (HsTyLit GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XNumTy GhcRn -> Integer -> HsTyLit GhcRn
forall pass. XNumTy pass -> Integer -> HsTyLit pass
HsNumTy XNumTy GhcPs
XNumTy GhcRn
x Integer
i)
rnHsTyLit (HsCharTy XCharTy GhcPs
x Char
c) = HsTyLit GhcRn -> RnM (HsTyLit GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XCharTy GhcRn -> Char -> HsTyLit GhcRn
forall pass. XCharTy pass -> Char -> HsTyLit pass
HsCharTy XCharTy GhcPs
XCharTy GhcRn
x Char
c)
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow RnTyKiEnv
env = (GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn, FreeVars)
forall (mult :: * -> *).
(LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
-> HsArrowOf (LocatedA (mult GhcPs)) GhcPs
-> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
rnHsArrowWith (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env)
rnHsArrowWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
-> HsArrowOf (LocatedA (mult GhcPs)) GhcPs
-> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
rnHsArrowWith :: forall (mult :: * -> *).
(LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
-> HsArrowOf (LocatedA (mult GhcPs)) GhcPs
-> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
rnHsArrowWith LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)
_rn (HsUnrestrictedArrow XUnrestrictedArrow (LocatedA (mult GhcPs)) GhcPs
_) = (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XUnrestrictedArrow (LocatedA (mult GhcRn)) GhcRn
-> HsArrowOf (LocatedA (mult GhcRn)) GhcRn
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow (LocatedA (mult GhcRn)) GhcRn
noExtField, FreeVars
emptyFVs)
rnHsArrowWith LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)
_rn (HsLinearArrow XLinearArrow (LocatedA (mult GhcPs)) GhcPs
_) = (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLinearArrow (LocatedA (mult GhcRn)) GhcRn
-> HsArrowOf (LocatedA (mult GhcRn)) GhcRn
forall mult pass. XLinearArrow mult pass -> HsArrowOf mult pass
HsLinearArrow NoExtField
XLinearArrow (LocatedA (mult GhcRn)) GhcRn
noExtField, FreeVars
emptyFVs)
rnHsArrowWith LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)
rn (HsExplicitMult XExplicitMult (LocatedA (mult GhcPs)) GhcPs
_ LocatedA (mult GhcPs)
p)
= (\(LocatedA (mult GhcRn)
mult, FreeVars
fvs) -> (XExplicitMult (LocatedA (mult GhcRn)) GhcRn
-> LocatedA (mult GhcRn) -> HsArrowOf (LocatedA (mult GhcRn)) GhcRn
forall mult pass.
XExplicitMult mult pass -> mult -> HsArrowOf mult pass
HsExplicitMult NoExtField
XExplicitMult (LocatedA (mult GhcRn)) GhcRn
noExtField LocatedA (mult GhcRn)
mult, FreeVars
fvs)) ((LocatedA (mult GhcRn), FreeVars)
-> (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars))
-> RnM (LocatedA (mult GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)
rn LocatedA (mult GhcPs)
p
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar :: RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
rdr_name
= do { name <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
rdr_name
; checkNamedWildCard env name
; return name }
rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
rnLTyVar :: GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar (L SrcSpanAnnN
loc RdrName
rdr_name)
= do { tyvar <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
rdr_name
; return (L loc tyvar) }
rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName
-> RnM (LocatedN Name, FreeVars)
rnHsTyOp :: RnTyKiEnv
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name, FreeVars)
rnHsTyOp RnTyKiEnv
env SDoc
overall_ty (L SrcSpanAnnN
loc RdrName
op)
= do { op' <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
op
; unlessXOptM LangExt.TypeOperators $
if (op' `hasKey` eqTyConKey)
then addDiagnostic TcRnTypeEqualityRequiresOperators
else addErr $ TcRnIllegalTypeOperator overall_ty op
; return (L loc op', unitFV op') }
checkWildCard :: RnTyKiEnv
-> Maybe Name
-> Maybe BadAnonWildcardContext
-> RnM ()
checkWildCard :: RnTyKiEnv -> Maybe Name -> Maybe BadAnonWildcardContext -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe Name
mb_name (Just BadAnonWildcardContext
bad)
= TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Maybe Name -> BadAnonWildcardContext -> TcRnMessage
TcRnIllegalWildcardInType Maybe Name
mb_name BadAnonWildcardContext
bad
checkWildCard RnTyKiEnv
_ Maybe Name
_ Maybe BadAnonWildcardContext
Nothing
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAnonWildCard :: RnTyKiEnv -> RnM ()
checkAnonWildCard :: RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
= RnTyKiEnv -> Maybe Name -> Maybe BadAnonWildcardContext -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe Name
forall a. Maybe a
Nothing Maybe BadAnonWildcardContext
mb_bad
where
mb_bad :: Maybe BadAnonWildcardContext
mb_bad :: Maybe BadAnonWildcardContext
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
= BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just BadAnonWildcardContext
WildcardsNotAllowedAtAll
| Bool
otherwise
= case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
RnTyKiWhat
RnTypeBody -> Maybe BadAnonWildcardContext
forall a. Maybe a
Nothing
RnTyKiWhat
RnTopConstraint -> BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just BadAnonWildcardContext
WildcardNotLastInConstraint
RnTyKiWhat
RnConstraint -> BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just BadAnonWildcardContext
WildcardNotLastInConstraint
checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
checkNamedWildCard :: RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
= RnTyKiEnv -> Maybe Name -> Maybe BadAnonWildcardContext -> TcRn ()
checkWildCard RnTyKiEnv
env (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Maybe BadAnonWildcardContext
mb_bad
where
mb_bad :: Maybe BadAnonWildcardContext
mb_bad | Bool -> Bool
not (Name
name Name -> FreeVars -> Bool
`elemNameSet` RnTyKiEnv -> FreeVars
rtke_nwcs RnTyKiEnv
env)
= Maybe BadAnonWildcardContext
forall a. Maybe a
Nothing
| Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
= BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just BadAnonWildcardContext
WildcardsNotAllowedAtAll
| Bool
otherwise
= case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
RnTyKiWhat
RnTypeBody -> Maybe BadAnonWildcardContext
forall a. Maybe a
Nothing
RnTyKiWhat
RnTopConstraint -> Maybe BadAnonWildcardContext
forall a. Maybe a
Nothing
RnTyKiWhat
RnConstraint -> BadAnonWildcardContext -> Maybe BadAnonWildcardContext
forall a. a -> Maybe a
Just BadAnonWildcardContext
WildcardNotLastInConstraint
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env
= case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
TypeSigCtx {} -> Bool
True
TypBrCtx {} -> Bool
True
SpliceTypeCtx {} -> Bool
True
ExprWithTySigCtx {} -> Bool
True
PatCtx {} -> Bool
True
RuleCtx {} -> Bool
True
FamPatCtx {} -> Bool
True
GHCiCtx {} -> Bool
True
HsTypeCtx {} -> Bool
True
StandaloneKindSigCtx {} -> Bool
False
HsDocContext
_ -> Bool
False
checkPolyKinds :: RnTyKiEnv
-> HsTypeOrSigType GhcPs
-> RnM ()
checkPolyKinds :: RnTyKiEnv -> HsTypeOrSigType GhcPs -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsTypeOrSigType GhcPs
ty
| RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
= do { polykinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; unless polykinds $
addErr $ TcRnIllegalKind ty True }
checkPolyKinds RnTyKiEnv
_ HsTypeOrSigType GhcPs
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notInKinds :: RnTyKiEnv
-> HsType GhcPs
-> RnM ()
notInKinds :: RnTyKiEnv -> HsType GhcPs -> TcRn ()
notInKinds RnTyKiEnv
env HsType GhcPs
ty
| RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
= TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsTypeOrSigType GhcPs -> Bool -> TcRnMessage
TcRnIllegalKind (HsType GhcPs -> HsTypeOrSigType GhcPs
forall p. HsType p -> HsTypeOrSigType p
HsType HsType GhcPs
ty) Bool
False
notInKinds RnTyKiEnv
_ HsType GhcPs
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV :: forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV [Name]
tvs RnM (a, FreeVars)
thing_inside
= do { scoped_tyvars <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
; if not scoped_tyvars then
thing_inside
else
bindLocalNamesFV tvs thing_inside }
bindHsQTyVars :: forall a b.
HsDocContext
-> Maybe (a, [Name])
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars :: forall a b.
HsDocContext
-> Maybe (a, [Name])
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe (a, [Name])
mb_assoc FreeKiTyVars
body_kv_occs LHsQTyVars GhcPs
hsq_bndrs LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars)
thing_inside
= do { let bndr_kv_occs :: FreeKiTyVars
bndr_kv_occs = [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
hs_tv_bndrs
; let
bndrs, all_implicit_kvs :: [LocatedN RdrName]
bndrs :: FreeKiTyVars
bndrs = (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
-> FreeKiTyVars
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsTyVarBndr (HsBndrVis GhcPs) GhcPs
-> Maybe (LocatedN (IdP GhcPs))
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName)
forall (p :: Pass) flag.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))
hsLTyVarLocName [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
hs_tv_bndrs
all_implicit_kvs :: FreeKiTyVars
all_implicit_kvs = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
FreeKiTyVars
bndr_kv_occs FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
body_kv_occs
body_remaining :: FreeKiTyVars
body_remaining = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndr_kv_occs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs FreeKiTyVars
body_kv_occs
; implicit_kvs <-
case Maybe (a, [Name])
mb_assoc of
Maybe (a, [Name])
Nothing -> FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM FreeKiTyVars
all_implicit_kvs
Just (a
_, [Name]
cls_tvs) -> [Name] -> FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeNonClassM [Name]
cls_tvs FreeKiTyVars
all_implicit_kvs
; traceRn "checkMixedVars3" $
vcat [ text "bndrs" <+> ppr hs_tv_bndrs
, text "bndr_kv_occs" <+> ppr bndr_kv_occs
, text "body_kv_occs" <+> ppr body_kv_occs
, text "implicit_kvs" <+> ppr implicit_kvs
, text "body_remaining" <+> ppr body_remaining
]
; rnImplicitTvOccs mb_assoc implicit_kvs $ \ [Name]
implicit_kv_nms' ->
HsDocContext
-> WarnUnusedForalls
-> Maybe (a, [Name])
-> [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
-> ([LHsTyVarBndr (HsBndrVis GhcPs) GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
NoWarnUnusedForalls Maybe (a, [Name])
mb_assoc [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
hs_tv_bndrs (([LHsTyVarBndr (HsBndrVis GhcPs) GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars))
-> ([LHsTyVarBndr (HsBndrVis GhcPs) GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr (HsBndrVis GhcPs) GhcRn]
rn_bndrs ->
do { rn_bndrs <- (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LHsTyVarBndr (HsBndrVis GhcPs) GhcRn
-> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn))
rnLHsTyVarBndrVisFlag [LHsTyVarBndr (HsBndrVis GhcPs) GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcRn)]
rn_bndrs
; let
implicit_kv_nms = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> SrcSpan -> Name
`setNameLoc` SrcSpan
bndrs_loc) [Name]
implicit_kv_nms'
; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
, hsq_explicit = rn_bndrs })
body_remaining } }
where
hs_tv_bndrs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
hs_tv_bndrs = LHsQTyVars GhcPs -> [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
forall pass.
LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
hsQTvExplicit LHsQTyVars GhcPs
hsq_bndrs
bndrs_loc :: SrcSpan
bndrs_loc = case (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr (HsBndrVis GhcPs) GhcPs -> SrcSpan
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> SrcSpan
forall flag. LHsTyVarBndr flag GhcPs -> SrcSpan
get_bndr_loc [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
hs_tv_bndrs [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpanAnnN RdrName -> SrcSpan)
-> FreeKiTyVars -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA FreeKiTyVars
body_kv_occs of
[] -> String -> SrcSpan
forall a. HasCallStack => String -> a
panic String
"bindHsQTyVars.bndrs_loc"
[SrcSpan
loc] -> SrcSpan
loc
(SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last [SrcSpan]
locs
get_bndr_loc :: LHsTyVarBndr flag GhcPs -> SrcSpan
get_bndr_loc :: forall flag. LHsTyVarBndr flag GhcPs -> SrcSpan
get_bndr_loc (L SrcSpanAnnA
l HsTyVarBndr flag GhcPs
tvb) =
SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans
(case HsTyVarBndr flag GhcPs -> HsBndrVar GhcPs
forall flag (pass :: Pass).
HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)
hsBndrVar HsTyVarBndr flag GhcPs
tvb of
HsBndrWildCard XBndrWildCard GhcPs
_ ->
SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l
HsBndrVar XBndrVar GhcPs
_ LIdP GhcPs
ln -> GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
ln)
(case HsTyVarBndr flag GhcPs -> HsBndrKind GhcPs
forall flag (pass :: Pass).
HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass)
hsBndrKind HsTyVarBndr flag GhcPs
tvb of
HsBndrNoKind XBndrNoKind GhcPs
_ -> SrcSpan
noSrcSpan
HsBndrKind XBndrKind GhcPs
_ LHsType GhcPs
lk -> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lk)
bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
=> HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs :: forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
doc Maybe assoc
mb_cls FreeKiTyVars
implicit_vars HsOuterTyVarBndrs flag GhcPs
outer_bndrs HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)
thing_inside =
case HsOuterTyVarBndrs flag GhcPs
outer_bndrs of
HsOuterImplicit{} ->
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvOccs Maybe assoc
mb_cls FreeKiTyVars
implicit_vars (([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars))
-> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[Name]
implicit_vars' ->
HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)
thing_inside (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ HsOuterImplicit { hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = [Name]
XHsOuterImplicit GhcRn
implicit_vars' }
HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcPs)]
exp_bndrs} ->
HsDocContext
-> WarnUnusedForalls
-> Maybe (ZonkAny 2)
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe (ZonkAny 2)
forall a. Maybe a
Nothing [LHsTyVarBndr flag (NoGhcTc GhcPs)]
[LHsTyVarBndr flag GhcPs]
exp_bndrs (([LHsTyVarBndr flag GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([LHsTyVarBndr flag GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr flag GhcRn]
exp_bndrs' -> do
HsDocContext -> [LHsTyVarBndr flag GhcRn] -> TcRn ()
forall flag (p :: Pass).
HsDocContext -> [LHsTyVarBndr flag (GhcPass p)] -> TcRn ()
checkForAllTelescopeWildcardBndrs HsDocContext
doc [LHsTyVarBndr flag GhcRn]
exp_bndrs'
HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)
thing_inside (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcRn flag
hso_xexplicit = XHsOuterExplicit GhcRn flag
NoExtField
noExtField
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcRn)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
[LHsTyVarBndr flag GhcRn]
exp_bndrs' }
warn_term_var_capture :: LocatedN RdrName -> RnM ()
warn_term_var_capture :: GenLocated SrcSpanAnnN RdrName -> TcRn ()
warn_term_var_capture GenLocated SrcSpanAnnN RdrName
lVar = do
gbl_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
local_env <- getLocalRdrEnv
case demoteRdrNameTv $ unLoc lVar of
Maybe RdrName
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just RdrName
demoted_name -> do
let global_vars :: [GlobalRdrEltX GREInfo]
global_vars = GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
gbl_env (RdrName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. RdrName -> WhichGREs info -> LookupGRE info
LookupRdrName RdrName
demoted_name WhichGREs GREInfo
forall info. WhichGREs info
SameNameSpace)
let mlocal_var :: Maybe Name
mlocal_var = LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv LocalRdrEnv
local_env RdrName
demoted_name
case Maybe Name
mlocal_var of
Just Name
name -> GenLocated SrcSpanAnnN RdrName
-> Either [GlobalRdrEltX GREInfo] Name -> TcRn ()
warnCapturedTerm GenLocated SrcSpanAnnN RdrName
lVar (Name -> Either [GlobalRdrEltX GREInfo] Name
forall a b. b -> Either a b
Right Name
name)
Maybe Name
Nothing -> Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GlobalRdrEltX GREInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrEltX GREInfo]
global_vars) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnN RdrName
-> Either [GlobalRdrEltX GREInfo] Name -> TcRn ()
warnCapturedTerm GenLocated SrcSpanAnnN RdrName
lVar ([GlobalRdrEltX GREInfo] -> Either [GlobalRdrEltX GREInfo] Name
forall a b. a -> Either a b
Left [GlobalRdrEltX GREInfo]
global_vars)
bindHsForAllTelescope :: HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope :: forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope HsDocContext
doc HsForAllTelescope GhcPs
tele HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside =
case HsForAllTelescope GhcPs
tele of
HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcPs]
bndrs } ->
HsDocContext
-> WarnUnusedForalls
-> Maybe (ZonkAny 0)
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe (ZonkAny 0)
forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr () GhcRn]
bndrs' -> do
HsDocContext -> [LHsTyVarBndr () GhcRn] -> TcRn ()
forall flag (p :: Pass).
HsDocContext -> [LHsTyVarBndr flag (GhcPass p)] -> TcRn ()
checkForAllTelescopeWildcardBndrs HsDocContext
doc [LHsTyVarBndr () GhcRn]
bndrs'
HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ EpAnnForallVis
-> [LHsTyVarBndr () GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallVis
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele EpAnnForallVis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr () GhcRn]
bndrs'
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } ->
HsDocContext
-> WarnUnusedForalls
-> Maybe (ZonkAny 1)
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe (ZonkAny 1)
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
bndrs (([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr Specificity GhcRn]
bndrs' -> do
HsDocContext -> [LHsTyVarBndr Specificity GhcRn] -> TcRn ()
forall flag (p :: Pass).
HsDocContext -> [LHsTyVarBndr flag (GhcPass p)] -> TcRn ()
checkForAllTelescopeWildcardBndrs HsDocContext
doc [LHsTyVarBndr Specificity GhcRn]
bndrs'
HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ EpAnnForallInvis
-> [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallInvis
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallInvis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcRn]
bndrs'
checkForAllTelescopeWildcardBndrs :: HsDocContext
-> [LHsTyVarBndr flag (GhcPass p)]
-> RnM ()
checkForAllTelescopeWildcardBndrs :: forall flag (p :: Pass).
HsDocContext -> [LHsTyVarBndr flag (GhcPass p)] -> TcRn ()
checkForAllTelescopeWildcardBndrs HsDocContext
doc [LHsTyVarBndr flag (GhcPass p)]
tvbs = (SrcSpan -> TcRn ()) -> [SrcSpan] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SrcSpan -> TcRn ()
report_err [SrcSpan]
wc_bndr_locs
where
report_err :: SrcSpan -> RnM ()
report_err :: SrcSpan -> TcRn ()
report_err SrcSpan
loc =
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
loc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
doc (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Maybe Name -> BadAnonWildcardContext -> TcRnMessage
TcRnIllegalWildcardInType Maybe Name
forall a. Maybe a
Nothing BadAnonWildcardContext
WildcardBndrInForallTelescope
wc_bndr_locs :: [SrcSpan]
wc_bndr_locs :: [SrcSpan]
wc_bndr_locs = [SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l | L SrcSpanAnnA
l (HsTvb XTyVarBndr (GhcPass p)
_ flag
_ HsBndrWildCard{} HsBndrKind (GhcPass p)
_) <- [LHsTyVarBndr flag (GhcPass p)]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag (GhcPass p))]
tvbs ]
data WarnUnusedForalls
= WarnUnusedForalls
| NoWarnUnusedForalls
instance Outputable WarnUnusedForalls where
ppr :: WarnUnusedForalls -> SDoc
ppr WarnUnusedForalls
wuf = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ case WarnUnusedForalls
wuf of
WarnUnusedForalls
WarnUnusedForalls -> String
"WarnUnusedForalls"
WarnUnusedForalls
NoWarnUnusedForalls -> String
"NoWarnUnusedForalls"
bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed)
=> HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs :: forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
wuf Maybe a
mb_assoc [LHsTyVarBndr flag GhcPs]
tv_bndrs [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
mb_assoc) (FreeKiTyVars -> TcRn ()
checkShadowedRdrNames FreeKiTyVars
tv_names_w_loc)
; FreeKiTyVars -> TcRn ()
checkDupRdrNames FreeKiTyVars
tv_names_w_loc
; [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
tv_bndrs [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars)
thing_inside }
where
tv_names_w_loc :: FreeKiTyVars
tv_names_w_loc = (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> FreeKiTyVars
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsTyVarBndr flag GhcPs -> Maybe (LocatedN (IdP GhcPs))
GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName)
forall (p :: Pass) flag.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))
hsLTyVarLocName [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
tv_bndrs
go :: [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [] [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars)
thing_inside = [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars)
thing_inside []
go (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
b:[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
bs) [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars)
thing_inside = HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc LHsTyVarBndr flag GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
b ((LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars))
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr flag GhcRn
b' ->
do { (res, fvs) <- [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
bs (([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars))
-> RnM (b, FreeVars))
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
bs' ->
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> RnM (b, FreeVars)
thing_inside (LHsTyVarBndr flag GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
b' GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
bs')
; warn_unused b' fvs
; return (res, fvs) }
warn_unused :: GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
-> FreeVars -> TcRn ()
warn_unused GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
tv_bndr FreeVars
fvs = case WarnUnusedForalls
wuf of
WarnUnusedForalls
WarnUnusedForalls -> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
forall flag.
OutputableBndrFlag flag 'Renamed =>
HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc LHsTyVarBndr flag GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
tv_bndr FreeVars
fvs
WarnUnusedForalls
NoWarnUnusedForalls -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bindLHsTyVarBndr :: HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr :: forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc (L SrcSpanAnnA
loc (HsTvb XTyVarBndr GhcPs
x flag
fl HsBndrVar GhcPs
bvar HsBndrKind GhcPs
kind)) LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside
= do { (kind', fvs1) <- HsDocContext
-> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeVars)
rnHsBndrKind HsDocContext
doc HsBndrKind GhcPs
kind
; (b, fvs2) <- bindHsBndrVar mb_assoc bvar $ \HsBndrVar GhcRn
bvar' ->
LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpanAnnA
-> HsTyVarBndr flag GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XTyVarBndr GhcRn
-> flag
-> HsBndrVar GhcRn
-> HsBndrKind GhcRn
-> HsTyVarBndr flag GhcRn
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb XTyVarBndr GhcPs
XTyVarBndr GhcRn
x flag
fl HsBndrVar GhcRn
bvar' HsBndrKind GhcRn
kind'))
; return (b, fvs1 `plusFV` fvs2) }
bindHsBndrVar :: Maybe a
-> HsBndrVar GhcPs
-> (HsBndrVar GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsBndrVar :: forall a b.
Maybe a
-> HsBndrVar GhcPs
-> (HsBndrVar GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsBndrVar Maybe a
mb_assoc (HsBndrVar XBndrVar GhcPs
_ lrdr :: LIdP GhcPs
lrdr@(L SrcSpanAnnN
lv RdrName
_)) HsBndrVar GhcRn -> RnM (b, FreeVars)
thing_inside
= do { tv_nm <- Maybe a
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
lrdr
; bindLocalNamesFV [tv_nm] $
thing_inside (HsBndrVar noExtField (L lv tv_nm)) }
bindHsBndrVar Maybe a
_ (HsBndrWildCard XBndrWildCard GhcPs
_) HsBndrVar GhcRn -> RnM (b, FreeVars)
thing_inside
= HsBndrVar GhcRn -> RnM (b, FreeVars)
thing_inside (XBndrWildCard GhcRn -> HsBndrVar GhcRn
forall pass. XBndrWildCard pass -> HsBndrVar pass
HsBndrWildCard NoExtField
XBndrWildCard GhcRn
noExtField)
rnHsBndrKind :: HsDocContext -> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeVars)
rnHsBndrKind :: HsDocContext
-> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeVars)
rnHsBndrKind HsDocContext
_ (HsBndrNoKind XBndrNoKind GhcPs
_) = (HsBndrKind GhcRn, FreeVars) -> RnM (HsBndrKind GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBndrNoKind GhcRn -> HsBndrKind GhcRn
forall pass. XBndrNoKind pass -> HsBndrKind pass
HsBndrNoKind NoExtField
XBndrNoKind GhcRn
noExtField, FreeVars
emptyFVs)
rnHsBndrKind HsDocContext
doc (HsBndrKind XBndrKind GhcPs
_ LHsType GhcPs
kind) =
do { sig_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
; (kind', fvs) <- rnLHsKind doc kind
; return (HsBndrKind noExtField kind', fvs) }
rnLHsTyVarBndrVisFlag
:: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn
-> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)
rnLHsTyVarBndrVisFlag :: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn
-> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)
rnLHsTyVarBndrVisFlag (L SrcSpanAnnA
loc HsTyVarBndr (HsBndrVis GhcPs) GhcRn
bndr) = do
let lbndr :: GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
lbndr = SrcSpanAnnA
-> HsTyVarBndr (HsBndrVis GhcRn) GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ((HsBndrVis GhcPs -> HsBndrVis GhcRn)
-> HsTyVarBndr (HsBndrVis GhcPs) GhcRn
-> HsTyVarBndr (HsBndrVis GhcRn) GhcRn
forall flag flag' (pass :: Pass).
(flag -> flag')
-> HsTyVarBndr flag (GhcPass pass)
-> HsTyVarBndr flag' (GhcPass pass)
updateHsTyVarBndrFlag HsBndrVis GhcPs -> HsBndrVis GhcRn
rnHsBndrVis HsTyVarBndr (HsBndrVis GhcPs) GhcRn
bndr)
Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.TypeAbstractions (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBndrVis GhcPs -> Bool
forall pass. HsBndrVis pass -> Bool
isHsBndrInvisible (HsTyVarBndr (HsBndrVis GhcPs) GhcRn -> HsBndrVis GhcPs
forall flag (pass :: Pass). HsTyVarBndr flag (GhcPass pass) -> flag
hsTyVarBndrFlag HsTyVarBndr (HsBndrVis GhcPs) GhcRn
bndr)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErr (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcRnMessage
TcRnIllegalInvisTyVarBndr LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
lbndr)
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBndrVar GhcRn -> Bool
forall pass. HsBndrVar pass -> Bool
isHsBndrWildCard (HsTyVarBndr (HsBndrVis GhcPs) GhcRn -> HsBndrVar GhcRn
forall flag (pass :: Pass).
HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)
hsBndrVar HsTyVarBndr (HsBndrVis GhcPs) GhcRn
bndr)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErr (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcRnMessage
TcRnIllegalWildcardTyVarBndr LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
lbndr)
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
lbndr
rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn
rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn
rnHsBndrVis (HsBndrRequired XBndrRequired GhcPs
_) = XBndrRequired GhcRn -> HsBndrVis GhcRn
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired GhcRn
noExtField
rnHsBndrVis (HsBndrInvisible XBndrInvisible GhcPs
_at) = XBndrInvisible GhcRn -> HsBndrVis GhcRn
forall pass. XBndrInvisible pass -> HsBndrVis pass
HsBndrInvisible NoExtField
XBndrInvisible GhcRn
noExtField
newTyVarNameRn, newTyVarNameRnImplicit
:: Maybe a
-> LocatedN RdrName -> RnM Name
newTyVarNameRn :: forall a.
Maybe a
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc = Maybe a
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
new_tv_name_rn Maybe a
mb_assoc GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn
newTyVarNameRnImplicit :: forall a.
Maybe a
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRnImplicit Maybe a
mb_assoc = Maybe a
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
new_tv_name_rn Maybe a
mb_assoc ((GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnN RdrName
lrdr ->
do { GenLocated SrcSpanAnnN RdrName -> TcRn ()
warn_term_var_capture GenLocated SrcSpanAnnN RdrName
lrdr
; GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn GenLocated SrcSpanAnnN RdrName
lrdr }
new_tv_name_rn :: Maybe a
-> (LocatedN RdrName -> RnM Name)
-> (LocatedN RdrName -> RnM Name)
new_tv_name_rn :: forall a.
Maybe a
-> (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
new_tv_name_rn Maybe a
Nothing GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
cont GenLocated SrcSpanAnnN RdrName
lrdr = GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
cont GenLocated SrcSpanAnnN RdrName
lrdr
new_tv_name_rn (Just a
_) GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
cont lrdr :: GenLocated SrcSpanAnnN RdrName
lrdr@(L SrcSpanAnnN
_ RdrName
rdr)
= do { rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; case lookupLocalRdrEnv rdr_env rdr of
Just Name
n -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
Maybe Name
_ -> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
cont GenLocated SrcSpanAnnN RdrName
lrdr }
rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields :: HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
ctxt [FieldLabel]
fls [LConDeclField GhcPs]
fields
= (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> RnM (GenLocated SrcSpanAnnA (ConDeclField GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (ConDeclField GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env) [LConDeclField GhcPs]
[GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields
where
env :: RnTyKiEnv
env = HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody
fl_env :: FastStringEnv FieldLabel
fl_env = [(FastString, FieldLabel)] -> FastStringEnv FieldLabel
forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv [ (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, FieldLabel
fl) | FieldLabel
fl <- [FieldLabel]
fls ]
rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField :: FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env (L SrcSpanAnnA
l (ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LHsType GhcPs
ty Maybe (LHsDoc GhcPs)
haddock_doc))
= do { let new_names :: [GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
new_names = (GenLocated SrcSpanAnnA (FieldOcc GhcPs)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn))
-> [GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
-> [GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldOcc GhcPs -> FieldOcc GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcPs)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField FastStringEnv FieldLabel
fl_env)) [LFieldOcc GhcPs]
[GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
names
; (new_ty, fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; haddock_doc' <- traverse rnLHsDoc haddock_doc
; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')
, fvs) }
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField FastStringEnv FieldLabel
fl_env (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpanAnnN
lr RdrName
rdr)) =
XCFieldOcc GhcRn -> LIdP GhcRn -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc (OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
sel) (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
lr Name
sel)
where
lbl :: FastString
lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
rdr
sel :: Name
sel = FieldLabel -> Name
flSelector
(FieldLabel -> Name) -> FieldLabel -> Name
forall a b. (a -> b) -> a -> b
$ String -> Maybe FieldLabel -> FieldLabel
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"lookupField"
(Maybe FieldLabel -> FieldLabel) -> Maybe FieldLabel -> FieldLabel
forall a b. (a -> b) -> a -> b
$ FastStringEnv FieldLabel -> FastString -> Maybe FieldLabel
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv FieldLabel
fl_env FastString
lbl
mkHsOpTyRn :: PromotionFlag
-> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn :: PromotionFlag
-> GenLocated SrcSpanAnnN Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn PromotionFlag
prom1 GenLocated SrcSpanAnnN Name
op1 Fixity
fix1 LHsType GhcRn
ty1 (L SrcSpanAnnA
loc2 (HsOpTy XOpTy GhcRn
_ PromotionFlag
prom2 LHsType GhcRn
ty2a LIdP GhcRn
op2 LHsType GhcRn
ty2b))
= do { fix2 <- GenLocated SrcSpanAnnN Name -> RnM Fixity
lookupTyFixityRn LIdP GhcRn
GenLocated SrcSpanAnnN Name
op2
; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }
mkHsOpTyRn PromotionFlag
prom1 GenLocated SrcSpanAnnN Name
op1 Fixity
_ LHsType GhcRn
ty1 LHsType GhcRn
ty2
= HsType GhcRn -> RnM (HsType GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpTy GhcRn
-> PromotionFlag
-> LHsType GhcRn
-> LIdP GhcRn
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
NoExtField
noExtField PromotionFlag
prom1 LHsType GhcRn
ty1 LIdP GhcRn
GenLocated SrcSpanAnnN Name
op1 LHsType GhcRn
ty2)
mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-> LHsType GhcRn -> SrcSpanAnnA
-> RnM (HsType GhcRn)
mk_hs_op_ty :: PromotionFlag
-> GenLocated SrcSpanAnnN Name
-> Fixity
-> LHsType GhcRn
-> PromotionFlag
-> GenLocated SrcSpanAnnN Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpanAnnA
-> RnM (HsType GhcRn)
mk_hs_op_ty PromotionFlag
prom1 GenLocated SrcSpanAnnN Name
op1 Fixity
fix1 LHsType GhcRn
ty1 PromotionFlag
prom2 GenLocated SrcSpanAnnN Name
op2 Fixity
fix2 LHsType GhcRn
ty2a LHsType GhcRn
ty2b SrcSpanAnnA
loc2
| Bool
nofix_error = do { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
op1),Fixity
fix1)
(Name -> OpName
NormalOp (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
op2),Fixity
fix2)
; HsType GhcRn -> RnM (HsType GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op1ty` (SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc2 (LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2a GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op2ty` LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2b))) }
| Bool
associate_right = HsType GhcRn -> RnM (HsType GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op1ty` (SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc2 (LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2a GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op2ty` LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2b)))
| Bool
otherwise = do {
new_ty <- PromotionFlag
-> GenLocated SrcSpanAnnN Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn PromotionFlag
prom1 GenLocated SrcSpanAnnN Name
op1 Fixity
fix1 LHsType GhcRn
ty1 LHsType GhcRn
ty2a
; return (noLocA new_ty `op2ty` ty2b) }
where
GenLocated SrcSpanAnnA (HsType GhcRn)
lhs op1ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op1ty` GenLocated SrcSpanAnnA (HsType GhcRn)
rhs = XOpTy GhcRn
-> PromotionFlag
-> LHsType GhcRn
-> LIdP GhcRn
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
NoExtField
noExtField PromotionFlag
prom1 LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
lhs LIdP GhcRn
GenLocated SrcSpanAnnN Name
op1 LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
rhs
GenLocated SrcSpanAnnA (HsType GhcRn)
lhs op2ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
`op2ty` GenLocated SrcSpanAnnA (HsType GhcRn)
rhs = XOpTy GhcRn
-> PromotionFlag
-> LHsType GhcRn
-> LIdP GhcRn
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
NoExtField
noExtField PromotionFlag
prom2 LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
lhs LIdP GhcRn
GenLocated SrcSpanAnnN Name
op2 LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
rhs
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
mkOpAppRn :: NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn :: NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
negation_handling e1 :: LHsExpr GhcRn
e1@(L SrcSpanAnnA
_ (OpApp XOpApp GhcRn
fix1 LHsExpr GhcRn
e1a LHsExpr GhcRn
op1 LHsExpr GhcRn
e1b)) LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
| Bool
nofix_error
= do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,Fixity
XOpApp GhcRn
fix1) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp Fixity
XOpApp GhcRn
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)
| Bool
associate_right = do
new_e <- NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
negation_handling LHsExpr GhcRn
e1b LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
return (OpApp fix1 e1a op1 (L loc' new_e))
where
loc' :: SrcSpanAnnA
loc'= GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
combineLocsA LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1b LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
XOpApp GhcRn
fix1 Fixity
fix2
mkOpAppRn NegationHandling
ReassociateNegation e1 :: LHsExpr GhcRn
e1@(L SrcSpanAnnA
_ (NegApp XNegApp GhcRn
_ LHsExpr GhcRn
neg_arg SyntaxExpr GhcRn
neg_name)) LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
| Bool
nofix_error
= do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (OpName
NegateOp,Fixity
negateFixity) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp Fixity
XOpApp GhcRn
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)
| Bool
associate_right
= do new_e <- NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
ReassociateNegation LHsExpr GhcRn
neg_arg LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
return (NegApp noExtField (L loc' new_e) neg_name)
where
loc' :: SrcSpanAnnA
loc' = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
combineLocsA LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
neg_arg LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2
mkOpAppRn NegationHandling
ReassociateNegation LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 Fixity
fix1 e2 :: LHsExpr GhcRn
e2@(L SrcSpanAnnA
_ (NegApp {}))
| Bool -> Bool
not Bool
associate_right
= do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1, Fixity
fix1) (OpName
NegateOp, Fixity
negateFixity)
HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp Fixity
XOpApp GhcRn
fix1 LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 LHsExpr GhcRn
e2)
where
(Bool
_, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
negateFixity
mkOpAppRn NegationHandling
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
op Fixity
fix LHsExpr GhcRn
e2
= Bool -> SDoc -> RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Fixity -> HsExpr GhcRn -> Bool
right_op_ok Fixity
fix (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2))
(GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
fix SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2) (RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn))
-> RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp Fixity
XOpApp GhcRn
fix LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2)
data NegationHandling = ReassociateNegation | KeepNegationIntact
get_op :: LHsExpr GhcRn -> OpName
get_op :: LHsExpr GhcRn -> OpName
get_op (L SrcSpanAnnA
_ (HsVar XVar GhcRn
_ LIdP GhcRn
n)) = Name -> OpName
NormalOp (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
n)
get_op (L SrcSpanAnnA
_ (HsUnboundVar XUnboundVar GhcRn
_ RdrName
uv)) = RdrName -> OpName
UnboundOp RdrName
uv
get_op (L SrcSpanAnnA
_ (XExpr (HsRecSelRn FieldOcc GhcRn
fld))) = FieldOcc GhcRn -> OpName
RecFldOp FieldOcc GhcRn
fld
get_op LHsExpr GhcRn
other = String -> SDoc -> OpName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"get_op" (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
other)
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
right_op_ok Fixity
fix1 (OpApp XOpApp GhcRn
fix2 LHsExpr GhcRn
_ LHsExpr GhcRn
_ LHsExpr GhcRn
_)
= Bool -> Bool
not Bool
error_please Bool -> Bool -> Bool
&& Bool
associate_right
where
(Bool
error_please, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
XOpApp GhcRn
fix2
right_op_ok Fixity
_ HsExpr GhcRn
_
= Bool
True
mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
mkNegAppRn LHsExpr GhcRn
neg_arg SyntaxExpr GhcRn
neg_name
= Bool -> RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn)
forall a. HasCallStack => Bool -> a -> a
assert (HsExpr GhcRn -> Bool
forall id. HsExpr id -> Bool
not_op_app (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
neg_arg)) (RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn))
-> RnM (HsExpr GhcRn) -> RnM (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcRn -> LHsExpr GhcRn -> SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
NoExtField
noExtField LHsExpr GhcRn
neg_arg SyntaxExpr GhcRn
neg_name)
not_op_app :: HsExpr id -> Bool
not_op_app :: forall id. HsExpr id -> Bool
not_op_app (OpApp {}) = Bool
False
not_op_app HsExpr id
_ = Bool
True
mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
mkConOpPatRn :: GenLocated SrcSpanAnnN Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn GenLocated SrcSpanAnnN Name
op2 Fixity
fix2 p1 :: LPat GhcRn
p1@(L SrcSpanAnnA
loc (ConPat XConPat GhcRn
NoExtField
NoExtField XRec GhcRn (ConLikeP GhcRn)
op1 (InfixCon LPat GhcRn
p1a LPat GhcRn
p1b))) LPat GhcRn
p2
= do { fix1 <- Name -> RnM Fixity
lookupFixityRn (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
op1)
; let (nofix_error, associate_right) = compareFixity fix1 fix2
; if nofix_error then do
{ precParseErr (NormalOp (unLoc op1),fix1)
(NormalOp (unLoc op2),fix2)
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op2
, pat_args = InfixCon p1 p2
}
}
else if associate_right then do
{ new_p <- mkConOpPatRn op2 fix2 p1b p2
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op1
, pat_args = InfixCon p1a (L loc new_p)
}
}
else return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op2
, pat_args = InfixCon p1 p2
}
}
mkConOpPatRn GenLocated SrcSpanAnnN Name
op Fixity
_ LPat GhcRn
p1 LPat GhcRn
p2
= Bool -> RnM (Pat GhcRn) -> RnM (Pat GhcRn)
forall a. HasCallStack => Bool -> a -> a
assert (Pat GhcRn -> Bool
not_op_pat (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall l e. GenLocated l e -> e
unLoc LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
p2)) (RnM (Pat GhcRn) -> RnM (Pat GhcRn))
-> RnM (Pat GhcRn) -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$
Pat GhcRn -> RnM (Pat GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> RnM (Pat GhcRn)) -> Pat GhcRn -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = XConPat GhcRn
NoExtField
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
op
, pat_args :: HsConDetails
(HsConPatTyArg (NoGhcTc GhcRn))
(LPat GhcRn)
(HsRecFields GhcRn (LPat GhcRn))
pat_args = GenLocated SrcSpanAnnA (Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn)
-> HsConDetails
(HsConPatTyArg GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcRn))
(HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
p1 LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
p2
}
not_op_pat :: Pat GhcRn -> Bool
not_op_pat :: Pat GhcRn -> Bool
not_op_pat (ConPat XConPat GhcRn
NoExtField
NoExtField XRec GhcRn (ConLikeP GhcRn)
_ (InfixCon LPat GhcRn
_ LPat GhcRn
_)) = Bool
False
not_op_pat Pat GhcRn
_ = Bool
True
checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
checkPrecMatch :: forall body. Name -> MatchGroup GhcRn body -> TcRn ()
checkPrecMatch Name
op (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L Anno [GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)]
_ [GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)]
ms) })
= (GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)
-> TcRn ())
-> [GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)]
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated (Anno (Match GhcRn body)) (Match GhcRn body) -> TcRn ()
check [GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)]
ms
where
check :: GenLocated (Anno (Match GhcRn body)) (Match GhcRn body) -> TcRn ()
check (L Anno (Match GhcRn body)
_ (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ ( (L SrcSpanAnnA
l1 Pat GhcRn
p1)
: (L SrcSpanAnnA
l2 Pat GhcRn
p2)
: [GenLocated SrcSpanAnnA (Pat GhcRn)]
_) }))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan) -> SrcSpanAnnA -> SrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => EpAnn a -> EpAnn a -> EpAnn a
combineSrcSpansA SrcSpanAnnA
l1 SrcSpanAnnA
l2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do Name -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op Pat GhcRn
p1 Bool
False
Name -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op Pat GhcRn
p2 Bool
True
check GenLocated (Anno (Match GhcRn body)) (Match GhcRn body)
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec :: Name -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op (ConPat XConPat GhcRn
NoExtField
NoExtField XRec GhcRn (ConLikeP GhcRn)
op1 (InfixCon LPat GhcRn
_ LPat GhcRn
_)) Bool
right = do
op_fix@(Fixity op_prec op_dir) <- Name -> RnM Fixity
lookupFixityRn Name
op
op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
let
inf_ok = Int
op1_prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
op_prec Bool -> Bool -> Bool
||
(Int
op1_prec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
op_prec Bool -> Bool -> Bool
&&
(FixityDirection
op1_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixR Bool -> Bool -> Bool
&& FixityDirection
op_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixR Bool -> Bool -> Bool
&& Bool
right Bool -> Bool -> Bool
||
FixityDirection
op1_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixL Bool -> Bool -> Bool
&& FixityDirection
op_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixL Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
right))
info = (Name -> OpName
NormalOp Name
op, Fixity
op_fix)
info1 = (Name -> OpName
NormalOp (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
op1), Fixity
op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
unless inf_ok (precParseErr infol infor)
checkPrec Name
_ Pat GhcRn
_ Bool
_
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSectionPrec :: FixityDirection -> HsExpr GhcPs
-> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
checkSectionPrec :: FixityDirection
-> HsExpr GhcPs -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcRn ()
checkSectionPrec FixityDirection
direction HsExpr GhcPs
section LHsExpr GhcRn
op LHsExpr GhcRn
arg
= case GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg of
OpApp XOpApp GhcRn
fix LHsExpr GhcRn
_ LHsExpr GhcRn
op' LHsExpr GhcRn
_ -> OpName -> Fixity -> TcRn ()
go_for_it (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op') Fixity
XOpApp GhcRn
fix
NegApp XNegApp GhcRn
_ LHsExpr GhcRn
_ SyntaxExpr GhcRn
_ -> OpName -> Fixity -> TcRn ()
go_for_it OpName
NegateOp Fixity
negateFixity
HsExpr GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
op_name :: OpName
op_name = LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op
go_for_it :: OpName -> Fixity -> TcRn ()
go_for_it OpName
arg_op arg_fix :: Fixity
arg_fix@(Fixity Int
arg_prec FixityDirection
assoc) = do
op_fix@(Fixity op_prec _) <- OpName -> RnM Fixity
lookupFixityOp OpName
op_name
unless (op_prec < arg_prec
|| (op_prec == arg_prec && direction == assoc))
(sectionPrecErr (get_op op, op_fix)
(arg_op, arg_fix) section)
lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp (NormalOp Name
n) = Name -> RnM Fixity
lookupFixityRn Name
n
lookupFixityOp OpName
NegateOp = Name -> RnM Fixity
lookupFixityRn Name
negateName
lookupFixityOp (UnboundOp RdrName
u) = Name -> RnM Fixity
lookupFixityRn (OccName -> Name
mkUnboundName (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
u))
lookupFixityOp (RecFldOp FieldOcc GhcRn
f) = FieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn FieldOcc GhcRn
f
precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
precParseErr :: (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr op1 :: (OpName, Fixity)
op1@(OpName
n1,Fixity
_) op2 :: (OpName, Fixity)
op2@(OpName
n2,Fixity
_)
| OpName -> Bool
is_unbound OpName
n1 Bool -> Bool -> Bool
|| OpName -> Bool
is_unbound OpName
n2
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (OpName, Fixity) -> (OpName, Fixity) -> TcRnMessage
TcRnPrecedenceParsingError (OpName, Fixity)
op1 (OpName, Fixity)
op2
sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
sectionPrecErr :: (OpName, Fixity) -> (OpName, Fixity) -> HsExpr GhcPs -> TcRn ()
sectionPrecErr op :: (OpName, Fixity)
op@(OpName
n1,Fixity
_) arg_op :: (OpName, Fixity)
arg_op@(OpName
n2,Fixity
_) HsExpr GhcPs
section
| OpName -> Bool
is_unbound OpName
n1 Bool -> Bool -> Bool
|| OpName -> Bool
is_unbound OpName
n2
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (OpName, Fixity) -> (OpName, Fixity) -> HsExpr GhcPs -> TcRnMessage
TcRnSectionPrecedenceError (OpName, Fixity)
op (OpName, Fixity)
arg_op HsExpr GhcPs
section
is_unbound :: OpName -> Bool
is_unbound :: OpName -> Bool
is_unbound (NormalOp Name
n) = Name -> Bool
isUnboundName Name
n
is_unbound UnboundOp{} = Bool
True
is_unbound OpName
_ = Bool
False
unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage
unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage
unexpectedPatSigTypeErr HsPatSigType GhcPs
ty
= HsPatSigType GhcPs -> TcRnMessage
TcRnUnexpectedPatSigType HsPatSigType GhcPs
ty
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc (L SrcSpanAnnA
loc HsType GhcPs
ty)
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
doc (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Either (HsType GhcPs) (Name, HsType GhcRn) -> TcRnMessage
TcRnKindSignaturesDisabled (HsType GhcPs -> Either (HsType GhcPs) (Name, HsType GhcRn)
forall a b. a -> Either a b
Left HsType GhcPs
ty)
checkDataKinds :: RnTyKiEnv -> HsType GhcPs -> TcM ()
checkDataKinds :: RnTyKiEnv -> HsType GhcPs -> TcRn ()
checkDataKinds RnTyKiEnv
env HsType GhcPs
thing
= do data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
unless data_kinds $
addErr $ TcRnDataKindsError type_or_kind $ Left thing
where
type_or_kind :: TypeOrKind
type_or_kind | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env = TypeOrKind
KindLevel
| Bool
otherwise = TypeOrKind
TypeLevel
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll :: forall flag.
OutputableBndrFlag flag 'Renamed =>
HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc (L SrcSpanAnnA
loc HsTyVarBndr flag GhcRn
tvb) FreeVars
used_names =
case HsTyVarBndr flag GhcRn -> HsBndrVar GhcRn
forall flag (pass :: Pass).
HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)
hsBndrVar HsTyVarBndr flag GhcRn
tvb of
HsBndrWildCard XBndrWildCard GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
HsBndrVar XBndrVar GhcRn
_ (L SrcSpanAnnN
_ Name
tv) ->
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
tv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: TcRnMessage
msg = HsDocContext -> HsTyVarBndrExistentialFlag -> TcRnMessage
TcRnUnusedQuantifiedTypeVar HsDocContext
doc (HsTyVarBndr flag GhcRn -> HsTyVarBndrExistentialFlag
forall flag.
OutputableBndrFlag flag 'Renamed =>
HsTyVarBndr flag GhcRn -> HsTyVarBndrExistentialFlag
HsTyVarBndrExistentialFlag HsTyVarBndr flag GhcRn
tvb)
SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) TcRnMessage
msg
warnCapturedTerm :: LocatedN RdrName -> Either [GlobalRdrElt] Name -> TcM ()
warnCapturedTerm :: GenLocated SrcSpanAnnN RdrName
-> Either [GlobalRdrEltX GREInfo] Name -> TcRn ()
warnCapturedTerm (L SrcSpanAnnN
loc RdrName
tv) Either [GlobalRdrEltX GREInfo] Name
shadowed_term_names
= let msg :: TcRnMessage
msg = RdrName -> Either [GlobalRdrEltX GREInfo] Name -> TcRnMessage
TcRnCapturedTermName RdrName
tv Either [GlobalRdrEltX GREInfo] Name
shadowed_term_names
in SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) TcRnMessage
msg
type FreeKiTyVars = [LocatedN RdrName]
data TermVariableCapture =
CaptureTermVars
| DontCaptureTermVars
getTermVariableCapture :: RnM TermVariableCapture
getTermVariableCapture :: RnM TermVariableCapture
getTermVariableCapture
= do { required_type_arguments <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RequiredTypeArguments
; let tvc | Bool
required_type_arguments = TermVariableCapture
CaptureTermVars
| Bool
otherwise = TermVariableCapture
DontCaptureTermVars
; return tvc }
filterInScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars
filterInScope :: TermVariableCapture
-> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars
filterInScope TermVariableCapture
tvc (GlobalRdrEnv, LocalRdrEnv)
envs = (GenLocated SrcSpanAnnN RdrName -> Bool)
-> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TermVariableCapture
-> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool
inScope TermVariableCapture
tvc (GlobalRdrEnv, LocalRdrEnv)
envs (RdrName -> Bool)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)
filterInScopeNonClass :: [Name] -> TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars
filterInScopeNonClass :: [Name]
-> TermVariableCapture
-> (GlobalRdrEnv, LocalRdrEnv)
-> FreeKiTyVars
-> FreeKiTyVars
filterInScopeNonClass [Name]
cls_tvs TermVariableCapture
tvc (GlobalRdrEnv, LocalRdrEnv)
envs = (GenLocated SrcSpanAnnN RdrName -> Bool)
-> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut (RdrName -> Bool
in_scope_non_class (RdrName -> Bool)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)
where
in_scope_non_class :: RdrName -> Bool
in_scope_non_class :: RdrName -> Bool
in_scope_non_class RdrName
rdr
| RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
rdr OccName -> OccSet -> Bool
`elemOccSet` OccSet
cls_tvs_set = Bool
False
| Bool
otherwise = TermVariableCapture
-> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool
inScope TermVariableCapture
tvc (GlobalRdrEnv, LocalRdrEnv)
envs RdrName
rdr
cls_tvs_set :: OccSet
cls_tvs_set :: OccSet
cls_tvs_set = [OccName] -> OccSet
mkOccSet ((Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
cls_tvs)
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM FreeKiTyVars
vars
= do { tvc <- RnM TermVariableCapture
getTermVariableCapture
; envs <- getRdrEnvs
; return (filterInScope tvc envs vars) }
filterInScopeNonClassM :: [Name] -> FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeNonClassM :: [Name] -> FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeNonClassM [Name]
cls_tvs FreeKiTyVars
vars
= do { tvc <- RnM TermVariableCapture
getTermVariableCapture
; envs <- getRdrEnvs
; return (filterInScopeNonClass cls_tvs tvc envs vars) }
inScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool
inScope :: TermVariableCapture
-> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool
inScope TermVariableCapture
tvc (GlobalRdrEnv
gbl, LocalRdrEnv
lcl) RdrName
rdr =
case TermVariableCapture
tvc of
TermVariableCapture
DontCaptureTermVars -> Bool
rdr_in_scope
TermVariableCapture
CaptureTermVars -> Bool
rdr_in_scope Bool -> Bool -> Bool
|| Bool
demoted_rdr_in_scope
where
rdr_in_scope, demoted_rdr_in_scope :: Bool
rdr_in_scope :: Bool
rdr_in_scope = RdrName -> Bool
elem_lcl RdrName
rdr
demoted_rdr_in_scope :: Bool
demoted_rdr_in_scope = Bool -> (RdrName -> Bool) -> Maybe RdrName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (RdrName -> Bool
elem_lcl (RdrName -> Bool) -> (RdrName -> Bool) -> RdrName -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> RdrName -> Bool
elem_gbl) (RdrName -> Maybe RdrName
demoteRdrNameTv RdrName
rdr)
elem_lcl, elem_gbl :: RdrName -> Bool
elem_lcl :: RdrName -> Bool
elem_lcl RdrName
name = RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv RdrName
name LocalRdrEnv
lcl
elem_gbl :: RdrName -> Bool
elem_gbl RdrName
name = (Bool -> Bool
not (Bool -> Bool)
-> ([GlobalRdrEltX GREInfo] -> Bool)
-> [GlobalRdrEltX GREInfo]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobalRdrEltX GREInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrEltX GREInfo]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
gbl (RdrName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. RdrName -> WhichGREs info -> LookupGRE info
LookupRdrName RdrName
name (FieldsOrSelectors -> WhichGREs GREInfo
RelevantGREsFOS FieldsOrSelectors
WantBoth)))
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
(HsValArg XValArg GhcPs
_ LHsType GhcPs
ty) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
extract_tyarg (HsTypeArg XTypeArg GhcPs
_ LHsType GhcPs
ki) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki FreeKiTyVars
acc
extract_tyarg (HsArgPar XArgPar GhcPs
_) FreeKiTyVars
acc = FreeKiTyVars
acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
[LHsTypeArg GhcPs]
args FreeKiTyVars
acc = (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> FreeKiTyVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars
extract_tyarg FreeKiTyVars
acc [LHsTypeArg GhcPs]
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
args
extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
[LHsTypeArg GhcPs]
args
= [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_tyargs [LHsTypeArg GhcPs]
args []
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
LHsType GhcPs
ty = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty []
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
(L SrcSpanAnnA
_ HsType GhcPs
ty) =
case HsType GhcPs
ty of
HsParTy XParTy GhcPs
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars LHsType GhcPs
ty
HsKindSig XKindSig GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
ki -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
ki
HsType GhcPs
_ -> []
extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
HsContext GhcPs
tys = HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys
extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
[LHsTyVarBndr flag GhcPs]
tv_bndrs = [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs [LHsTyVarBndr flag GhcPs]
tv_bndrs
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
(L EpAnnCO
_ FamilyResultSig GhcPs
resultSig) = case FamilyResultSig GhcPs
resultSig of
KindSig XCKindSig GhcPs
_ LHsType GhcPs
k -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
k
TyVarSig XTyVarSig GhcPs
_ (L SrcSpanAnnA
_ HsTyVarBndr () GhcPs
tvb) | HsTvb { tvb_kind :: forall flag pass. HsTyVarBndr flag pass -> HsBndrKind pass
tvb_kind = HsBndrKind XBndrKind GhcPs
_ LHsType GhcPs
k } <- HsTyVarBndr () GhcPs
tvb
-> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
k
FamilyResultSig GhcPs
_ -> []
extractConDeclGADTDetailsTyVars ::
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
HsConDeclGADTDetails GhcPs
con_args = case HsConDeclGADTDetails GhcPs
con_args of
PrefixConGADT XPrefixConGADT GhcPs
_ [HsScaled GhcPs (LHsType GhcPs)]
args -> [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
extract_scaled_ltys [HsScaled GhcPs (LHsType GhcPs)]
args
RecConGADT XRecConGADT GhcPs
_ (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds) -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys (HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars)
-> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> LHsType GhcPs)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> HsContext GhcPs
forall a b. (a -> b) -> [a] -> [b]
map (ConDeclField GhcPs -> LHsType GhcPs
ConDeclField GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> ConDeclField GhcPs
forall l e. GenLocated l e -> e
unLoc) ([GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> HsContext GhcPs)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> HsContext GhcPs
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds
extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVars
(HsDataDefn { dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
ksig })
= FreeKiTyVars
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> FreeKiTyVars)
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
-> FreeKiTyVars
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] LHsType GhcPs -> FreeKiTyVars
GenLocated SrcSpanAnnA (HsType GhcPs) -> FreeKiTyVars
extractHsTyRdrTyVars Maybe (LHsType GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
LHsContext GhcPs
ctxt = HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. GenLocated l e -> e
unLoc LHsContext GhcPs
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt)
extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
-> FreeKiTyVars -> FreeKiTyVars
[HsScaled GhcPs (LHsType GhcPs)]
args FreeKiTyVars
acc = (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> FreeKiTyVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsScaled GhcPs (LHsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars
HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars
extract_scaled_lty FreeKiTyVars
acc [HsScaled GhcPs (LHsType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
args
extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
(HsScaled HsArrow GhcPs
m LHsType GhcPs
ty) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow HsArrow GhcPs
m FreeKiTyVars
acc
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
HsContext GhcPs
tys FreeKiTyVars
acc = (GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> FreeKiTyVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_lty FreeKiTyVars
acc HsContext GhcPs
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys
extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
(L SrcSpanAnnA
_ HsType GhcPs
ty) FreeKiTyVars
acc
= case HsType GhcPs
ty of
HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
ltv -> GenLocated SrcSpanAnnN RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
ltv FreeKiTyVars
acc
HsBangTy XBangTy GhcPs
_ HsBang
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
flds -> (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> FreeKiTyVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_lty
(GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars)
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> FreeKiTyVars
-> FreeKiTyVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcPs -> LHsType GhcPs
ConDeclField GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcPs) -> ConDeclField GhcPs
forall l e. GenLocated l e -> e
unLoc) FreeKiTyVars
acc
[LConDeclField GhcPs]
[GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds
HsAppTy XAppTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2 -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 FreeKiTyVars
acc
HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
k FreeKiTyVars
acc
HsListTy XListTy GhcPs
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsTupleTy XTupleTy GhcPs
_ HsTupleSort
_ HsContext GhcPs
tys -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
HsSumTy XSumTy GhcPs
_ HsContext GhcPs
tys -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
m LHsType GhcPs
ty1 LHsType GhcPs
ty2 -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow HsArrow GhcPs
m (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 FreeKiTyVars
acc
HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsOpTy XOpTy GhcPs
_ PromotionFlag
_ LHsType GhcPs
ty1 LIdP GhcPs
tv LHsType GhcPs
ty2 -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnN RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tv (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 FreeKiTyVars
acc
HsParTy XParTy GhcPs
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsSpliceTy {} -> FreeKiTyVars
acc
HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty LHsDoc GhcPs
_ -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
_ HsContext GhcPs
tys -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
tys -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
HsTyLit XTyLit GhcPs
_ HsTyLit GhcPs
_ -> FreeKiTyVars
acc
HsStarTy XStarTy GhcPs
_ Bool
_ -> FreeKiTyVars
acc
HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
ki -> LHsType GhcPs -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_kind_sig LHsType GhcPs
ty LHsType GhcPs
ki FreeKiTyVars
acc
HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
ty }
-> HsForAllTelescope GhcPs
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_for_all_telescope HsForAllTelescope GhcPs
tele FreeKiTyVars
acc (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty []
HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcPs
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
ty }
-> LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt LHsContext GhcPs
ctxt (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
XHsType {} -> FreeKiTyVars
acc
HsWildCardTy {} -> FreeKiTyVars
acc
extract_kind_sig :: LHsType GhcPs
-> LHsType GhcPs
-> FreeKiTyVars -> FreeKiTyVars
LHsType GhcPs
ty LHsType GhcPs
ki FreeKiTyVars
acc
| (L SrcSpanAnnA
_ HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs }
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
ki_body }) <- LHsType GhcPs
ki
= [LHsTyVarBndr Specificity GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr Specificity GhcPs]
bndrs FreeKiTyVars
acc (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki_body []
extract_kind_sig LHsType GhcPs
ty LHsType GhcPs
ki FreeKiTyVars
acc
= LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki FreeKiTyVars
acc
extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
(L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcPs
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcPs
body})) =
HsOuterSigTyVarBndrs GhcPs -> FreeKiTyVars -> FreeKiTyVars
forall flag.
HsOuterTyVarBndrs flag GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractHsOuterTvBndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
body []
extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
FreeKiTyVars
(HsExplicitMult XExplicitMult (LHsType GhcPs) GhcPs
_ LHsType GhcPs
p) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
p FreeKiTyVars
acc
extract_hs_arrow HsArrow GhcPs
_ FreeKiTyVars
acc = FreeKiTyVars
acc
extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-> FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
HsForAllTelescope GhcPs
tele FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs =
case HsForAllTelescope GhcPs
tele of
HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcPs]
bndrs } ->
[LHsTyVarBndr () GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr () GhcPs]
bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } ->
[LHsTyVarBndr Specificity GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr Specificity GhcPs]
bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs
extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs
-> FreeKiTyVars
-> FreeKiTyVars
HsOuterTyVarBndrs flag GhcPs
outer_bndrs FreeKiTyVars
body_fvs =
case HsOuterTyVarBndrs flag GhcPs
outer_bndrs of
HsOuterImplicit{} -> FreeKiTyVars
body_fvs
HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcPs)]
bndrs} -> [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr flag (NoGhcTc GhcPs)]
[LHsTyVarBndr flag GhcPs]
bndrs [] FreeKiTyVars
body_fvs
extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
[LHsTyVarBndr flag GhcPs]
tv_bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_vars = FreeKiTyVars
new_vars FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
acc_vars
where
new_vars :: FreeKiTyVars
new_vars
| [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
tv_bndrs = FreeKiTyVars
body_vars
| Bool
otherwise = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
tv_bndr_rdrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ FreeKiTyVars
bndr_vars FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
body_vars
bndr_vars :: FreeKiTyVars
bndr_vars = [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs [LHsTyVarBndr flag GhcPs]
tv_bndrs
tv_bndr_rdrs :: FreeKiTyVars
tv_bndr_rdrs = (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> FreeKiTyVars
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsTyVarBndr flag GhcPs -> Maybe (LocatedN (IdP GhcPs))
GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (GenLocated SrcSpanAnnN RdrName)
forall (p :: Pass) flag.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))
hsLTyVarLocName [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
tv_bndrs
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
[LHsTyVarBndr flag GhcPs]
tv_bndrs =
(GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> FreeKiTyVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
GenLocated SrcSpanAnnA (HsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_lty []
[LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
k | L SrcSpanAnnA
_ (HsTvb { tvb_kind :: forall flag pass. HsTyVarBndr flag pass -> HsBndrKind pass
tvb_kind = HsBndrKind XBndrKind GhcPs
_ LHsType GhcPs
k }) <- [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
tv_bndrs]
extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars
GenLocated SrcSpanAnnN RdrName
tv FreeKiTyVars
acc =
if RdrName -> Bool
isRdrTyVar (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tv) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (RdrName -> Bool) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> Bool
isQual) (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tv) then GenLocated SrcSpanAnnN RdrName
tvGenLocated SrcSpanAnnN RdrName -> FreeKiTyVars -> FreeKiTyVars
forall a. a -> [a] -> [a]
:FreeKiTyVars
acc else FreeKiTyVars
acc
nubL :: Eq a => [GenLocated l a] -> [GenLocated l a]
nubL :: forall a l. Eq a => [GenLocated l a] -> [GenLocated l a]
nubL = (GenLocated l a -> GenLocated l a -> Bool)
-> [GenLocated l a] -> [GenLocated l a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy GenLocated l a -> GenLocated l a -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated
nubN :: Eq a => [LocatedN a] -> [LocatedN a]
nubN :: forall a. Eq a => [LocatedN a] -> [LocatedN a]
nubN = (LocatedN a -> LocatedN a -> Bool) -> [LocatedN a] -> [LocatedN a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy LocatedN a -> LocatedN a -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated
filterFreeVarsToBind :: FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
filterFreeVarsToBind :: FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs = (GenLocated SrcSpanAnnN RdrName -> Bool)
-> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut GenLocated SrcSpanAnnN RdrName -> Bool
is_in_scope
where
is_in_scope :: GenLocated SrcSpanAnnN RdrName -> Bool
is_in_scope GenLocated SrcSpanAnnN RdrName
locc = (GenLocated SrcSpanAnnN RdrName -> Bool) -> FreeKiTyVars -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN RdrName -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated GenLocated SrcSpanAnnN RdrName
locc) FreeKiTyVars
bndrs