module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType,
HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVarsDups,
extractRdrKindSigVars, extractDataDefnKindVars,
extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
nubL, elemRdr
) where
import GhcPrelude
import RnSplice( rnSpliceType )
import DynFlags
import GHC.Hs
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
, pprHsDocContext, bindLocalNamesFV, typeAppErr
, newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
import RnFixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import TcRnMonad
import RdrName
import PrelNames
import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
import FieldLabel
import Util
import ListSetOps ( deleteBys )
import BasicTypes ( compareFixity, funTyFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..)
, TypeOrKind(..) )
import Outputable
import FastString
import Maybes
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( nubBy, partition, (\\) )
import Control.Monad ( unless, when )
#include "HsVersions.h"
data HsSigWcTypeScoping = AlwaysBind
| BindUnlessForall
| NeverBind
rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType scoping doc sig_ty
= rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
return (sig_ty', emptyFVs)
rnHsSigWcTypeScoped :: HsSigWcTypeScoping
-> HsDocContext -> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
}
rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type scoping ctxt
(HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
thing_inside
= do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
bind_free_tvs = case scoping of
AlwaysBind -> True
BindUnlessForall -> not (isLHsForAllTy hs_ty)
NeverBind -> False
; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
ib_ty' = HsIB { hsib_ext = vars
, hsib_body = hs_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _
= noExtCon nec
rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _
= noExtCon nec
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (nwc_rdrs, _) <- partition_nwcs free_vars
; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody ctxt nwc_rdrs hs_ty
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs
; let env = RTKE { rtke_level = TypeLevel
, rtke_what = RnTypeBody
, rtke_nwcs = mkNameSet nwcs
, rtke_ctxt = ctxt }
; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
rn_lty env hs_ty
; return (nwcs, hs_ty', fvs) }
where
rn_lty env (dL->L loc hs_ty)
= setSrcSpan loc $
do { (hs_ty', fvs) <- rn_ty env hs_ty
; return (cL loc hs_ty', fvs) }
rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs
, hst_body = hs_body })
= bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
do { (hs_body', fvs) <- rn_lty env hs_body
; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
, hst_bndrs = tvs', hst_body = hs_body' }
, fvs) }
rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt
, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
, (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1
; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
| otherwise
= do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, hst_ctxt = cL cx hs_ctxt'
, hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
rn_ty env hs_ty = rnHsTyKi env hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
checkExtraConstraintWildCard env hs_ctxt
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
= Just base_msg
| DerivDeclCtx {} <- rtke_ctxt env
, not (null hs_ctxt)
= Just deriv_decl_msg
| otherwise
= Nothing
base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
<+> text "not allowed"
deriv_decl_msg
= hang base_msg
2 (vcat [ text "except as the sole constraint"
, nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
DerivDeclCtx {} -> True
StandaloneKindSigCtx {} -> False
_ -> False
extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)
extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)
partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)
partition_nwcs free_vars
= do { wildcards_enabled <- xoptM LangExt.NamedWildCards
; return $
if wildcards_enabled
then partition is_wildcard free_vars
else ([], free_vars) }
where
is_wildcard :: Located RdrName -> Bool
is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
= do { traceRn "rnHsSigType" (ppr hs_ty)
; vars <- extractFilteredRdrTyVarsDups hs_ty
; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty
; return ( HsIB { hsib_ext = vars
, hsib_body = body' }
, fvs ) } }
rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec
rnImplicitBndrs :: Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs bind_free_tvs
fvs_with_dups
thing_inside
= do { let fvs = nubL fvs_with_dups
real_fvs | bind_free_tvs = fvs
| otherwise = []
; traceRn "rnImplicitBndrs" $
vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]
; loc <- getSrcSpanM
; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs
; bindLocalNamesFV vars $
thing_inside vars }
data RnTyKiEnv
= RTKE { rtke_ctxt :: HsDocContext
, rtke_level :: TypeOrKind
, rtke_what :: RnTyKiWhat
, rtke_nwcs :: NameSet
}
data RnTyKiWhat = RnTypeBody
| RnTopConstraint
| RnConstraint
instance Outputable RnTyKiEnv where
ppr (RTKE { rtke_level = lev, rtke_what = what
, rtke_nwcs = wcs, rtke_ctxt = ctxt })
= text "RTKE"
<+> braces (sep [ ppr lev, ppr what, ppr wcs
, pprHsDocContext ctxt ])
instance Outputable RnTyKiWhat where
ppr RnTypeBody = text "RnTypeBody"
ppr RnTopConstraint = text "RnTopConstraint"
ppr RnConstraint = text "RnConstraint"
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv cxt level what
= RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
, rtke_what = what, rtke_ctxt = cxt }
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
isRnKindLevel _ = False
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg ctxt (HsValArg ty)
= do { (tys_rn, fvs) <- rnLHsType ctxt ty
; return (HsValArg tys_rn, fvs) }
rnLHsTypeArg ctxt (HsTypeArg l ki)
= do { (kis_rn, fvs) <- rnLHsKind ctxt ki
; return (HsTypeArg l kis_rn, fvs) }
rnLHsTypeArg _ (HsArgPar sp)
= return (HsArgPar sp, emptyFVs)
rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
-> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext env (dL->L loc cxt)
= do { traceRn "rncontext" (ppr cxt)
; let env' = env { rtke_what = RnConstraint }
; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
; return (cL loc cxt', fvs) }
rnContext :: HsDocContext -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi env (dL->L loc ty)
= setSrcSpan loc $
do { (ty', fvs) <- rnHsTyKi env ty
; return (cL loc ty', fvs) }
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars
, hst_body = tau })
= do { checkPolyKinds env ty
; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
Nothing tyvars $ \ tyvars' ->
do { (tau', fvs) <- rnLHsTyKi env tau
; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
, hst_bndrs = tyvars' , hst_body = tau' }
, fvs) } }
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
= do { checkPolyKinds env ty
; (ctxt', fvs1) <- rnTyKiContext env lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'
, hst_body = tau' }
, fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))
= do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
unlessXOptM LangExt.PolyKinds $ addErr $
withHsDocContext (rtke_ctxt env) $
vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
, text "Perhaps you intended to use PolyKinds" ]
; name <- rnTyVar env rdr_name
; return (HsTyVar noExtField ip (cL loc name), unitFV name) }
rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
= setSrcSpan (getLoc l_op) $
do { (l_op', fvs1) <- rnHsTyOp env ty l_op
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2)
(unLoc l_op') fix ty1' ty2'
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsParTy noExtField ty', fvs) }
rnHsTyKi env (HsBangTy _ b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsBangTy noExtField b ty', fvs) }
rnHsTyKi env ty@(HsRecTy _ flds)
= do { let ctxt = rtke_ctxt env
; fls <- get_fields ctxt
; (flds', fvs) <- rnConDeclFields ctxt fls flds
; return (HsRecTy noExtField flds', fvs) }
where
get_fields (ConDeclCtx names)
= concatMapM (lookupConstructorFields . unLoc) names
get_fields _
= do { addErr (hang (text "Record syntax is illegal here:")
2 (ppr ty))
; return [] }
rnHsTyKi env (HsFunTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2'
; return (res_ty, fvs1 `plusFV` fvs2) }
rnHsTyKi env listTy@(HsListTy _ ty)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env listTy))
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsListTy noExtField ty', fvs) }
rnHsTyKi env t@(HsKindSig _ ty k)
= do { checkPolyKinds env t
; kind_sigs_ok <- xoptM LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
; (ty', lhs_fvs) <- rnLHsTyKi env ty
; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }
rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env tupleTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsTupleTy noExtField tup_con tys', fvs) }
rnHsTyKi env sumTy@(HsSumTy _ tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env sumTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsSumTy noExtField tys', fvs) }
rnHsTyKi env tyLit@(HsTyLit _ t)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env tyLit))
; when (negLit t) (addErr negLitErr)
; checkPolyKinds env tyLit
; return (HsTyLit noExtField t, emptyFVs) }
where
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsAppKindTy l ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr "kind" k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsIParamTy noExtField n ty', fvs) }
rnHsTyKi _ (HsStarTy _ isUni)
= return (HsStarTy noExtField isUni, emptyFVs)
rnHsTyKi _ (HsSpliceTy _ sp)
= rnSpliceType sp
rnHsTyKi env (HsDocTy _ ty haddock_doc)
= do { (ty', fvs) <- rnLHsTyKi env ty
; haddock_doc' <- rnLHsDoc haddock_doc
; return (HsDocTy noExtField ty' haddock_doc', fvs) }
rnHsTyKi _ (XHsType (NHsCoreTy ty))
= return (XHsType (NHsCoreTy ty), emptyFVs)
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { checkPolyKinds env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitListTy noExtField ip tys', fvs) }
rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
= do { checkPolyKinds env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitTupleTy noExtField tys', fvs) }
rnHsTyKi env (HsWildCardTy _)
= do { checkAnonWildCard env
; return (HsWildCardTy noExtField, emptyFVs) }
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar env rdr_name
= do { name <- lookupTypeOccRn rdr_name
; checkNamedWildCard env name
; return name }
rnLTyVar :: Located RdrName -> RnM (Located Name)
rnLTyVar (dL->L loc rdr_name)
= do { tyvar <- lookupTypeOccRn rdr_name
; return (cL loc tyvar) }
rnHsTyOp :: Outputable a
=> RnTyKiEnv -> a -> Located RdrName
-> RnM (Located Name, FreeVars)
rnHsTyOp env overall_ty (dL->L loc op)
= do { ops_ok <- xoptM LangExt.TypeOperators
; op' <- rnTyVar env op
; unless (ops_ok || op' `hasKey` eqTyConKey) $
addErr (opTyErr op overall_ty)
; let l_op' = cL loc op'
; return (l_op', unitFV op') }
notAllowed :: SDoc -> SDoc
notAllowed doc
= text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard env (Just doc)
= addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
checkWildCard _ Nothing
= return ()
checkAnonWildCard :: RnTyKiEnv -> RnM ()
checkAnonWildCard env
= checkWildCard env mb_bad
where
mb_bad :: Maybe SDoc
mb_bad | not (wildCardsAllowed env)
= Just (notAllowed pprAnonWildCard)
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnTopConstraint -> Just constraint_msg
RnConstraint -> Just constraint_msg
constraint_msg = hang
(notAllowed pprAnonWildCard <+> text "in a constraint")
2 hint_msg
hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
, nest 2 (text "e.g f :: (Eq a, _) => blah") ]
checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
checkNamedWildCard env name
= checkWildCard env mb_bad
where
mb_bad | not (name `elemNameSet` rtke_nwcs env)
= Nothing
| not (wildCardsAllowed env)
= Just (notAllowed (ppr name))
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnTopConstraint -> Nothing
RnConstraint -> Just constraint_msg
constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
TypBrCtx {} -> True
SpliceTypeCtx {} -> True
ExprWithTySigCtx {} -> True
PatCtx {} -> True
RuleCtx {} -> True
FamPatCtx {} -> True
GHCiCtx {} -> True
HsTypeCtx {} -> True
StandaloneKindSigCtx {} -> False
_ -> False
checkPolyKinds :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
checkPolyKinds env ty
| isRnKindLevel env
= do { polykinds <- xoptM LangExt.PolyKinds
; unless polykinds $
addErr (text "Illegal kind:" <+> ppr ty $$
text "Did you mean to enable PolyKinds?") }
checkPolyKinds _ _ = return ()
notInKinds :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
notInKinds env ty
| isRnKindLevel env
= addErr (text "Illegal kind:" <+> ppr ty)
notInKinds _ _ = return ()
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV tvs thing_inside
= do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
; if not scoped_tyvars then
thing_inside
else
bindLocalNamesFV tvs thing_inside }
bindLRdrNames :: [Located RdrName]
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindLRdrNames rdrs thing_inside
= do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
; bindLocalNamesFV var_names $
thing_inside var_names }
bindHsQTyVars :: forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [Located RdrName]
-> (LHsQTyVars GhcPs)
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
= do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
; let
bndrs, kv_occs, implicit_kvs :: [Located RdrName]
bndrs = map hsLTyVarLocName hs_tv_bndrs
kv_occs = nubL (bndr_kv_occs ++ body_kv_occs)
implicit_kvs = filter_occs bndrs kv_occs
del = deleteBys eqLocated
all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
; traceRn "checkMixedVars3" $
vcat [ text "kv_occs" <+> ppr kv_occs
, text "bndrs" <+> ppr hs_tv_bndrs
, text "bndr_kv_occs" <+> ppr bndr_kv_occs
, text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
]
; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
; bindLocalNamesFV implicit_kv_nms $
bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
, hsq_explicit = rn_bndrs })
all_bound_on_lhs } }
where
filter_occs :: [Located RdrName]
-> [Located RdrName]
-> [Located RdrName]
filter_occs bndrs occs
= filterOut is_in_scope occs
where
is_in_scope locc = locc `elemRdr` bndrs
bindLHsTyVarBndrs :: HsDocContext
-> Maybe SDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
; checkDupRdrNames tv_names_w_loc
; go tv_bndrs thing_inside }
where
tv_names_w_loc = map hsLTyVarLocName tv_bndrs
go [] thing_inside = thing_inside []
go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
do { (res, fvs) <- go bs $ \ bs' ->
thing_inside (b' : bs')
; warn_unused b' fvs
; return (res, fvs) }
warn_unused tv_bndr fvs = case mb_in_doc of
Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
Nothing -> return ()
bindLHsTyVarBndr :: HsDocContext
-> Maybe a
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr _doc mb_assoc (dL->L loc
(UserTyVar x
lrdr@(dL->L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside (cL loc (UserTyVar x (cL lv nm))) }
bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))
thing_inside
= do { sig_ok <- xoptM LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
; (kind', fvs1) <- rnLHsKind doc kind
; tv_nm <- newTyVarNameRn mb_assoc lrdr
; (b, fvs2) <- bindLocalNamesFV [tv_nm]
$ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec
bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (dL->L loc rdr)
= do { rdr_env <- getLocalRdrEnv
; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
(Just _, Just n) -> return n
_ -> newLocalBndrRn (cL loc rdr) }
rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields ctxt fls fields
= mapFvRn (rnField fl_env env) fields
where
env = mkTyKiEnv ctxt TypeLevel RnTypeBody
fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))
= do { let new_names = map (fmap lookupField) names
; (new_ty, fvs) <- rnLHsTyKi env ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc)
, fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc _ (dL->L lr rdr)) =
FieldOcc (flSelector fl) (cL lr rdr)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
lookupField (XFieldOcc nec) = noExtCon nec
rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec
rnField _ _ _ = panic "rnField: Impossible Match"
mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1
(\t1 t2 -> HsOpTy noExtField t1 op2 t2)
(unLoc op2) fix2 ty21 ty22 loc2 }
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1
(HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2
mkHsOpTyRn mk1 _ _ ty1 ty2
= return (mk1 ty1 ty2)
mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn
-> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty mk1 op1 fix1 ty1
mk2 op2 fix2 ty21 ty22 loc2
| nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }
| associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))
| otherwise = do {
new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
; return (mk2 (noLoc new_ty) ty22) }
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn :: LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (OpApp fix2 e1 op2 e2)
| associate_right = do
new_e <- mkOpAppRn e12 op2 fix2 e2
return (OpApp fix1 e11 op1 (cL loc' new_e))
where
loc'= combineLocs e12 e2
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
| nofix_error
= do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
return (OpApp fix2 e1 op2 e2)
| associate_right
= do new_e <- mkOpAppRn neg_arg op2 fix2 e2
return (NegApp noExtField (cL loc' new_e) neg_name)
where
loc' = combineLocs neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {}))
| not associate_right
= do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
return (OpApp fix1 e1 op1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
mkOpAppRn e1 op fix e2
= ASSERT2( right_op_ok fix (unLoc e2),
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
return (OpApp fix e1 op e2)
data OpName = NormalOp Name
| NegateOp
| UnboundOp UnboundVar
| RecFldOp (AmbiguousFieldOcc GhcRn)
instance Outputable OpName where
ppr (NormalOp n) = ppr n
ppr NegateOp = ppr negateName
ppr (UnboundOp uv) = ppr uv
ppr (RecFldOp fld) = ppr fld
get_op :: LHsExpr GhcRn -> OpName
get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n)
get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv
get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld
get_op other = pprPanic "get_op" (ppr other)
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
right_op_ok fix1 (OpApp fix2 _ _ _)
= not error_please && associate_right
where
(error_please, associate_right) = compareFixity fix1 fix2
right_op_ok _ _
= True
mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
-> RnM (HsExpr (GhcPass id))
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
return (NegApp noExtField neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp {}) = False
not_op_app _ = True
mkOpFormRn :: LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsCmdTop GhcRn
-> RnM (HsCmd GhcRn)
mkOpFormRn a1@(dL->L loc
(HsCmdTop _
(dL->L _ (HsCmdArrForm x op1 f (Just fix1)
[a11,a12]))))
op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
return (HsCmdArrForm noExtField op1 f (Just fix1)
[a11, cL loc (HsCmdTop [] (cL loc new_c))])
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpFormRn arg1 op fix arg2
= return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])
mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2
= do { fix1 <- lookupFixityRn (unLoc op1)
; let (nofix_error, associate_right) = compareFixity fix1 fix2
; if nofix_error then do
{ precParseErr (NormalOp (unLoc op1),fix1)
(NormalOp (unLoc op2),fix2)
; return (ConPatIn op2 (InfixCon p1 p2)) }
else if associate_right then do
{ new_p <- mkConOpPatRn op2 fix2 p12 p2
; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }
else return (ConPatIn op2 (InfixCon p1 p2)) }
mkConOpPatRn op _ p1 p2
= ASSERT( not_op_pat (unLoc p2) )
return (ConPatIn op (InfixCon p1 p2))
not_op_pat :: Pat GhcRn -> Bool
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
not_op_pat _ = True
checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })
= mapM_ check ms
where
check (dL->L _ (Match { m_pats = (dL->L l1 p1)
: (dL->L l2 p2)
: _ }))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
check _ = return ()
checkPrecMatch _ (XMatchGroup nec) = noExtCon nec
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
(op1_dir == InfixR && op_dir == InfixR && right ||
op1_dir == InfixL && op_dir == InfixL && not right))
info = (NormalOp op, op_fix)
info1 = (NormalOp (unLoc op1), op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
unless inf_ok (precParseErr infol infor)
checkPrec _ _ _
= return ()
checkSectionPrec :: FixityDirection -> HsExpr GhcPs
-> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
checkSectionPrec direction section op arg
= case unLoc arg of
OpApp fix _ op' _ -> go_for_it (get_op op') fix
NegApp _ _ _ -> go_for_it NegateOp negateFixity
_ -> return ()
where
op_name = get_op op
go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
unless (op_prec < arg_prec
|| (op_prec == arg_prec && direction == assoc))
(sectionPrecErr (get_op op, op_fix)
(arg_op, arg_fix) section)
lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp (NormalOp n) = lookupFixityRn n
lookupFixityOp NegateOp = lookupFixityRn negateName
lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
precParseErr op1@(n1,_) op2@(n2,_)
| is_unbound n1 || is_unbound n2
= return ()
| otherwise
= addErr $ hang (text "Precedence parsing error")
4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
ppr_opfix op2,
text "in the same infix expression"])
sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
sectionPrecErr op@(n1,_) arg_op@(n2,_) section
| is_unbound n1 || is_unbound n2
= return ()
| otherwise
= addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
nest 4 (sep [text "must have lower precedence than that of the operand,",
nest 2 (text "namely" <+> ppr_opfix arg_op)]),
nest 4 (text "in the section:" <+> quotes (ppr section))]
is_unbound :: OpName -> Bool
is_unbound (NormalOp n) = isUnboundName n
is_unbound UnboundOp{} = True
is_unbound _ = False
ppr_opfix :: (OpName, Fixity) -> SDoc
ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
where
pp_op | NegateOp <- op = text "prefix `-'"
| otherwise = quotes (ppr op)
unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
unexpectedTypeSigErr ty
= hang (text "Illegal type signature:" <+> quotes (ppr ty))
2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr doc (dL->L loc ty)
= setSrcSpan loc $ addErr $
withHsDocContext doc $
hang (text "Illegal kind signature:" <+> quotes (ppr ty))
2 (text "Perhaps you intended to use KindSignatures")
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
dataKindsErr env thing
= hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
2 (text "Perhaps you intended to use DataKinds")
where
pp_what | isRnKindLevel env = text "kind"
| otherwise = text "type"
inTypeDoc :: HsType GhcPs -> SDoc
inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
warnUnusedForAll in_doc (dL->L loc tv) used_names
= whenWOptM Opt_WarnUnusedForalls $
unless (hsTyVarName tv `elemNameSet` used_names) $
addWarnAt (Reason Opt_WarnUnusedForalls) loc $
vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
, in_doc ]
opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr op overall_ty
= hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
2 (text "Use TypeOperators to allow operators in types")
type FreeKiTyVars = [Located RdrName]
type FreeKiTyVarsWithDups = FreeKiTyVars
type FreeKiTyVarsNoDups = FreeKiTyVars
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM vars
= do { rdr_env <- getLocalRdrEnv
; return (filterInScope rdr_env vars) }
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyarg (HsValArg ty) acc = extract_lty ty acc
extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
extract_tyarg (HsArgPar _) acc = acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs args acc = foldr extract_tyarg acc args
extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
extractHsTyArgRdrKiTyVarsDup args
= extract_tyargs args []
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
extractHsTyRdrTyVars ty
= nubL (extractHsTyRdrTyVarsDups ty)
extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups ty
= extract_lty ty []
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
extractHsTyRdrTyVarsKindVars (unLoc -> ty) =
case ty of
HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
HsKindSig _ _ ki -> extractHsTyRdrTyVars ki
_ -> []
extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups tys
= extract_ltys tys []
extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups
extractHsTyVarBndrsKVs tv_bndrs
= nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
extractRdrKindSigVars (dL->L _ resultSig)
| KindSig _ k <- resultSig = extractHsTyRdrTyVars k
| TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k
| otherwise = []
extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups
extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
= maybe [] extractHsTyRdrTyVars ksig
extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec
extract_lctxt :: LHsContext GhcPs
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
extract_ltys :: [LHsType GhcPs]
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys tys acc = foldr extract_lty acc tys
extract_lty :: LHsType GhcPs
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty (dL->L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv ltv acc
HsBangTy _ _ ty -> extract_lty ty acc
HsRecTy _ flds -> foldr (extract_lty
. cd_fld_type . unLoc) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
HsAppKindTy _ ty k -> extract_lty ty $
extract_lty k acc
HsListTy _ ty -> extract_lty ty acc
HsTupleTy _ _ tys -> extract_ltys tys acc
HsSumTy _ tys -> extract_ltys tys acc
HsFunTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
HsIParamTy _ _ ty -> extract_lty ty acc
HsOpTy _ ty1 tv ty2 -> extract_tv tv $
extract_lty ty1 $
extract_lty ty2 acc
HsParTy _ ty -> extract_lty ty acc
HsSpliceTy {} -> acc
HsDocTy _ ty _ -> extract_lty ty acc
HsExplicitListTy _ _ tys -> extract_ltys tys acc
HsExplicitTupleTy _ tys -> extract_ltys tys acc
HsTyLit _ _ -> acc
HsStarTy _ _ -> acc
HsKindSig _ ty ki -> extract_lty ty $
extract_lty ki acc
HsForAllTy { hst_bndrs = tvs, hst_body = ty }
-> extract_hs_tv_bndrs tvs acc $
extract_lty ty []
HsQualTy { hst_ctxt = ctxt, hst_body = ty }
-> extract_lctxt ctxt $
extract_lty ty acc
XHsType {} -> acc
HsWildCardTy {} -> acc
extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extractHsTvBndrs tv_bndrs body_fvs
= extract_hs_tv_bndrs tv_bndrs [] body_fvs
extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extract_hs_tv_bndrs tv_bndrs acc_vars body_vars
| null tv_bndrs = body_vars ++ acc_vars
| otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars
where
bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
extract_hs_tv_bndrs_kvs tv_bndrs =
foldr extract_lty []
[k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]
extract_tv :: Located RdrName
-> [Located RdrName] -> [Located RdrName]
extract_tv tv acc =
if isRdrTyVar (unLoc tv) then tv:acc else acc
nubL :: Eq a => [Located a] -> [Located a]
nubL = nubBy eqLocated
elemRdr :: Located RdrName -> [Located RdrName] -> Bool
elemRdr x = any (eqLocated x)