{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType,
HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
rnScaledLHsType,
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
nubL
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )
import GHC.Driver.Session
import GHC.Hs
import GHC.Rename.Env
import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext
, mapFvRn, pprHsDocContext, bindLocalNamesFV
, typeAppErr, newLocalBndrRn, checkDupRdrNames
, checkShadowedRdrNames )
import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import GHC.Tc.Utils.Monad
import GHC.Types.Name.Reader
import GHC.Builtin.Names
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
import GHC.Types.FieldLabel
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.FastString
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( nubBy, partition )
import Control.Monad ( unless, when )
#include "GhclibHsVersions.h"
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 SrcSpan
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 { FreeKiTyVars
free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsSigType GhcPs -> FreeKiTyVars
extract_lhs_sig_ty LHsSigType GhcPs
sig_ty)
; (FreeKiTyVars
nwc_rdrs', FreeKiTyVars
imp_tv_nms) <- FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
; let nwc_rdrs :: FreeKiTyVars
nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
nwc_rdrs'
; HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> HsOuterSigTyVarBndrs GhcPs
-> (HsOuterTyVarBndrs Specificity GhcRn
-> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall flag assoc a.
OutputableBndrFlag flag =>
HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
imp_tv_nms HsOuterSigTyVarBndrs GhcPs
outer_bndrs ((HsOuterTyVarBndrs Specificity GhcRn
-> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars))
-> (HsOuterTyVarBndrs Specificity GhcRn
-> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
do { ([Name]
wcs, Located (HsType GhcRn)
body_ty', FreeVars
fvs) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
doc FreeKiTyVars
nwc_rdrs LHsType GhcPs
body_ty
; (LHsSigWcType GhcRn, FreeVars)
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC { hswc_ext :: XHsWC GhcRn (GenLocated SrcSpan (HsSigType GhcRn))
hswc_ext = [Name]
XHsWC GhcRn (GenLocated SrcSpan (HsSigType GhcRn))
wcs, hswc_body :: GenLocated SrcSpan (HsSigType GhcRn)
hswc_body = SrcSpan -> HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$
HsSig :: forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig { sig_ext :: XHsSig GhcRn
sig_ext = NoExtField
XHsSig GhcRn
noExtField
, sig_bndrs :: HsOuterTyVarBndrs Specificity GhcRn
sig_bndrs = HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs', sig_body :: LHsType GhcRn
sig_body = Located (HsType GhcRn)
LHsType GhcRn
body_ty' }}
, FreeVars
fvs) } }
rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsPatSigTypeScoping
scoping HsDocContext
ctx HsPatSigType GhcPs
sig_ty HsPatSigType GhcRn -> RnM (a, FreeVars)
thing_inside
= do { Bool
ty_sig_okay <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
; Bool -> MsgDoc -> TcRn ()
checkErr Bool
ty_sig_okay (HsPatSigType GhcPs -> MsgDoc
unexpectedPatSigTypeErr HsPatSigType GhcPs
sig_ty)
; FreeKiTyVars
free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
pat_sig_ty)
; (FreeKiTyVars
nwc_rdrs', FreeKiTyVars
tv_rdrs) <- FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
; let nwc_rdrs :: FreeKiTyVars
nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
nwc_rdrs'
implicit_bndrs :: FreeKiTyVars
implicit_bndrs = case HsPatSigTypeScoping
scoping of
HsPatSigTypeScoping
AlwaysBind -> FreeKiTyVars
tv_rdrs
HsPatSigTypeScoping
NeverBind -> []
; Maybe Any
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
implicit_bndrs (([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars))
-> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
imp_tvs ->
do { ([Name]
nwcs, Located (HsType GhcRn)
pat_sig_ty', FreeVars
fvs1) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctx FreeKiTyVars
nwc_rdrs LHsType GhcPs
pat_sig_ty
; let sig_names :: HsPSRn
sig_names = HsPSRn :: [Name] -> [Name] -> HsPSRn
HsPSRn { hsps_nwcs :: [Name]
hsps_nwcs = [Name]
nwcs, hsps_imp_tvs :: [Name]
hsps_imp_tvs = [Name]
imp_tvs }
sig_ty' :: HsPatSigType GhcRn
sig_ty' = HsPS :: forall pass. XHsPS pass -> LHsType pass -> HsPatSigType pass
HsPS { hsps_ext :: XHsPS GhcRn
hsps_ext = HsPSRn
XHsPS GhcRn
sig_names, hsps_body :: LHsType GhcRn
hsps_body = Located (HsType GhcRn)
LHsType GhcRn
pat_sig_ty' }
; (a
res, FreeVars
fvs2) <- HsPatSigType GhcRn -> RnM (a, FreeVars)
thing_inside HsPatSigType GhcRn
sig_ty'
; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) } }
where
pat_sig_ty :: LHsType GhcPs
pat_sig_ty = HsPatSigType GhcPs -> LHsType GhcPs
forall pass. HsPatSigType pass -> LHsType pass
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 { FreeKiTyVars
free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
hs_ty)
; (FreeKiTyVars
nwc_rdrs', FreeKiTyVars
_) <- FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
; let nwc_rdrs :: FreeKiTyVars
nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
nwc_rdrs'
; ([Name]
wcs, Located (HsType GhcRn)
hs_ty', FreeVars
fvs) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt FreeKiTyVars
nwc_rdrs LHsType GhcPs
hs_ty
; let sig_ty' :: HsWildCardBndrs GhcRn (Located (HsType GhcRn))
sig_ty' = HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC { hswc_ext :: XHsWC GhcRn (Located (HsType GhcRn))
hswc_ext = [Name]
XHsWC GhcRn (Located (HsType GhcRn))
wcs, hswc_body :: Located (HsType GhcRn)
hswc_body = Located (HsType GhcRn)
hs_ty' }
; (HsWildCardBndrs GhcRn (Located (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWildCardBndrs GhcRn (Located (HsType GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWildCardBndrs GhcRn (Located (HsType GhcRn))
sig_ty', FreeVars
fvs) }
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody :: HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt FreeKiTyVars
nwc_rdrs LHsType GhcPs
hs_ty
= do { [Name]
nwcs <- (Located 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)
mapM Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn FreeKiTyVars
nwc_rdrs
; let env :: RnTyKiEnv
env = RTKE :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> FreeVars -> RnTyKiEnv
RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
TypeLevel
, rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnTypeBody
, rtke_nwcs :: FreeVars
rtke_nwcs = [Name] -> FreeVars
mkNameSet [Name]
nwcs
, rtke_ctxt :: HsDocContext
rtke_ctxt = HsDocContext
ctxt }
; (Located (HsType GhcRn)
hs_ty', FreeVars
fvs) <- [Name]
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
nwcs (RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars))
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$
RnTyKiEnv
-> GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars)
rn_lty RnTyKiEnv
env GenLocated SrcSpan (HsType GhcPs)
LHsType GhcPs
hs_ty
; ([Name], Located (HsType GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv) ([Name], Located (HsType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
nwcs, Located (HsType GhcRn)
hs_ty', FreeVars
fvs) }
where
rn_lty :: RnTyKiEnv
-> GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars)
rn_lty RnTyKiEnv
env (L SrcSpan
loc HsType GhcPs
hs_ty)
= SrcSpan
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars))
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$
do { (HsType GhcRn
hs_ty', FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env HsType GhcPs
hs_ty
; (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsType GhcRn -> Located (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsType GhcRn
hs_ty', FreeVars
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 { (Located (HsType GhcRn)
hs_body', FreeVars
fvs) <- RnTyKiEnv
-> GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars)
rn_lty RnTyKiEnv
env GenLocated SrcSpan (HsType GhcPs)
LHsType GhcPs
hs_body
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsForAllTy :: forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
, hst_tele :: HsForAllTelescope GhcRn
hst_tele = HsForAllTelescope GhcRn
tele', hst_body :: LHsType GhcRn
hst_body = Located (HsType GhcRn)
LHsType GhcRn
hs_body' }
, FreeVars
fvs) }
rn_ty RnTyKiEnv
env (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L cx hs_ctxt
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_ty })
| Just ([GenLocated SrcSpan (HsType GhcPs)]
hs_ctxt1, GenLocated SrcSpan (HsType GhcPs)
hs_ctxt_last) <- [GenLocated SrcSpan (HsType GhcPs)]
-> Maybe
([GenLocated SrcSpan (HsType GhcPs)],
GenLocated SrcSpan (HsType GhcPs))
forall a. [a] -> Maybe ([a], a)
snocView [GenLocated SrcSpan (HsType GhcPs)]
hs_ctxt
, L lx (HsWildCardTy _) <- LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens GenLocated SrcSpan (HsType GhcPs)
LHsType GhcPs
hs_ctxt_last
= do { ([Located (HsType GhcRn)]
hs_ctxt1', FreeVars
fvs1) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv
-> GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars)
rn_top_constraint RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
hs_ctxt1
; SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
lx (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RnTyKiEnv -> HsContext GhcPs -> TcRn ()
checkExtraConstraintWildCard RnTyKiEnv
env [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
hs_ctxt1
; let hs_ctxt' :: [Located (HsType GhcRn)]
hs_ctxt' = [Located (HsType GhcRn)]
hs_ctxt1' [Located (HsType GhcRn)]
-> [Located (HsType GhcRn)] -> [Located (HsType GhcRn)]
forall a. [a] -> [a] -> [a]
++ [SrcSpan -> HsType GhcRn -> Located (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
lx (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy NoExtField
XWildCardTy GhcRn
noExtField)]
; (Located (HsType GhcRn)
hs_ty', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
, hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan
-> [Located (HsType GhcRn)]
-> GenLocated SrcSpan [Located (HsType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
cx [Located (HsType GhcRn)]
hs_ctxt', hst_body :: LHsType GhcRn
hst_body = Located (HsType GhcRn)
LHsType GhcRn
hs_ty' }
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
| Bool
otherwise
= do { ([Located (HsType GhcRn)]
hs_ctxt', FreeVars
fvs1) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv
-> GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars)
rn_top_constraint RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
hs_ctxt
; (Located (HsType GhcRn)
hs_ty', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
, hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan
-> [Located (HsType GhcRn)]
-> GenLocated SrcSpan [Located (HsType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
cx [Located (HsType GhcRn)]
hs_ctxt'
, hst_body :: LHsType GhcRn
hst_body = Located (HsType GhcRn)
LHsType GhcRn
hs_ty' }
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
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 :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnTopConstraint })
checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
RnTyKiEnv
env HsContext GhcPs
hs_ctxt
= RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
where
mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed RnTyKiEnv
env)
= MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
base_msg
| DerivDeclCtx {} <- RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env
, Bool -> Bool
not ([GenLocated SrcSpan (HsType GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
hs_ctxt)
= MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
deriv_decl_msg
| Bool
otherwise
= Maybe MsgDoc
forall a. Maybe a
Nothing
base_msg :: MsgDoc
base_msg = String -> MsgDoc
text String
"Extra-constraint wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
pprAnonWildCard
MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"not allowed"
deriv_decl_msg :: MsgDoc
deriv_decl_msg
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang MsgDoc
base_msg
Int
2 ([MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"except as the sole constraint"
, Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"e.g., deriving instance _ => Eq (Foo a)") ])
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 ([Located RdrName], FreeKiTyVars)
partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
= do { Bool
wildcards_enabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedWildCards
; (FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars))
-> (FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars)
forall a b. (a -> b) -> a -> b
$
if Bool
wildcards_enabled
then (Located RdrName -> Bool)
-> FreeKiTyVars -> (FreeKiTyVars, FreeKiTyVars)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Located RdrName -> Bool
is_wildcard FreeKiTyVars
free_vars
else ([], FreeKiTyVars
free_vars) }
where
is_wildcard :: Located RdrName -> Bool
is_wildcard :: Located RdrName -> Bool
is_wildcard Located RdrName
rdr = OccName -> Bool
startsWithUnderscore (RdrName -> OccName
rdrNameOcc (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
rdr))
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
rnHsSigType HsDocContext
ctx TypeOrKind
level
(L SrcSpan
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 }))
= SrcSpan
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars))
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$
do { String -> MsgDoc -> TcRn ()
traceRn String
"rnHsSigType" (HsSigType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsSigType GhcPs
sig_ty)
; case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
HsOuterExplicit{} -> RnTyKiEnv -> HsSigType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsSigType GhcPs
sig_ty
HsOuterImplicit{} -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; FreeKiTyVars
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
; HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> HsOuterSigTyVarBndrs GhcPs
-> (HsOuterTyVarBndrs Specificity GhcRn
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars))
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
forall flag assoc a.
OutputableBndrFlag flag =>
HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
ctx Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
imp_vars HsOuterSigTyVarBndrs GhcPs
outer_bndrs ((HsOuterTyVarBndrs Specificity GhcRn
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars))
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars))
-> (HsOuterTyVarBndrs Specificity GhcRn
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars))
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
do { (Located (HsType GhcRn)
body', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
body
; (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
-> RnM (GenLocated SrcSpan (HsSigType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SrcSpan -> HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpan (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$ HsSig :: forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig { sig_ext :: XHsSig GhcRn
sig_ext = NoExtField
XHsSig GhcRn
noExtField
, sig_bndrs :: HsOuterTyVarBndrs Specificity GhcRn
sig_bndrs = HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs', sig_body :: LHsType GhcRn
sig_body = Located (HsType GhcRn)
LHsType GhcRn
body' }
, FreeVars
fvs ) } }
where
env :: RnTyKiEnv
env = HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctx TypeOrKind
level RnTyKiWhat
RnTypeBody
rnImplicitBndrs :: Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs :: Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs 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 => [Located a] -> [Located a]
nubL FreeKiTyVars
implicit_vs_with_dups
; String -> MsgDoc -> TcRn ()
traceRn String
"rnImplicitBndrs" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_vs_with_dups, FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_vs ]
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; [Name]
vars <- (Located 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)
mapM (Maybe assoc
-> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe assoc
mb_assoc (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (Located RdrName -> Located RdrName)
-> Located RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RdrName -> Located RdrName)
-> (Located RdrName -> RdrName)
-> Located RdrName
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) FreeKiTyVars
implicit_vs
; [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
vars (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
[Name] -> RnM (a, FreeVars)
thing_inside [Name]
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 -> MsgDoc
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 -> MsgDoc
text String
"RTKE"
MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
braces ([MsgDoc] -> MsgDoc
sep [ TypeOrKind -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TypeOrKind
lev, RnTyKiWhat -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RnTyKiWhat
what, FreeVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeVars
wcs
, HsDocContext -> MsgDoc
pprHsDocContext HsDocContext
ctxt ])
instance Outputable RnTyKiWhat where
ppr :: RnTyKiWhat -> MsgDoc
ppr RnTyKiWhat
RnTypeBody = String -> MsgDoc
text String
"RnTypeBody"
ppr RnTyKiWhat
RnTopConstraint = String -> MsgDoc
text String
"RnTopConstraint"
ppr RnTyKiWhat
RnConstraint = String -> MsgDoc
text String
"RnConstraint"
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
cxt TypeOrKind
level RnTyKiWhat
what
= RTKE :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> FreeVars -> RnTyKiEnv
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 SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc) [GenLocated SrcSpan (HsType GhcPs)]
HsContext 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
(HsArrow GhcRn
w' , FreeVars
fvs_w) <- RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
doc TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) HsArrow GhcPs
w
(Located (HsType GhcRn)
ty', FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc LHsType GhcPs
ty
(HsScaled GhcRn (Located (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsScaled GhcRn (Located (HsType GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsArrow GhcRn
-> Located (HsType GhcRn)
-> HsScaled GhcRn (Located (HsType GhcRn))
forall pass a. HsArrow pass -> a -> HsScaled pass a
HsScaled HsArrow GhcRn
w' Located (HsType GhcRn)
ty', FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
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
rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
rnHsKind :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsKind HsDocContext
ctxt HsType GhcPs
kind = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
KindLevel RnTyKiWhat
RnTypeBody) HsType GhcPs
kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg :: HsDocContext
-> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg HsDocContext
ctxt (HsValArg LHsType GhcPs
ty)
= do { (Located (HsType GhcRn)
tys_rn, FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
ty
; (HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsType GhcRn)
-> HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg Located (HsType GhcRn)
tys_rn, FreeVars
fvs) }
rnLHsTypeArg HsDocContext
ctxt (HsTypeArg SrcSpan
l LHsType GhcPs
ki)
= do { (Located (HsType GhcRn)
kis_rn, FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
ctxt LHsType GhcPs
ki
; (HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> Located (HsType GhcRn)
-> HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l Located (HsType GhcRn)
kis_rn, FreeVars
fvs) }
rnLHsTypeArg HsDocContext
_ (HsArgPar SrcSpan
sp)
= (HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
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
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn)),
FreeVars))
-> [HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))]
-> RnM
([HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))],
FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg HsDocContext
doc) [HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))]
[LHsTypeArg GhcPs]
args
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env (L loc cxt)
= do { String -> MsgDoc -> TcRn ()
traceRn String
"rncontext" ([GenLocated SrcSpan (HsType GhcPs)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [GenLocated SrcSpan (HsType GhcPs)]
cxt)
; let env' :: RnTyKiEnv
env' = RnTyKiEnv
env { rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnConstraint }
; ([Located (HsType GhcRn)]
cxt', FreeVars
fvs) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env') [GenLocated SrcSpan (HsType GhcPs)]
cxt
; (GenLocated SrcSpan [Located (HsType GhcRn)], FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan [Located (HsType GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> [Located (HsType GhcRn)]
-> GenLocated SrcSpan [Located (HsType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc [Located (HsType GhcRn)]
cxt', FreeVars
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
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env (L loc ty)
= SrcSpan
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars))
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$
do { (HsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env HsType GhcPs
ty
; (Located (HsType GhcRn), FreeVars)
-> RnM (Located (HsType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsType GhcRn -> Located (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsType GhcRn
ty', FreeVars
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 -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env 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 { (Located (HsType GhcRn)
tau', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsForAllTy :: forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
, hst_tele :: HsForAllTelescope GhcRn
hst_tele = HsForAllTelescope GhcRn
tele' , hst_body :: LHsType GhcRn
hst_body = Located (HsType GhcRn)
LHsType GhcRn
tau' }
, FreeVars
fvs) } }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(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 { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
(MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
; (GenLocated SrcSpan [Located (HsType GhcRn)]
ctxt', FreeVars
fvs1) <- RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env LHsContext GhcPs
lctxt
; (Located (HsType GhcRn)
tau', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField, hst_ctxt :: LHsContext GhcRn
hst_ctxt = GenLocated SrcSpan [Located (HsType GhcRn)]
LHsContext GhcRn
ctxt'
, hst_body :: LHsType GhcRn
hst_body = Located (HsType GhcRn)
LHsType GhcRn
tau' }
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
rnHsTyKi RnTyKiEnv
env (HsTyVar XTyVar GhcPs
_ PromotionFlag
ip (L loc 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
$ MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Unexpected kind variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
rdr_name)
, String -> MsgDoc
text String
"Perhaps you intended to use PolyKinds" ]
; Name
name <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
rdr_name
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar NoExtField
XTyVar GhcRn
noExtField PromotionFlag
ip (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
name), Name -> FreeVars
unitFV Name
name) }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsOpTy XOpTy GhcPs
_ 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 (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
LIdP GhcPs
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 { (GenLocated SrcSpan Name
l_op', FreeVars
fvs1) <- RnTyKiEnv
-> HsType GhcPs
-> Located RdrName
-> RnM (GenLocated SrcSpan Name, FreeVars)
forall a.
Outputable a =>
RnTyKiEnv
-> a -> Located RdrName -> RnM (GenLocated SrcSpan Name, FreeVars)
rnHsTyOp RnTyKiEnv
env HsType GhcPs
ty Located RdrName
LIdP GhcPs
l_op
; Fixity
fix <- GenLocated SrcSpan Name -> RnM Fixity
lookupTyFixityRn GenLocated SrcSpan Name
l_op'
; (Located (HsType GhcRn)
ty1', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
; (Located (HsType GhcRn)
ty2', FreeVars
fvs3) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
; HsType GhcRn
res_ty <- GenLocated SrcSpan Name
-> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn)
mkHsOpTyRn GenLocated SrcSpan Name
l_op' Fixity
fix Located (HsType GhcRn)
LHsType GhcRn
ty1' Located (HsType GhcRn)
LHsType GhcRn
ty2'
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType GhcRn
res_ty, [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs1, FreeVars
fvs2, FreeVars
fvs3]) }
rnHsTyKi RnTyKiEnv
env (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)
= do { (Located (HsType GhcRn)
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
ty', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env (HsBangTy XBangTy GhcPs
_ HsSrcBang
b LHsType GhcPs
ty)
= do { (Located (HsType GhcRn)
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBangTy GhcRn -> HsSrcBang -> LHsType GhcRn -> HsType GhcRn
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcRn
noExtField HsSrcBang
b Located (HsType GhcRn)
LHsType GhcRn
ty', FreeVars
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
; [FieldLabel]
fls <- HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields HsDocContext
ctxt
; ([Located (ConDeclField GhcRn)]
flds', FreeVars
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
ctxt [FieldLabel]
fls [LConDeclField GhcPs]
flds
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecTy GhcRn -> [LConDeclField GhcRn] -> HsType GhcRn
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy NoExtField
XRecTy GhcRn
noExtField [Located (ConDeclField GhcRn)]
[LConDeclField GhcRn]
flds', FreeVars
fvs) }
where
get_fields :: HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields (ConDeclCtx [GenLocated SrcSpan Name]
names)
= (GenLocated SrcSpan Name
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> [GenLocated SrcSpan Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
lookupConstructorFields (Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> (GenLocated SrcSpan Name -> Name)
-> GenLocated SrcSpan Name
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpan Name]
names
get_fields HsDocContext
_
= do { MsgDoc -> TcRn ()
addErr (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Record syntax is illegal here:")
Int
2 (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
ty))
; [FieldLabel] -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
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 { (Located (HsType GhcRn)
ty1', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
; (Located (HsType GhcRn)
ty2', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
; (HsArrow GhcRn
mult', FreeVars
w_fvs) <- RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow RnTyKiEnv
env HsArrow GhcPs
mult
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
XFunTy GhcRn
u HsArrow GhcRn
mult' Located (HsType GhcRn)
LHsType GhcRn
ty1' Located (HsType GhcRn)
LHsType GhcRn
ty2'
, [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs1, FreeVars
fvs2, FreeVars
w_fvs]) }
rnHsTyKi RnTyKiEnv
env listTy :: HsType GhcPs
listTy@(HsListTy XListTy GhcPs
_ LHsType GhcPs
ty)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
(MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
listTy))
; (Located (HsType GhcRn)
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XListTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
ty', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env (HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k)
= do { Bool
kind_sigs_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kind_sigs_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) LHsType GhcPs
ty)
; (Located (HsType GhcRn)
ty', FreeVars
lhs_fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (Located (HsType GhcRn)
k', FreeVars
sig_fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
KindLevel }) LHsType GhcPs
k
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XKindSig GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig NoExtField
XKindSig GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
ty' Located (HsType GhcRn)
LHsType GhcRn
k', FreeVars
lhs_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
sig_fvs) }
rnHsTyKi RnTyKiEnv
env tupleTy :: HsType GhcPs
tupleTy@(HsTupleTy XTupleTy GhcPs
_ HsTupleSort
tup_con HsContext GhcPs
tys)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
(MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
tupleTy))
; ([Located (HsType GhcRn)]
tys', FreeVars
fvs) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
tys
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTupleTy GhcRn -> HsTupleSort -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy NoExtField
XTupleTy GhcRn
noExtField HsTupleSort
tup_con [Located (HsType GhcRn)]
[LHsType GhcRn]
tys', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env sumTy :: HsType GhcPs
sumTy@(HsSumTy XSumTy GhcPs
_ HsContext GhcPs
tys)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
(MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
sumTy))
; ([Located (HsType GhcRn)]
tys', FreeVars
fvs) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
tys
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSumTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy NoExtField
XSumTy GhcRn
noExtField [Located (HsType GhcRn)]
[LHsType GhcRn]
tys', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env tyLit :: HsType GhcPs
tyLit@(HsTyLit XTyLit GhcPs
_ HsTyLit
t)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
tyLit))
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsTyLit -> Bool
negLit HsTyLit
t) (MsgDoc -> TcRn ()
addErr MsgDoc
negLitErr)
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyLit GhcRn -> HsTyLit -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
XTyLit GhcRn
noExtField HsTyLit
t, FreeVars
emptyFVs) }
where
negLit :: HsTyLit -> Bool
negLit (HsStrTy SourceText
_ FastString
_) = Bool
False
negLit (HsNumTy SourceText
_ Integer
i) = Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
negLitErr :: MsgDoc
negLitErr = String -> MsgDoc
text String
"Illegal literal in type (type literals must not be negative):" MsgDoc -> MsgDoc -> MsgDoc
<+> HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
tyLit
rnHsTyKi RnTyKiEnv
env (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2)
= do { (Located (HsType GhcRn)
ty1', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
; (Located (HsType GhcRn)
ty2', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
ty1' Located (HsType GhcRn)
LHsType GhcRn
ty2', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
rnHsTyKi RnTyKiEnv
env (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
k)
= do { Bool
kind_app <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kind_app (MsgDoc -> TcRn ()
addErr (String -> LHsType GhcPs -> MsgDoc
typeAppErr String
"kind" LHsType GhcPs
k))
; (Located (HsType GhcRn)
ty', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (Located (HsType GhcRn)
k', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env {rtke_level :: TypeOrKind
rtke_level = TypeOrKind
KindLevel }) LHsType GhcPs
k
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppKindTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy GhcPs
XAppKindTy GhcRn
l Located (HsType GhcRn)
LHsType GhcRn
ty' Located (HsType GhcRn)
LHsType GhcRn
k', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
rnHsTyKi RnTyKiEnv
env t :: HsType GhcPs
t@(HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
n LHsType GhcPs
ty)
= do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
notInKinds RnTyKiEnv
env HsType GhcPs
t
; (Located (HsType GhcRn)
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIParamTy GhcRn
-> XRec GhcRn HsIPName -> LHsType GhcRn -> HsType GhcRn
forall pass.
XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass
HsIParamTy NoExtField
XIParamTy GhcRn
noExtField XRec GhcPs HsIPName
XRec GhcRn HsIPName
n Located (HsType GhcRn)
LHsType GhcRn
ty', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
_ (HsStarTy XStarTy GhcPs
_ Bool
isUni)
= (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XStarTy GhcRn -> Bool -> HsType GhcRn
forall pass. XStarTy pass -> Bool -> HsType pass
HsStarTy NoExtField
XStarTy GhcRn
noExtField Bool
isUni, FreeVars
emptyFVs)
rnHsTyKi RnTyKiEnv
_ (HsSpliceTy XSpliceTy GhcPs
_ HsSplice GhcPs
sp)
= HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType HsSplice GhcPs
sp
rnHsTyKi RnTyKiEnv
env (HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty LHsDocString
haddock_doc)
= do { (Located (HsType GhcRn)
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDocTy GhcRn -> LHsType GhcRn -> LHsDocString -> HsType GhcRn
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy NoExtField
XDocTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
ty' LHsDocString
haddock_doc, FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
_ (XHsType (NHsCoreTy ty))
= (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType (Type -> NewHsTypeX
NHsCoreTy Type
ty), FreeVars
emptyFVs)
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
ip HsContext GhcPs
tys)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
; ([Located (HsType GhcRn)]
tys', FreeVars
fvs) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
tys
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitListTy GhcRn
-> PromotionFlag -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy NoExtField
XExplicitListTy GhcRn
noExtField PromotionFlag
ip [Located (HsType GhcRn)]
[LHsType GhcRn]
tys', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
tys)
= do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
; ([Located (HsType GhcRn)]
tys', FreeVars
fvs) <- (GenLocated SrcSpan (HsType GhcPs)
-> RnM (Located (HsType GhcRn), FreeVars))
-> [GenLocated SrcSpan (HsType GhcPs)]
-> RnM ([Located (HsType GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
tys
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitTupleTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy NoExtField
XExplicitTupleTy GhcRn
noExtField [Located (HsType GhcRn)]
[LHsType GhcRn]
tys', FreeVars
fvs) }
rnHsTyKi RnTyKiEnv
env (HsWildCardTy XWildCardTy GhcPs
_)
= do { RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy NoExtField
XWildCardTy GhcRn
noExtField, FreeVars
emptyFVs) }
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow RnTyKiEnv
_env (HsUnrestrictedArrow IsUnicodeSyntax
u) = (HsArrow GhcRn, FreeVars) -> RnM (HsArrow GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (IsUnicodeSyntax -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
u, FreeVars
emptyFVs)
rnHsArrow RnTyKiEnv
_env (HsLinearArrow IsUnicodeSyntax
u) = (HsArrow GhcRn, FreeVars) -> RnM (HsArrow GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (IsUnicodeSyntax -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> HsArrow pass
HsLinearArrow IsUnicodeSyntax
u, FreeVars
emptyFVs)
rnHsArrow RnTyKiEnv
env (HsExplicitMult IsUnicodeSyntax
u LHsType GhcPs
p)
= (\(Located (HsType GhcRn)
mult, FreeVars
fvs) -> (IsUnicodeSyntax -> LHsType GhcRn -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> LHsType pass -> HsArrow pass
HsExplicitMult IsUnicodeSyntax
u Located (HsType GhcRn)
LHsType GhcRn
mult, FreeVars
fvs)) ((Located (HsType GhcRn), FreeVars) -> (HsArrow GhcRn, FreeVars))
-> RnM (Located (HsType GhcRn), FreeVars)
-> RnM (HsArrow GhcRn, FreeVars)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
p
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar :: RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
rdr_name
= do { Name
name <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
rdr_name
; RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
; Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name }
rnLTyVar :: Located RdrName -> RnM (Located Name)
rnLTyVar :: Located RdrName -> RnM (GenLocated SrcSpan Name)
rnLTyVar (L SrcSpan
loc RdrName
rdr_name)
= do { Name
tyvar <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
rdr_name
; GenLocated SrcSpan Name -> RnM (GenLocated SrcSpan Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
tyvar) }
rnHsTyOp :: Outputable a
=> RnTyKiEnv -> a -> Located RdrName
-> RnM (Located Name, FreeVars)
rnHsTyOp :: RnTyKiEnv
-> a -> Located RdrName -> RnM (GenLocated SrcSpan Name, FreeVars)
rnHsTyOp RnTyKiEnv
env a
overall_ty (L SrcSpan
loc RdrName
op)
= do { Bool
ops_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeOperators
; Name
op' <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
op
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
ops_ok Bool -> Bool -> Bool
|| Name
op' Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
MsgDoc -> TcRn ()
addErr (RdrName -> a -> MsgDoc
forall a. Outputable a => RdrName -> a -> MsgDoc
opTyErr RdrName
op a
overall_ty)
; let l_op' :: GenLocated SrcSpan Name
l_op' = SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
op'
; (GenLocated SrcSpan Name, FreeVars)
-> RnM (GenLocated SrcSpan Name, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan Name
l_op', Name -> FreeVars
unitFV Name
op') }
notAllowed :: SDoc -> SDoc
notAllowed :: MsgDoc -> MsgDoc
notAllowed MsgDoc
doc
= String -> MsgDoc
text String
"Wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"not allowed")
checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard :: RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env (Just MsgDoc
doc)
= MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [MsgDoc
doc, Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"in" MsgDoc -> MsgDoc -> MsgDoc
<+> HsDocContext -> MsgDoc
pprHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env))]
checkWildCard RnTyKiEnv
_ Maybe MsgDoc
Nothing
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAnonWildCard :: RnTyKiEnv -> RnM ()
checkAnonWildCard :: RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
= RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
where
mb_bad :: Maybe SDoc
mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
= MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> MsgDoc
notAllowed MsgDoc
pprAnonWildCard)
| Bool
otherwise
= case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
RnTyKiWhat
RnTypeBody -> Maybe MsgDoc
forall a. Maybe a
Nothing
RnTyKiWhat
RnTopConstraint -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
RnTyKiWhat
RnConstraint -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
constraint_msg :: MsgDoc
constraint_msg = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang
(MsgDoc -> MsgDoc
notAllowed MsgDoc
pprAnonWildCard MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"in a constraint")
Int
2 MsgDoc
hint_msg
hint_msg :: MsgDoc
hint_msg = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"except as the last top-level constraint of a type signature"
, Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"e.g f :: (Eq a, _) => blah") ]
checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
checkNamedWildCard :: RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
= RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
where
mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (Name
name Name -> FreeVars -> Bool
`elemNameSet` RnTyKiEnv -> FreeVars
rtke_nwcs RnTyKiEnv
env)
= Maybe MsgDoc
forall a. Maybe a
Nothing
| Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
= MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name))
| Bool
otherwise
= case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
RnTyKiWhat
RnTypeBody -> Maybe MsgDoc
forall a. Maybe a
Nothing
RnTyKiWhat
RnTopConstraint -> Maybe MsgDoc
forall a. Maybe a
Nothing
RnTyKiWhat
RnConstraint -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
constraint_msg :: MsgDoc
constraint_msg = MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"in a constraint"
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 :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
checkPolyKinds :: RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env ty
ty
| RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
= do { Bool
polykinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
polykinds (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
MsgDoc -> TcRn ()
addErr (String -> MsgDoc
text String
"Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty MsgDoc -> MsgDoc -> MsgDoc
$$
String -> MsgDoc
text String
"Did you mean to enable PolyKinds?") }
checkPolyKinds RnTyKiEnv
_ ty
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notInKinds :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
notInKinds :: RnTyKiEnv -> ty -> TcRn ()
notInKinds RnTyKiEnv
env ty
ty
| RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
= MsgDoc -> TcRn ()
addErr (String -> MsgDoc
text String
"Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty)
notInKinds RnTyKiEnv
_ ty
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV [Name]
tvs RnM (a, FreeVars)
thing_inside
= do { Bool
scoped_tyvars <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
; if Bool -> Bool
not Bool
scoped_tyvars then
RnM (a, FreeVars)
thing_inside
else
[Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
tvs RnM (a, FreeVars)
thing_inside }
bindHsQTyVars :: forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars :: HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe a
mb_assoc FreeKiTyVars
body_kv_occs LHsQTyVars GhcPs
hsq_bndrs LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside
= do { let bndr_kv_occs :: FreeKiTyVars
bndr_kv_occs = [LHsTyVarBndr () GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs [LHsTyVarBndr () GhcPs]
hs_tv_bndrs
; let
bndrs, implicit_kvs :: [Located RdrName]
bndrs :: FreeKiTyVars
bndrs = (Located (HsTyVarBndr () GhcPs) -> Located RdrName)
-> [Located (HsTyVarBndr () GhcPs)] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map Located (HsTyVarBndr () GhcPs) -> Located RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [Located (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
hs_tv_bndrs
implicit_kvs :: FreeKiTyVars
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
all_bound_on_lhs :: Bool
all_bound_on_lhs = FreeKiTyVars -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FreeKiTyVars
body_remaining
; String -> MsgDoc -> TcRn ()
traceRn String
"checkMixedVars3" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"bndrs" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located (HsTyVarBndr () GhcPs)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
hs_tv_bndrs
, String -> MsgDoc
text String
"bndr_kv_occs" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
bndr_kv_occs
, String -> MsgDoc
text String
"body_kv_occs" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
body_kv_occs
, String -> MsgDoc
text String
"implicit_kvs" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_kvs
, String -> MsgDoc
text String
"body_remaining" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
body_remaining
]
; Maybe a
-> FreeKiTyVars
-> ([Name] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe a
mb_assoc FreeKiTyVars
implicit_kvs (([Name] -> RnM (b, FreeVars)) -> RnM (b, FreeVars))
-> ([Name] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
implicit_kv_nms' ->
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
NoWarnUnusedForalls Maybe a
mb_assoc [LHsTyVarBndr () GhcPs]
hs_tv_bndrs (([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars))
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr () GhcRn]
rn_bndrs ->
do { let
implicit_kv_nms :: [Name]
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'
; String -> MsgDoc -> TcRn ()
traceRn String
"bindHsQTyVars" (LHsQTyVars GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsQTyVars GhcPs
hsq_bndrs MsgDoc -> MsgDoc -> MsgDoc
$$ [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
implicit_kv_nms MsgDoc -> MsgDoc -> MsgDoc
$$ [Located (HsTyVarBndr () GhcRn)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
rn_bndrs)
; LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside (HsQTvs :: forall pass.
XHsQTvs pass -> [LHsTyVarBndr () pass] -> LHsQTyVars pass
HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = [Name]
XHsQTvs GhcRn
implicit_kv_nms
, hsq_explicit :: [LHsTyVarBndr () GhcRn]
hsq_explicit = [LHsTyVarBndr () GhcRn]
rn_bndrs })
Bool
all_bound_on_lhs } }
where
hs_tv_bndrs :: [LHsTyVarBndr () GhcPs]
hs_tv_bndrs = LHsQTyVars GhcPs -> [LHsTyVarBndr () GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsQTvExplicit LHsQTyVars GhcPs
hsq_bndrs
bndrs_loc :: SrcSpan
bndrs_loc = case (Located (HsTyVarBndr () GhcPs) -> SrcSpan)
-> [Located (HsTyVarBndr () GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (HsTyVarBndr () GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [Located (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () GhcPs]
hs_tv_bndrs [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (Located RdrName -> SrcSpan) -> FreeKiTyVars -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc FreeKiTyVars
body_kv_occs of
[] -> String -> SrcSpan
forall a. 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. [a] -> a
last [SrcSpan]
locs
bindHsOuterTyVarBndrs :: OutputableBndrFlag flag
=> HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs :: 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)
rnImplicitBndrs 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 :: forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
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 Any
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr flag GhcPs]
[LHsTyVarBndr flag (NoGhcTc 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' ->
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 :: forall flag pass.
XHsOuterExplicit pass flag
-> [LHsTyVarBndr flag (NoGhcTc pass)]
-> HsOuterTyVarBndrs flag pass
HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcRn flag
hso_xexplicit = NoExtField
XHsOuterExplicit GhcRn flag
noExtField
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcRn)]
hso_bndrs = [LHsTyVarBndr flag GhcRn]
[LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs' }
bindHsForAllTelescope :: HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope :: 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 Any
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
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' ->
HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr () GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
[LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele [LHsTyVarBndr () GhcRn]
bndrs'
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } ->
HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
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' ->
HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
[LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele [LHsTyVarBndr Specificity GhcRn]
bndrs'
data WarnUnusedForalls
= WarnUnusedForalls
| NoWarnUnusedForalls
instance Outputable WarnUnusedForalls where
ppr :: WarnUnusedForalls -> MsgDoc
ppr WarnUnusedForalls
wuf = String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ case WarnUnusedForalls
wuf of
WarnUnusedForalls
WarnUnusedForalls -> String
"WarnUnusedForalls"
WarnUnusedForalls
NoWarnUnusedForalls -> String
"NoWarnUnusedForalls"
bindLHsTyVarBndrs :: (OutputableBndrFlag flag)
=> HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs :: 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
; [Located (HsTyVarBndr flag GhcPs)]
-> ([Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [Located (HsTyVarBndr flag GhcPs)]
[LHsTyVarBndr flag GhcPs]
tv_bndrs [Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars)
[LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside }
where
tv_names_w_loc :: FreeKiTyVars
tv_names_w_loc = (Located (HsTyVarBndr flag GhcPs) -> Located RdrName)
-> [Located (HsTyVarBndr flag GhcPs)] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map Located (HsTyVarBndr flag GhcPs) -> Located RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [Located (HsTyVarBndr flag GhcPs)]
[LHsTyVarBndr flag GhcPs]
tv_bndrs
go :: [Located (HsTyVarBndr flag GhcPs)]
-> ([Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [] [Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars)
thing_inside = [Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars)
thing_inside []
go (Located (HsTyVarBndr flag GhcPs)
b:[Located (HsTyVarBndr flag GhcPs)]
bs) [Located (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 Located (HsTyVarBndr flag GhcPs)
LHsTyVarBndr 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 { (b
res, FreeVars
fvs) <- [Located (HsTyVarBndr flag GhcPs)]
-> ([Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [Located (HsTyVarBndr flag GhcPs)]
bs (([Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars))
-> RnM (b, FreeVars))
-> ([Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Located (HsTyVarBndr flag GhcRn)]
bs' ->
[Located (HsTyVarBndr flag GhcRn)] -> RnM (b, FreeVars)
thing_inside (Located (HsTyVarBndr flag GhcRn)
LHsTyVarBndr flag GhcRn
b' Located (HsTyVarBndr flag GhcRn)
-> [Located (HsTyVarBndr flag GhcRn)]
-> [Located (HsTyVarBndr flag GhcRn)]
forall a. a -> [a] -> [a]
: [Located (HsTyVarBndr flag GhcRn)]
bs')
; Located (HsTyVarBndr flag GhcRn) -> FreeVars -> TcRn ()
warn_unused Located (HsTyVarBndr flag GhcRn)
LHsTyVarBndr flag GhcRn
b' FreeVars
fvs
; (b, FreeVars) -> RnM (b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, FreeVars
fvs) }
warn_unused :: Located (HsTyVarBndr flag GhcRn) -> FreeVars -> TcRn ()
warn_unused Located (HsTyVarBndr flag GhcRn)
tv_bndr FreeVars
fvs = case WarnUnusedForalls
wuf of
WarnUnusedForalls
WarnUnusedForalls -> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
forall flag.
OutputableBndrFlag flag =>
HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc Located (HsTyVarBndr flag GhcRn)
LHsTyVarBndr flag GhcRn
tv_bndr FreeVars
fvs
WarnUnusedForalls
NoWarnUnusedForalls -> () -> TcRn ()
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 :: HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
_doc Maybe a
mb_assoc (L loc
(UserTyVar x fl
lrdr@(L lv _))) LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside
= do { Name
nm <- Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc Located RdrName
LIdP GhcPs
lrdr
; [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name
nm] (RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$
LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan
-> HsTyVarBndr flag GhcRn
-> GenLocated SrcSpan (HsTyVarBndr flag GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUserTyVar GhcRn -> flag -> LIdP GhcRn -> HsTyVarBndr flag GhcRn
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
XUserTyVar GhcRn
x flag
fl (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv Name
nm))) }
bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))
LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside
= do { Bool
sig_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sig_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc LHsType GhcPs
kind)
; (Located (HsType GhcRn)
kind', FreeVars
fvs1) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
; Name
tv_nm <- Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc Located RdrName
LIdP GhcPs
lrdr
; (b
b, FreeVars
fvs2) <- [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name
tv_nm]
(RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan
-> HsTyVarBndr flag GhcRn
-> GenLocated SrcSpan (HsTyVarBndr flag GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XKindedTyVar GhcRn
-> flag -> LIdP GhcRn -> LHsType GhcRn -> HsTyVarBndr flag GhcRn
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
XKindedTyVar GhcRn
x flag
fl (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv Name
tv_nm) Located (HsType GhcRn)
LHsType GhcRn
kind'))
; (b, FreeVars) -> RnM (b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
newTyVarNameRn :: Maybe a
-> Located RdrName -> RnM Name
newTyVarNameRn :: Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc lrdr :: Located RdrName
lrdr@(L SrcSpan
_ RdrName
rdr)
= do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; case (Maybe a
mb_assoc, LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv LocalRdrEnv
rdr_env RdrName
rdr) of
(Just a
_, Just Name
n) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
(Maybe a, Maybe Name)
_ -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn Located 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
= (Located (ConDeclField GhcPs)
-> RnM (Located (ConDeclField GhcRn), FreeVars))
-> [Located (ConDeclField GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([Located (ConDeclField GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env) [Located (ConDeclField GhcPs)]
[LConDeclField 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 [ (FieldLabel -> FastString
forall a. FieldLbl a -> FastString
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 l (ConDeclField _ names ty haddock_doc))
= do { let new_names :: [GenLocated SrcSpan (FieldOcc GhcRn)]
new_names = (GenLocated SrcSpan (FieldOcc GhcPs)
-> GenLocated SrcSpan (FieldOcc GhcRn))
-> [GenLocated SrcSpan (FieldOcc GhcPs)]
-> [GenLocated SrcSpan (FieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldOcc GhcPs -> FieldOcc GhcRn)
-> GenLocated SrcSpan (FieldOcc GhcPs)
-> GenLocated SrcSpan (FieldOcc GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldOcc GhcPs -> FieldOcc GhcRn
lookupField) [GenLocated SrcSpan (FieldOcc GhcPs)]
[LFieldOcc GhcPs]
names
; (Located (HsType GhcRn)
new_ty, FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
; (Located (ConDeclField GhcRn), FreeVars)
-> RnM (Located (ConDeclField GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> ConDeclField GhcRn -> Located (ConDeclField GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XConDeclField GhcRn
-> [LFieldOcc GhcRn]
-> LHsType GhcRn
-> Maybe LHsDocString
-> ConDeclField GhcRn
forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField NoExtField
XConDeclField GhcRn
noExtField [GenLocated SrcSpan (FieldOcc GhcRn)]
[LFieldOcc GhcRn]
new_names Located (HsType GhcRn)
LHsType GhcRn
new_ty Maybe LHsDocString
haddock_doc)
, FreeVars
fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpan
lr RdrName
rdr)) =
XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl) (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
lr RdrName
rdr)
where
lbl :: FastString
lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
rdr
fl :: FieldLabel
fl = String -> Maybe FieldLabel -> FieldLabel
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"rnField" (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 :: Located Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn :: GenLocated SrcSpan Name
-> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn)
mkHsOpTyRn GenLocated SrcSpan Name
op1 Fixity
fix1 LHsType GhcRn
ty1 (L loc2 (HsOpTy _ ty21 op2 ty22))
= do { Fixity
fix2 <- GenLocated SrcSpan Name -> RnM Fixity
lookupTyFixityRn GenLocated SrcSpan Name
LIdP GhcRn
op2
; GenLocated SrcSpan Name
-> Fixity
-> LHsType GhcRn
-> GenLocated SrcSpan Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty GenLocated SrcSpan Name
op1 Fixity
fix1 LHsType GhcRn
ty1 GenLocated SrcSpan Name
LIdP GhcRn
op2 Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2 }
mkHsOpTyRn GenLocated SrcSpan Name
op1 Fixity
_ LHsType GhcRn
ty1 LHsType GhcRn
ty2
= HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpTy GhcRn
-> LHsType GhcRn -> LIdP GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField LHsType GhcRn
ty1 GenLocated SrcSpan Name
LIdP GhcRn
op1 LHsType GhcRn
ty2)
mk_hs_op_ty :: Located Name -> Fixity -> LHsType GhcRn
-> Located Name -> Fixity -> LHsType GhcRn
-> LHsType GhcRn -> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty :: GenLocated SrcSpan Name
-> Fixity
-> LHsType GhcRn
-> GenLocated SrcSpan Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty GenLocated SrcSpan Name
op1 Fixity
fix1 LHsType GhcRn
ty1 GenLocated SrcSpan Name
op2 Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2
| Bool
nofix_error = do { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
op1),Fixity
fix1)
(Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
op2),Fixity
fix2)
; HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsType GhcRn)
LHsType GhcRn
ty1 Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op1ty` (SrcSpan -> HsType GhcRn -> Located (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc2 (Located (HsType GhcRn)
LHsType GhcRn
ty21 Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op2ty` Located (HsType GhcRn)
LHsType GhcRn
ty22))) }
| Bool
associate_right = HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsType GhcRn)
LHsType GhcRn
ty1 Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op1ty` (SrcSpan -> HsType GhcRn -> Located (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc2 (Located (HsType GhcRn)
LHsType GhcRn
ty21 Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op2ty` Located (HsType GhcRn)
LHsType GhcRn
ty22)))
| Bool
otherwise = do {
HsType GhcRn
new_ty <- GenLocated SrcSpan Name
-> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn)
mkHsOpTyRn GenLocated SrcSpan Name
op1 Fixity
fix1 LHsType GhcRn
ty1 LHsType GhcRn
ty21
; HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType GhcRn -> Located (HsType GhcRn)
forall e. e -> Located e
noLoc HsType GhcRn
new_ty Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op2ty` Located (HsType GhcRn)
LHsType GhcRn
ty22) }
where
Located (HsType GhcRn)
lhs op1ty :: Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op1ty` Located (HsType GhcRn)
rhs = XOpTy GhcRn
-> LHsType GhcRn -> LIdP GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
lhs GenLocated SrcSpan Name
LIdP GhcRn
op1 Located (HsType GhcRn)
LHsType GhcRn
rhs
Located (HsType GhcRn)
lhs op2ty :: Located (HsType GhcRn) -> Located (HsType GhcRn) -> HsType GhcRn
`op2ty` Located (HsType GhcRn)
rhs = XOpTy GhcRn
-> LHsType GhcRn -> LIdP GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
lhs GenLocated SrcSpan Name
LIdP GhcRn
op2 Located (HsType GhcRn)
LHsType GhcRn
rhs
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
mkOpAppRn :: LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn :: LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn e1 :: LHsExpr GhcRn
e1@(L _ (OpApp fix1 e11 op1 e12)) 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,XOpApp GhcRn
Fixity
fix1) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
HsExpr GhcRn -> RnM (HsExpr GhcRn)
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 XOpApp GhcRn
Fixity
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)
| Bool
associate_right = do
HsExpr GhcRn
new_e <- LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn LHsExpr GhcRn
e12 LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
HsExpr GhcRn -> RnM (HsExpr GhcRn)
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 XOpApp GhcRn
fix1 LHsExpr GhcRn
e11 LHsExpr GhcRn
op1 (SrcSpan -> HsExpr GhcRn -> GenLocated SrcSpan (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' HsExpr GhcRn
new_e))
where
loc' :: SrcSpan
loc'= GenLocated SrcSpan (HsExpr GhcRn)
-> GenLocated SrcSpan (HsExpr GhcRn) -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr GhcRn
e12 GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr GhcRn
e2
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity XOpApp GhcRn
Fixity
fix1 Fixity
fix2
mkOpAppRn e1 :: LHsExpr GhcRn
e1@(L _ (NegApp _ neg_arg 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 (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 XOpApp GhcRn
Fixity
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)
| Bool
associate_right
= do HsExpr GhcRn
new_e <- LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn LHsExpr GhcRn
neg_arg LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
HsExpr GhcRn -> RnM (HsExpr GhcRn)
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 NoExtField
XNegApp GhcRn
noExtField (SrcSpan -> HsExpr GhcRn -> GenLocated SrcSpan (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' HsExpr GhcRn
new_e) SyntaxExpr GhcRn
neg_name)
where
loc' :: SrcSpan
loc' = GenLocated SrcSpan (HsExpr GhcRn)
-> GenLocated SrcSpan (HsExpr GhcRn) -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr GhcRn
neg_arg GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr GhcRn
e2
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2
mkOpAppRn LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 Fixity
fix1 e2 :: LHsExpr GhcRn
e2@(L _ (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 (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 XOpApp GhcRn
Fixity
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 LHsExpr GhcRn
e1 LHsExpr GhcRn
op Fixity
fix LHsExpr GhcRn
e2
= ASSERT2( right_op_ok fix (unLoc e2),
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
HsExpr GhcRn -> RnM (HsExpr GhcRn)
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 XOpApp GhcRn
Fixity
fix LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2)
data OpName = NormalOp Name
| NegateOp
| UnboundOp OccName
| RecFldOp (AmbiguousFieldOcc GhcRn)
instance Outputable OpName where
ppr :: OpName -> MsgDoc
ppr (NormalOp Name
n) = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
n
ppr OpName
NegateOp = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
negateName
ppr (UnboundOp OccName
uv) = OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OccName
uv
ppr (RecFldOp AmbiguousFieldOcc GhcRn
fld) = AmbiguousFieldOcc GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr AmbiguousFieldOcc GhcRn
fld
get_op :: LHsExpr GhcRn -> OpName
get_op :: LHsExpr GhcRn -> OpName
get_op (L _ (HsVar _ n)) = Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
LIdP GhcRn
n)
get_op (L _ (HsUnboundVar _ uv)) = OccName -> OpName
UnboundOp OccName
uv
get_op (L _ (HsRecFld _ fld)) = AmbiguousFieldOcc GhcRn -> OpName
RecFldOp AmbiguousFieldOcc GhcRn
fld
get_op LHsExpr GhcRn
other = String -> MsgDoc -> OpName
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"get_op" (GenLocated SrcSpan (HsExpr GhcRn) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr 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 XOpApp GhcRn
Fixity
fix2
right_op_ok Fixity
_ HsExpr GhcRn
_
= Bool
True
mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
-> RnM (HsExpr (GhcPass id))
mkNegAppRn :: LHsExpr (GhcPass id)
-> SyntaxExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))
mkNegAppRn LHsExpr (GhcPass id)
neg_arg SyntaxExpr (GhcPass id)
neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
HsExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp (GhcPass id)
-> LHsExpr (GhcPass id)
-> SyntaxExpr (GhcPass id)
-> HsExpr (GhcPass id)
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp NoExtField
XNegApp (GhcPass id)
noExtField LHsExpr (GhcPass id)
neg_arg SyntaxExpr (GhcPass id)
neg_name)
not_op_app :: HsExpr id -> Bool
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp {}) = Bool
False
not_op_app HsExpr id
_ = Bool
True
mkOpFormRn :: LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsCmdTop GhcRn
-> RnM (HsCmd GhcRn)
mkOpFormRn :: LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsCmdTop GhcRn -> RnM (HsCmd GhcRn)
mkOpFormRn a1 :: LHsCmdTop GhcRn
a1@(L loc
(HsCmdTop _
(L _ (HsCmdArrForm x op1 f (Just fix1)
[a11,a12]))))
LHsExpr GhcRn
op2 Fixity
fix2 LHsCmdTop GhcRn
a2
| Bool
nofix_error
= do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,Fixity
fix1) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcRn
x LHsExpr GhcRn
op2 LexicalFixity
f (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix2) [LHsCmdTop GhcRn
a1, LHsCmdTop GhcRn
a2])
| Bool
associate_right
= do HsCmd GhcRn
new_c <- LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsCmdTop GhcRn -> RnM (HsCmd GhcRn)
mkOpFormRn LHsCmdTop GhcRn
a12 LHsExpr GhcRn
op2 Fixity
fix2 LHsCmdTop GhcRn
a2
HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExtField
XCmdArrForm GhcRn
noExtField LHsExpr GhcRn
op1 LexicalFixity
f (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix1)
[LHsCmdTop GhcRn
a11, SrcSpan -> HsCmdTop GhcRn -> GenLocated SrcSpan (HsCmdTop GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCmdTop GhcRn -> LHsCmd GhcRn -> HsCmdTop GhcRn
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop [] (SrcSpan -> HsCmd GhcRn -> GenLocated SrcSpan (HsCmd GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsCmd GhcRn
new_c))])
where
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
mkOpFormRn LHsCmdTop GhcRn
arg1 LHsExpr GhcRn
op Fixity
fix LHsCmdTop GhcRn
arg2
= HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExtField
XCmdArrForm GhcRn
noExtField LHsExpr GhcRn
op LexicalFixity
Infix (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix) [LHsCmdTop GhcRn
arg1, LHsCmdTop GhcRn
arg2])
mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
mkConOpPatRn :: GenLocated SrcSpan Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn GenLocated SrcSpan Name
op2 Fixity
fix2 p1 :: LPat GhcRn
p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) LPat GhcRn
p2
= do { Fixity
fix1 <- Name -> RnM Fixity
lookupFixityRn (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op1)
; let (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
; if Bool
nofix_error then do
{ (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op1),Fixity
fix1)
(Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
op2),Fixity
fix2)
; Pat GhcRn -> RnM (Pat GhcRn)
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 :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op2
, pat_args :: HsConPatDetails GhcRn
pat_args = Located (Pat GhcRn)
-> Located (Pat GhcRn)
-> HsConDetails
(Located (Pat GhcRn)) (HsRecFields GhcRn (Located (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcRn)
LPat GhcRn
p1 Located (Pat GhcRn)
LPat GhcRn
p2
}
}
else if Bool
associate_right then do
{ Pat GhcRn
new_p <- GenLocated SrcSpan Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn GenLocated SrcSpan Name
op2 Fixity
fix2 LPat GhcRn
p12 LPat GhcRn
p2
; Pat GhcRn -> RnM (Pat GhcRn)
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 :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = XRec GhcRn (ConLikeP GhcRn)
op1
, pat_args :: HsConPatDetails GhcRn
pat_args = Located (Pat GhcRn)
-> Located (Pat GhcRn)
-> HsConDetails
(Located (Pat GhcRn)) (HsRecFields GhcRn (Located (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcRn)
LPat GhcRn
p11 (SrcSpan -> Pat GhcRn -> Located (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Pat GhcRn
new_p)
}
}
else Pat GhcRn -> RnM (Pat GhcRn)
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 :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op2
, pat_args :: HsConPatDetails GhcRn
pat_args = Located (Pat GhcRn)
-> Located (Pat GhcRn)
-> HsConDetails
(Located (Pat GhcRn)) (HsRecFields GhcRn (Located (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcRn)
LPat GhcRn
p1 Located (Pat GhcRn)
LPat GhcRn
p2
}
}
mkConOpPatRn GenLocated SrcSpan Name
op Fixity
_ LPat GhcRn
p1 LPat GhcRn
p2
= ASSERT( not_op_pat (unLoc p2) )
Pat GhcRn -> RnM (Pat GhcRn)
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 :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op
, pat_args :: HsConPatDetails GhcRn
pat_args = Located (Pat GhcRn)
-> Located (Pat GhcRn)
-> HsConDetails
(Located (Pat GhcRn)) (HsRecFields GhcRn (Located (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcRn)
LPat GhcRn
p1 Located (Pat GhcRn)
LPat GhcRn
p2
}
not_op_pat :: Pat GhcRn -> Bool
not_op_pat :: Pat GhcRn -> Bool
not_op_pat (ConPat XConPat GhcRn
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 :: 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 _ ms) })
= (GenLocated SrcSpan (Match GhcRn body) -> TcRn ())
-> [GenLocated SrcSpan (Match GhcRn body)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated SrcSpan (Match GhcRn body) -> TcRn ()
check [GenLocated SrcSpan (Match GhcRn body)]
ms
where
check :: GenLocated SrcSpan (Match GhcRn body) -> TcRn ()
check (L SrcSpan
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = (L l1 p1)
: (L l2 p2)
: [LPat GhcRn]
_ }))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
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 SrcSpan (Match GhcRn body)
_ = () -> TcRn ()
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 XRec GhcRn (ConLikeP GhcRn)
op1 (InfixCon LPat GhcRn
_ LPat GhcRn
_)) Bool
right = do
op_fix :: Fixity
op_fix@(Fixity SourceText
_ Int
op_prec FixityDirection
op_dir) <- Name -> RnM Fixity
lookupFixityRn Name
op
op1_fix :: Fixity
op1_fix@(Fixity SourceText
_ Int
op1_prec FixityDirection
op1_dir) <- Name -> RnM Fixity
lookupFixityRn (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op1)
let
inf_ok :: Bool
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 :: (OpName, Fixity)
info = (Name -> OpName
NormalOp Name
op, Fixity
op_fix)
info1 :: (OpName, Fixity)
info1 = (Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
XRec GhcRn (ConLikeP GhcRn)
op1), Fixity
op1_fix)
((OpName, Fixity)
infol, (OpName, Fixity)
infor) = if Bool
right then ((OpName, Fixity)
info, (OpName, Fixity)
info1) else ((OpName, Fixity)
info1, (OpName, Fixity)
info)
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inf_ok ((OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (OpName, Fixity)
infol (OpName, Fixity)
infor)
checkPrec Name
_ Pat GhcRn
_ Bool
_
= () -> TcRn ()
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 SrcSpan (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (HsExpr GhcRn)
LHsExpr 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') XOpApp GhcRn
Fixity
fix
NegApp XNegApp GhcRn
_ LHsExpr GhcRn
_ SyntaxExpr GhcRn
_ -> OpName -> Fixity -> TcRn ()
go_for_it OpName
NegateOp Fixity
negateFixity
HsExpr GhcRn
_ -> () -> TcRn ()
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 SourceText
_ Int
arg_prec FixityDirection
assoc) = do
op_fix :: Fixity
op_fix@(Fixity SourceText
_ Int
op_prec FixityDirection
_) <- OpName -> RnM Fixity
lookupFixityOp OpName
op_name
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
op_prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arg_prec
Bool -> Bool -> Bool
|| (Int
op_prec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arg_prec Bool -> Bool -> Bool
&& FixityDirection
direction FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
assoc))
((OpName, Fixity) -> (OpName, Fixity) -> HsExpr GhcPs -> TcRn ()
sectionPrecErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op, Fixity
op_fix)
(OpName
arg_op, Fixity
arg_fix) HsExpr GhcPs
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 OccName
u) = Name -> RnM Fixity
lookupFixityRn (OccName -> Name
mkUnboundName OccName
u)
lookupFixityOp (RecFldOp AmbiguousFieldOcc GhcRn
f) = AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn AmbiguousFieldOcc 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 (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Precedence parsing error")
Int
4 ([MsgDoc] -> MsgDoc
hsep [String -> MsgDoc
text String
"cannot mix", (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op1, PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"and"),
(OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op2,
String -> MsgDoc
text String
"in the same infix expression"])
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 (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text String
"The operator" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"of a section"),
Int -> MsgDoc -> MsgDoc
nest Int
4 ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"must have lower precedence than that of the operand,",
Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"namely" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
arg_op)]),
Int -> MsgDoc -> MsgDoc
nest Int
4 (String -> MsgDoc
text String
"in the section:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr 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
ppr_opfix :: (OpName, Fixity) -> SDoc
ppr_opfix :: (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName
op, Fixity
fixity) = MsgDoc
pp_op MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
brackets (Fixity -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Fixity
fixity)
where
pp_op :: MsgDoc
pp_op | OpName
NegateOp <- OpName
op = String -> MsgDoc
text String
"prefix `-'"
| Bool
otherwise = MsgDoc -> MsgDoc
quotes (OpName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OpName
op)
unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc
unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> MsgDoc
unexpectedPatSigTypeErr HsPatSigType GhcPs
ty
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal type signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsPatSigType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsPatSigType GhcPs
ty))
Int
2 (String -> MsgDoc
text String
"Type signatures are only allowed in patterns with ScopedTypeVariables")
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc (L loc ty)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
doc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal kind signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
ty))
Int
2 (String -> MsgDoc
text String
"Perhaps you intended to use KindSignatures")
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
thing
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
pp_what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
thing))
Int
2 (String -> MsgDoc
text String
"Perhaps you intended to use DataKinds")
where
pp_what :: MsgDoc
pp_what | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env = String -> MsgDoc
text String
"kind"
| Bool
otherwise = String -> MsgDoc
text String
"type"
warnUnusedForAll :: OutputableBndrFlag flag
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll :: HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc (L loc tv) FreeVars
used_names
= WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedForalls (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HsTyVarBndr flag GhcRn -> IdP GhcRn
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName HsTyVarBndr flag GhcRn
tv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedForalls) SrcSpan
loc (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Unused quantified type variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsTyVarBndr flag GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsTyVarBndr flag GhcRn
tv)
, HsDocContext -> MsgDoc
inHsDocContext HsDocContext
doc ]
opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr :: RdrName -> a -> MsgDoc
opTyErr RdrName
op a
overall_ty
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal operator" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
op) MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"in type") MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
overall_ty))
Int
2 (String -> MsgDoc
text String
"Use TypeOperators to allow operators in types")
type FreeKiTyVars = [Located RdrName]
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope LocalRdrEnv
rdr_env = (Located RdrName -> Bool) -> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut (LocalRdrEnv -> RdrName -> Bool
inScope LocalRdrEnv
rdr_env (RdrName -> Bool)
-> (Located RdrName -> RdrName) -> Located RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM FreeKiTyVars
vars
= do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; FreeKiTyVars -> RnM FreeKiTyVars
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope LocalRdrEnv
rdr_env FreeKiTyVars
vars) }
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope LocalRdrEnv
rdr_env RdrName
rdr = RdrName
rdr RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
(HsValArg LHsType GhcPs
ty) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
extract_tyarg (HsTypeArg SrcSpan
_ LHsType GhcPs
ki) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki FreeKiTyVars
acc
extract_tyarg (HsArgPar SrcSpan
_) FreeKiTyVars
acc = FreeKiTyVars
acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
[LHsTypeArg GhcPs]
args FreeKiTyVars
acc = (HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))]
-> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars
LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_tyarg FreeKiTyVars
acc [HsArg
(GenLocated SrcSpan (HsType GhcPs))
(GenLocated SrcSpan (HsType GhcPs))]
[LHsTypeArg 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 _ 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 _ resultSig) = case FamilyResultSig GhcPs
resultSig of
KindSig XCKindSig GhcPs
_ LHsType GhcPs
k -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
k
TyVarSig XTyVarSig GhcPs
_ (L _ (KindedTyVar _ _ _ k)) -> 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 [HsScaled GhcPs (LHsType GhcPs)]
args -> [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
extract_scaled_ltys [HsScaled GhcPs (LHsType GhcPs)]
args
RecConGADT (L _ flds) -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys (HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars)
-> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ (Located (ConDeclField GhcPs) -> GenLocated SrcSpan (HsType GhcPs))
-> [Located (ConDeclField GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ConDeclField GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> (Located (ConDeclField GhcPs) -> ConDeclField GhcPs)
-> Located (ConDeclField GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (ConDeclField GhcPs) -> ConDeclField GhcPs
forall l e. GenLocated l e -> e
unLoc) ([Located (ConDeclField GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)])
-> [Located (ConDeclField GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ [Located (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 SrcSpan (HsType GhcPs) -> FreeKiTyVars)
-> Maybe (GenLocated SrcSpan (HsType GhcPs))
-> FreeKiTyVars
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars
LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars Maybe (GenLocated SrcSpan (HsType GhcPs))
Maybe (LHsType GhcPs)
ksig
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
LHsContext GhcPs
ctxt = HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys (GenLocated SrcSpan [GenLocated SrcSpan (HsType GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan [GenLocated SrcSpan (HsType GhcPs)]
LHsContext GhcPs
ctxt)
extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
-> FreeKiTyVars -> FreeKiTyVars
[HsScaled GhcPs (LHsType GhcPs)]
args FreeKiTyVars
acc = (HsScaled GhcPs (GenLocated SrcSpan (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [HsScaled GhcPs (GenLocated SrcSpan (HsType GhcPs))]
-> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsScaled GhcPs (GenLocated SrcSpan (HsType GhcPs))
-> FreeKiTyVars -> FreeKiTyVars
HsScaled GhcPs (LHsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars
extract_scaled_lty FreeKiTyVars
acc [HsScaled GhcPs (GenLocated SrcSpan (HsType GhcPs))]
[HsScaled GhcPs (LHsType 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 SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [GenLocated SrcSpan (HsType GhcPs)]
-> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty FreeKiTyVars
acc [GenLocated SrcSpan (HsType GhcPs)]
HsContext GhcPs
tys
extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
(L _ ty) FreeKiTyVars
acc
= case HsType GhcPs
ty of
HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
ltv -> Located RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv Located RdrName
LIdP GhcPs
ltv FreeKiTyVars
acc
HsBangTy XBangTy GhcPs
_ HsSrcBang
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
flds -> (Located (ConDeclField GhcPs) -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars -> [Located (ConDeclField GhcPs)] -> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty
(GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars)
-> (Located (ConDeclField GhcPs)
-> GenLocated SrcSpan (HsType GhcPs))
-> Located (ConDeclField GhcPs)
-> FreeKiTyVars
-> FreeKiTyVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> (Located (ConDeclField GhcPs) -> ConDeclField GhcPs)
-> Located (ConDeclField GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (ConDeclField GhcPs) -> ConDeclField GhcPs
forall l e. GenLocated l e -> e
unLoc) FreeKiTyVars
acc
[Located (ConDeclField GhcPs)]
[LConDeclField 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
w 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 -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow HsArrow GhcPs
w 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
_ LHsType GhcPs
ty1 LIdP GhcPs
tv LHsType GhcPs
ty2 -> Located RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv Located RdrName
LIdP GhcPs
tv (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
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
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 LHsDocString
_ -> 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
_ -> FreeKiTyVars
acc
HsStarTy XStarTy GhcPs
_ Bool
_ -> FreeKiTyVars
acc
HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
ki -> 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
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_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
(L SrcSpan
_ (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 IsUnicodeSyntax
_ 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 GhcPs]
[LHsTyVarBndr flag (NoGhcTc 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
| [Located (HsTyVarBndr flag GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (HsTyVarBndr flag GhcPs)]
[LHsTyVarBndr 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 = (Located (HsTyVarBndr flag GhcPs) -> Located RdrName)
-> [Located (HsTyVarBndr flag GhcPs)] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map Located (HsTyVarBndr flag GhcPs) -> Located RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [Located (HsTyVarBndr flag GhcPs)]
[LHsTyVarBndr flag GhcPs]
tv_bndrs
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
[LHsTyVarBndr flag GhcPs]
tv_bndrs =
(GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars
-> [GenLocated SrcSpan (HsType GhcPs)]
-> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenLocated SrcSpan (HsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars
LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty []
[GenLocated SrcSpan (HsType GhcPs)
LHsType GhcPs
k | L SrcSpan
_ (KindedTyVar XKindedTyVar GhcPs
_ flag
_ LIdP GhcPs
_ LHsType GhcPs
k) <- [GenLocated SrcSpan (HsTyVarBndr flag GhcPs)]
[LHsTyVarBndr flag GhcPs]
tv_bndrs]
extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars
Located RdrName
tv FreeKiTyVars
acc =
if RdrName -> Bool
isRdrTyVar (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
tv) then Located RdrName
tvLocated RdrName -> FreeKiTyVars -> FreeKiTyVars
forall a. a -> [a] -> [a]
:FreeKiTyVars
acc else FreeKiTyVars
acc
nubL :: Eq a => [Located a] -> [Located a]
nubL :: [Located a] -> [Located a]
nubL = (Located a -> Located a -> Bool) -> [Located a] -> [Located a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Located a -> Located 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 = (Located RdrName -> Bool) -> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut Located RdrName -> Bool
is_in_scope
where
is_in_scope :: Located RdrName -> Bool
is_in_scope Located RdrName
locc = (Located RdrName -> Bool) -> FreeKiTyVars -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Located RdrName -> Located RdrName -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated Located RdrName
locc) FreeKiTyVars
bndrs