module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind,
rnHsSigType, rnHsWcType,
rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
newTyVarNameRn, collectAnonWildCards,
rnConDeclFields,
rnLTyVar,
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
extractRdrKindSigVars, extractDataDefnKindVars,
extractHsTvBndrs,
freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
elemRdr
) where
import GhcPrelude
import RnSplice( rnSpliceType )
import DynFlags
import HsSyn
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import RnUnbound ( perhapsForallMsg )
import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
, pprHsDocContext, bindLocalNamesFV
, 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(..) )
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"
rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType doc sig_ty
= rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
return (sig_ty', emptyFVs)
rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsSigWcTypeScoped ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
; rn_hs_sig_wc_type True ctx sig_ty thing_inside
}
rn_hs_sig_wc_type :: Bool
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type always_bind_free_tvs ctxt
(HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
thing_inside
= do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
; 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' = mk_implicit_bndrs vars hs_ty' fvs1
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
= panic "rn_hs_sig_wc_type"
rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
= panic "rn_hs_sig_wc_type"
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 _) = panic "rnHsWcType"
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
; let awcs = collectAnonWildCards hs_ty'
; return (nwcs ++ awcs, hs_ty', fvs) }
where
rn_lty env (L loc hs_ty)
= setSrcSpan loc $
do { (hs_ty', fvs) <- rn_ty env hs_ty
; return (L loc hs_ty', fvs) }
rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty env hs_ty@(HsForAllTy { 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_xforall = noExt, hst_bndrs = tvs'
, hst_body = hs_body' }, fvs) }
rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
, L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
do { checkExtraConstraintWildCard env hs_ctxt1
; rnAnonWildCard }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExt
, hst_ctxt = L 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 = noExt
, hst_ctxt = L 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
_ -> False
extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractFilteredRdrTyVars hs_ty
= do { rdr_env <- getLocalRdrEnv
; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups hs_ty
= do { rdr_env <- getLocalRdrEnv
; filterInScope rdr_env <$> extractHsTyRdrTyVarsDups hs_ty }
partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])
partition_nwcs free_vars@(FKTV { fktv_tys = tys })
= do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags
; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys
| otherwise = ([], tys)
free_vars' = free_vars { fktv_tys = no_nwcs }
; return (free_vars', nwcs) }
where
is_wildcard :: Located RdrName -> Bool
is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
rnHsSigType :: HsDocContext -> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType ctx (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) <- rnLHsType ctx hs_ty
; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
rnImplicitBndrs :: Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs bind_free_tvs
fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
, fktv_tys = tvs_with_dups })
thing_inside
= do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
real_tvs | bind_free_tvs = tvs
| otherwise = []
; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
; whenWOptM Opt_WarnImplicitKindVars $
unless (bind_free_tvs || null kvs) $
addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $
implicit_kind_vars_msg kvs
; loc <- getSrcSpanM
; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
; traceRn "checkMixedVars2" $
vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
, text "tvs_with_dups" <+> ppr tvs_with_dups ]
; bindLocalNamesFV vars $
thing_inside vars }
where
implicit_kind_vars_msg kvs =
vcat [ text "An explicit" <+> quotes (text "forall") <+>
text "was used, but the following kind variables" <+>
text "are not quantified:" <+>
hsep (punctuate comma (map (quotes . ppr) kvs))
, text "Despite this fact, GHC will introduce them into scope," <+>
text "but it will stop doing so in the future."
, text "Suggested fix: add" <+>
quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
mk_implicit_bndrs :: [Name]
-> a
-> FreeVars
-> HsImplicitBndrs GhcRn a
mk_implicit_bndrs vars body fvs
= HsIB { hsib_ext = HsIBRn
{ hsib_vars = vars
, hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
, hsib_body = body }
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
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext env (L loc cxt)
= do { traceRn "rncontext" (ppr cxt)
; let env' = env { rtke_what = RnConstraint }
; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
; return (L 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 (L loc ty)
= setSrcSpan loc $
do { (ty', fvs) <- rnHsTyKi env ty
; return (L loc ty', fvs) }
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi env ty@(HsForAllTy { 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_xforall = noExt, 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 = noExt, hst_ctxt = ctxt'
, hst_body = tau' }
, fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsTyVar _ ip (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 noExt ip (L 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 noExt 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 noExt ty', fvs) }
rnHsTyKi env (HsBangTy _ b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsBangTy noExt 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 noExt 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 noExt) 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 noExt 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', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
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 noExt 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 noExt 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 noExt 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 noExt ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsIParamTy noExt n ty', fvs) }
rnHsTyKi _ (HsStarTy _ isUni)
= return (HsStarTy noExt 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 noExt 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 noExt 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 noExt tys', fvs) }
rnHsTyKi env (HsWildCardTy _)
= do { checkAnonWildCard env
; wc' <- rnAnonWildCard
; return (HsWildCardTy wc', 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 (L loc rdr_name)
= do { tyvar <- lookupTypeOccRn rdr_name
; return (L loc tyvar) }
rnHsTyOp :: Outputable a
=> RnTyKiEnv -> a -> Located RdrName
-> RnM (Located Name, FreeVars)
rnHsTyOp env overall_ty (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' = L 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
RnConstraint -> Just constraint_msg
RnTopConstraint -> 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
_ -> False
rnAnonWildCard :: RnM HsWildCardInfo
rnAnonWildCard
= do { loc <- getSrcSpanM
; uniq <- newUnique
; let name = mkInternalName uniq (mkTyVarOcc "_") loc
; return (AnonWildCard (L loc name)) }
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
; rdr_env <- getLocalRdrEnv
; let
bndrs, kv_occs, implicit_kvs :: [Located RdrName]
bndrs = map hsLTyVarLocName hs_tv_bndrs
kv_occs = nubL (body_kv_occs ++ bndr_kv_occs)
implicit_kvs = filter_occs rdr_env bndrs kv_occs
dep_bndrs = filter (`elemRdr` kv_occs) bndrs
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)
; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = implicit_kv_nms
, hsq_dependent = mkNameSet dep_bndr_nms }
, hsq_explicit = rn_bndrs })
all_bound_on_lhs } }
where
filter_occs :: LocalRdrEnv
-> [Located RdrName]
-> [Located RdrName]
-> [Located RdrName]
filter_occs rdr_env bndrs occs
= filterOut is_in_scope occs
where
is_in_scope locc@(L _ occ) = isJust (lookupLocalRdrEnv rdr_env occ)
|| 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 (L loc (UserTyVar x lrdr@(L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside (L loc (UserTyVar x (L lv nm))) }
bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(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 (L loc (KindedTyVar x (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
= do { rdr_env <- getLocalRdrEnv
; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
(Just _, Just n) -> return n
_ -> newLocalBndrRn (L loc rdr) }
collectAnonWildCards :: LHsType GhcRn -> [Name]
collectAnonWildCards lty = go lty
where
go (L _ ty) = case ty of
HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2
HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2
HsListTy _ ty -> go ty
HsTupleTy _ _ tys -> gos tys
HsSumTy _ tys -> gos tys
HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2
HsParTy _ ty -> go ty
HsIParamTy _ _ ty -> go ty
HsKindSig _ ty kind -> go ty `mappend` go kind
HsDocTy _ ty _ -> go ty
HsBangTy _ _ ty -> go ty
HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
HsExplicitTupleTy _ tys -> gos tys
HsForAllTy { hst_bndrs = bndrs
, hst_body = ty } -> collectAnonWildCardsBndrs bndrs
`mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty
HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
HsSpliceTy{} -> mempty
HsTyLit{} -> mempty
HsTyVar{} -> mempty
HsStarTy{} -> mempty
XHsType{} -> mempty
gos = mconcat . map go
collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
where
go (UserTyVar _ _) = []
go (KindedTyVar _ _ ki) = collectAnonWildCards ki
go (XTyVarBndr{}) = []
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 (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 (L l (ConDeclField noExt new_names new_ty new_haddock_doc)
, fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
lookupField (XFieldOcc{}) = panic "rnField"
rnField _ _ (L _ (XConDeclField _)) = panic "rnField"
mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1
(\t1 t2 -> HsOpTy noExt t1 op2 t2)
(unLoc op2) fix2 ty21 ty22 loc2 }
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1
(HsFunTy noExt) 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 (L loc2 (mk2 ty21 ty22))) }
| associate_right = return (mk1 ty1 (L 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@(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 (L loc' new_e))
where
loc'= combineLocs e12 e2
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn e1@(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 noExt (L loc' new_e) neg_name)
where
loc' = combineLocs neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
mkOpAppRn e1 op1 fix1 e2@(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 (L _ (HsVar _ (L _ n))) = NormalOp n
get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
get_op (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 noExt 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@(L loc (HsCmdTop _ (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 noExt op1 f (Just fix1)
[a11, L loc (HsCmdTop [] (L loc new_c))])
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpFormRn arg1 op fix arg2
= return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
mkConOpPatRn op2 fix2 p1@(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 (L 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 = L _ ms })
= mapM_ check ms
where
check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
check _ = return ()
checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
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 (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 (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 extra
where
extra | op == dot_tv_RDR
= perhapsForallMsg
| otherwise
= text "Use TypeOperators to allow operators in types"
data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName]
, fktv_tys :: [Located RdrName] }
type FreeKiTyVarsWithDups = FreeKiTyVars
type FreeKiTyVarsNoDups = FreeKiTyVars
instance Outputable FreeKiTyVars where
ppr (FKTV kis tys) = ppr (kis, tys)
emptyFKTV :: FreeKiTyVarsNoDups
emptyFKTV = FKTV [] []
freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsAllVars (FKTV tys kvs) = tys ++ kvs
freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsKindVars = fktv_kis
freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsTypeVars = fktv_tys
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope rdr_env (FKTV kis tys)
= FKTV (filterOut in_scope kis)
(filterOut in_scope tys)
where
in_scope = inScope rdr_env . unLoc
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractHsTyRdrTyVars ty
= rmDupsInRdrTyVars <$> extractHsTyRdrTyVarsDups ty
extractHsTyRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups ty
= extract_lty TypeLevel ty emptyFKTV
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> RnM [Located RdrName]
extractHsTyRdrTyVarsKindVars ty
= freeKiTyVarsKindVars <$> extractHsTyRdrTyVars ty
extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVarsNoDups
extractHsTysRdrTyVars tys
= rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups tys
= extract_ltys TypeLevel tys emptyFKTV
extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
extractHsTyVarBndrsKVs tv_bndrs
= do { kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
; return (nubL kvs) }
rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
rmDupsInRdrTyVars (FKTV kis tys)
= FKTV kis' tys'
where
kis' = nubL kis
tys' = nubL (filterOut (`elemRdr` kis') tys)
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName]
extractRdrKindSigVars (L _ resultSig)
| KindSig _ k <- resultSig = kindRdrNameFromSig k
| TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
| otherwise = return []
where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName]
extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
, dd_cons = cons })
= (nubL . freeKiTyVarsKindVars) <$>
(extract_lctxt TypeLevel ctxt =<<
extract_mb extract_lkind ksig =<<
foldrM (extract_con . unLoc) emptyFKTV cons)
where
extract_con (ConDeclGADT { }) acc = return acc
extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
, con_mb_cxt = ctxt, con_args = args }) acc
= extract_hs_tv_bndrs ex_tvs acc =<<
extract_mlctxt ctxt =<<
extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
extract_mlctxt :: Maybe (LHsContext GhcPs)
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_mlctxt Nothing acc = return acc
extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
extract_lctxt :: TypeOrKind
-> LHsContext GhcPs
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
extract_ltys :: TypeOrKind
-> [LHsType GhcPs]
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
extract_mb :: (a -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups)
-> Maybe a
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_mb _ Nothing acc = return acc
extract_mb f (Just x) acc = f x acc
extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
extract_lkind = extract_lty KindLevel
extract_lty :: TypeOrKind -> LHsType GhcPs
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_lty t_or_k (L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc
HsBangTy _ _ ty -> extract_lty t_or_k ty acc
HsRecTy _ flds -> foldrM (extract_lty t_or_k
. cd_fld_type . unLoc) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
extract_lty t_or_k ty2 acc
HsListTy _ ty -> extract_lty t_or_k ty acc
HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc
HsSumTy _ tys -> extract_ltys t_or_k tys acc
HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
extract_lty t_or_k ty2 acc
HsIParamTy _ _ ty -> extract_lty t_or_k ty acc
HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<<
extract_lty t_or_k ty1 =<<
extract_lty t_or_k ty2 acc
HsParTy _ ty -> extract_lty t_or_k ty acc
HsSpliceTy {} -> return acc
HsDocTy _ ty _ -> extract_lty t_or_k ty acc
HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
HsTyLit _ _ -> return acc
HsStarTy _ _ -> return acc
HsKindSig _ ty ki -> extract_lty t_or_k ty =<<
extract_lkind ki acc
HsForAllTy { hst_bndrs = tvs, hst_body = ty }
-> extract_hs_tv_bndrs tvs acc =<<
extract_lty t_or_k ty emptyFKTV
HsQualTy { hst_ctxt = ctxt, hst_body = ty }
-> extract_lctxt t_or_k ctxt =<<
extract_lty t_or_k ty acc
XHsType {} -> return acc
HsWildCardTy {} -> return acc
extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> RnM FreeKiTyVarsWithDups
extractHsTvBndrs tv_bndrs body_fvs
= extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> RnM FreeKiTyVarsWithDups
extract_hs_tv_bndrs tv_bndrs
(FKTV acc_kvs acc_tvs)
(FKTV body_kvs body_tvs)
| null tv_bndrs
= return $
FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)
| otherwise
= do { bndr_kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
; let tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
all_kv_occs = bndr_kvs ++ body_kvs
; traceRn "checkMixedVars1" $
vcat [ text "bndr_kvs" <+> ppr bndr_kvs
, text "body_kvs" <+> ppr body_kvs
, text "all_kv_occs" <+> ppr all_kv_occs
, text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ]
; return $
FKTV (filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs
++ acc_kvs)
(filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs) }
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
extract_hs_tv_bndrs_kvs tv_bndrs
= do { fktvs <- foldrM extract_lkind emptyFKTV
[k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
; return (freeKiTyVarsKindVars fktvs) }
extract_tv :: TypeOrKind -> Located RdrName
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs)
| not (isRdrTyVar tv) = return acc
| isTypeLevel t_or_k = return (FKTV kvs (ltv : tvs))
| otherwise = return (FKTV (ltv : kvs) tvs)
nubL :: Eq a => [Located a] -> [Located a]
nubL = nubBy eqLocated
elemRdr :: Located RdrName -> [Located RdrName] -> Bool
elemRdr x = any (eqLocated x)