module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind,
rnHsSigType, rnHsWcType,
rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
newTyVarNameRn, collectAnonWildCards,
rnConDeclFields,
rnLTyVar,
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindLHsTyVarBndr,
bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
extractRdrKindSigVars, extractDataDefnKindVars,
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 TysWiredIn ( starKindTyConName, unicodeStarKindTyConName )
import Name
import SrcLoc
import NameSet
import FieldLabel
import Util
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 True 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 False 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 no_implicit_if_forall 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'
; rnImplicitBndrs no_implicit_if_forall ctxt hs_ty tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_wcs = 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) } }
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_wcs = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
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_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 wc) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
do { checkExtraConstraintWildCard env wc
; rnAnonWildCard wc }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { 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_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 -> HsWildCardInfo GhcPs
-> RnM ()
checkExtraConstraintWildCard env wc
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
= Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
<+> text "not allowed")
| otherwise
= Nothing
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> 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 True ctx hs_ty vars $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
rnImplicitBndrs :: Bool
-> HsDocContext
-> LHsType GhcPs
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty)
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 | no_implicit_if_forall
, HsForAllTy {} <- hs_ty = []
| otherwise = tvs
; traceRn "rnImplicitBndrs" (vcat [ ppr hs_ty, ppr kvs, ppr tvs, ppr real_tvs ])
; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
; checkBadKindBndrs doc kvs
; traceRn "checkMixedVars2" $
vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
, text "tvs_with_dups" <+> ppr tvs_with_dups ]
; checkMixedVars kvs_with_dups tvs_with_dups
; bindLocalNamesFV vars $
thing_inside vars }
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rnLHsInstType doc_str inst_ty
| Just cls <- getLHsInstDeclClass_maybe inst_ty
, isTcOcc (rdrNameOcc (unLoc cls))
= do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls)
; rnHsSigType (GenericCtx full_doc) inst_ty }
| otherwise
= do { addErrAt (getLoc (hsSigType inst_ty)) $
text "Malformed instance:" <+> ppr inst_ty
; rnHsSigType (GenericCtx doc_str) inst_ty }
mk_implicit_bndrs :: [Name]
-> a
-> FreeVars
-> HsImplicitBndrs GhcRn a
mk_implicit_bndrs vars body fvs
= HsIB { hsib_vars = vars
, hsib_body = body
, hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
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 { checkTypeInType env ty
; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
Nothing tyvars $ \ tyvars' ->
do { (tau', fvs) <- rnLHsTyKi env tau
; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' }
, fvs) } }
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
= do { checkTypeInType env ty
; (ctxt', fvs1) <- rnTyKiContext env lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' }
, fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsTyVar ip (L loc rdr_name))
= do { name <- rnTyVar env rdr_name
; return (HsTyVar 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 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 ty', fvs) }
rnHsTyKi env (HsBangTy b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsBangTy 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 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 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 ty', fvs) }
rnHsTyKi env t@(HsKindSig ty k)
= do { checkTypeInType 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 ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsPArrTy ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsPArrTy ty', 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 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 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)
; checkTypeInType env tyLit
; return (HsTyLit 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 overall_ty@(HsAppsTy tys)
= do {
let (non_syms, syms) = splitHsAppsTy tys
; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms
; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
; non_syms3 <- mapM deal_with_non_syms non_syms2
; L _ res_ty <- build_res_ty non_syms3 syms2
; return (res_ty, fvs1 `plusFV` fvs2) }
where
deal_with_star :: [[LHsType GhcRn]] -> [Located Name]
-> [[LHsType GhcRn]] -> [Located Name]
-> ([[LHsType GhcRn]], [Located Name])
deal_with_star acc1 acc2
(non_syms1 : non_syms2 : non_syms) (L loc star : ops)
| star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
= deal_with_star acc1 acc2
((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
: non_syms2) : non_syms)
ops
deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
= deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
deal_with_star acc1 acc2 [non_syms] []
= (reverse (non_syms : acc1), reverse acc2)
deal_with_star _ _ _ _
= pprPanic "deal_with_star" (ppr overall_ty)
deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn)
deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty)
build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn)
build_res_ty (arg1 : args) (op1 : ops)
= do { rhs <- build_res_ty args ops
; fix <- lookupTyFixityRn op1
; res <-
mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
; return (L loc res)
}
build_res_ty [arg] [] = return arg
build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
rnHsTyKi env (HsAppTy ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsIParamTy n ty', fvs) }
rnHsTyKi env t@(HsEqTy ty1 ty2)
= do { checkTypeInType env t
; (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi _ (HsSpliceTy sp k)
= rnSpliceType sp k
rnHsTyKi env (HsDocTy ty haddock_doc)
= do { (ty', fvs) <- rnLHsTyKi env ty
; haddock_doc' <- rnLHsDoc haddock_doc
; return (HsDocTy ty' haddock_doc', fvs) }
rnHsTyKi _ (HsCoreTy ty)
= return (HsCoreTy ty, emptyFVs)
rnHsTyKi env ty@(HsExplicitListTy ip k tys)
= do { checkTypeInType env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitListTy ip k tys', fvs) }
rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
= do { checkTypeInType env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitTupleTy kis tys', fvs) }
rnHsTyKi env (HsWildCardTy wc)
= do { checkAnonWildCard env wc
; wc' <- rnAnonWildCard wc
; return (HsWildCardTy wc', emptyFVs) }
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar env rdr_name
= do { name <- if isRnKindLevel env
then lookupKindOccRn rdr_name
else 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' == starKindTyConName
|| op' == unicodeStarKindTyConName
|| 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 -> HsWildCardInfo GhcPs -> RnM ()
checkAnonWildCard env wc
= checkWildCard env mb_bad
where
mb_bad :: Maybe SDoc
mb_bad | not (wildCardsAllowed env)
= Just (notAllowed (ppr wc))
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnConstraint -> Just constraint_msg
RnTopConstraint -> Just constraint_msg
constraint_msg = hang (notAllowed (ppr wc) <+> 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 :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn)
rnAnonWildCard (AnonWildCard _)
= do { loc <- getSrcSpanM
; uniq <- newUnique
; let name = mkInternalName uniq (mkTyVarOcc "_") loc
; return (AnonWildCard (L loc name)) }
checkTypeInType :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
checkTypeInType env ty
| isRnKindLevel env
= do { type_in_type <- xoptM LangExt.TypeInType
; unless type_in_type $
addErr (text "Illegal kind:" <+> ppr ty $$
text "Did you mean to enable TypeInType?") }
checkTypeInType _ _ = return ()
notInKinds :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
notInKinds env ty
| isRnKindLevel env
= addErr (text "Illegal kind (even with TypeInType enabled):" <+> 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_bndr_kvs,
implicit_body_kvs, implicit_kvs :: [Located RdrName]
bndrs = map hsLTyVarLocName hs_tv_bndrs
kv_occs = body_kv_occs ++ bndr_kv_occs
implicit_bndr_kvs = filter_occs rdr_env bndrs bndr_kv_occs
implicit_body_kvs = filter_occs rdr_env (implicit_bndr_kvs ++ bndrs) body_kv_occs
implicit_kvs = implicit_bndr_kvs ++ implicit_body_kvs
dep_bndrs = filter (`elemRdr` kv_occs) bndrs
; traceRn "checkMixedVars3" $
vcat [ text "kv_occs" <+> ppr kv_occs
, text "bndrs" <+> ppr bndrs ]
; checkBadKindBndrs doc implicit_kvs
; checkMixedVars kv_occs bndrs
; 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_implicit = implicit_kv_nms
, hsq_explicit = rn_bndrs
, hsq_dependent = mkNameSet dep_bndr_nms })
(null implicit_body_kvs) } }
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 lrdr@(L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside (L loc (UserTyVar (L lv nm))) }
bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar 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 (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
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]
HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
HsListTy ty -> go ty
HsPArrTy 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
HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
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
HsCoreTy{} -> mempty
HsTyLit{} -> mempty
HsTyVar{} -> mempty
gos = mconcat . map go
prefix_types_only (HsAppPrefix ty) = Just ty
prefix_types_only (HsAppInfix _) = Nothing
collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
where
go (UserTyVar _) = []
go (KindedTyVar _ ki) = collectAnonWildCards ki
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 new_names new_ty new_haddock_doc), fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
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 ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1
(\t1 t2 -> HsOpTy 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 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 e11 op1 fix1 e12)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2)
| associate_right = do
new_e <- mkOpAppRn e12 op2 fix2 e2
return (OpApp e11 op1 fix1 (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 e1 op2 fix2 e2)
| associate_right
= do new_e <- mkOpAppRn neg_arg op2 fix2 e2
return (NegApp (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 e1 op1 fix1 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 e1 op fix 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 id -> SyntaxExpr id -> RnM (HsExpr id)
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
return (NegApp 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 op1 f (Just fix1)
[a11,a12])) _ _ _))
op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
return (HsCmdArrForm op1 f (Just fix1)
[a11, L loc (HsCmdTop (L loc new_c)
placeHolderType placeHolderType [])])
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpFormRn arg1 op fix arg2
= return (HsCmdArrForm 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 ()
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 _ op' fix _ -> 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")
checkBadKindBndrs :: HsDocContext -> [Located RdrName] -> RnM ()
checkBadKindBndrs doc kvs
= unless (null kvs) $
unlessXOptM LangExt.PolyKinds $
addErr (withHsDocContext doc $
hang (text "Unexpected kind variable" <> plural kvs
<+> pprQuotedList kvs)
2 (text "Perhaps you intended to use PolyKinds"))
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"
emptyNonSymsErr :: HsType GhcPs -> SDoc
emptyNonSymsErr overall_ty
= text "Operator applied to too few arguments:" <+> ppr overall_ty
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_qvars = qvs
, con_cxt = ctxt, con_details = details }) acc
= extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
extract_mlctxt ctxt =<<
extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
extract_mlctxt Nothing acc = return acc
extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
extract_lctxt :: TypeOrKind
-> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
extract_ltys :: TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
-> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
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 -> FreeKiTyVars -> RnM FreeKiTyVars
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
HsAppsTy tys -> extract_apps t_or_k tys acc
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
HsPArrTy 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
HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
extract_lty t_or_k ty2 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
HsCoreTy {} -> return 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
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
HsWildCardTy {} -> return acc
extract_apps :: TypeOrKind
-> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
-> RnM FreeKiTyVars
extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc
extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
-> FreeKiTyVars -> RnM FreeKiTyVars
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 :: [Located RdrName]
tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
; traceRn "checkMixedVars1" $
vcat [ text "body_kvs" <+> ppr body_kvs
, text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ]
; checkMixedVars body_kvs tv_bndr_rdrs
; return $
FKTV (filterOut (`elemRdr` tv_bndr_rdrs) (bndr_kvs ++ body_kvs)
++ 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 -> FreeKiTyVars
-> RnM FreeKiTyVars
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)
checkMixedVars :: [Located RdrName] -> [Located RdrName] -> RnM ()
checkMixedVars kvs tvs
= do { type_in_type <- xoptM LangExt.TypeInType
; unless type_in_type $
mapM_ check kvs }
where
check kv = when (kv `elemRdr` tvs) $
addErrAt (getLoc kv) $
vcat [ text "Variable" <+> quotes (ppr kv)
<+> text "used as both a kind and a type"
, text "Did you intend to use TypeInType?" ]