{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
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,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
extractRdrKindSigVars, extractDataDefnKindVars,
freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars
) where
import {-# SOURCE #-} RnSplice( rnSpliceType )
import DynFlags
import HsSyn
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
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 RdrName
-> RnM (LHsSigWcType Name, FreeVars)
rnHsSigWcType doc sig_ty
= rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
return (sig_ty', emptyFVs)
rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName
-> (LHsSigWcType Name -> 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 RdrName
-> (LHsSigWcType Name -> 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 <- extractFilteredRdrTyVars hs_ty
; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ 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 RdrName -> RnM (LHsWcType Name, 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 RdrName
-> RnM ([Name], LHsType Name, 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 RdrName -> RnM (HsType Name, 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 RdrName
-> 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 RdrName -> RnM FreeKiTyVars
extractFilteredRdrTyVars hs_ty
= do { rdr_env <- getLocalRdrEnv
; filterInScope rdr_env <$> extractHsTyRdrTyVars 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 RdrName
-> RnM (LHsSigType Name, FreeVars)
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
= do { vars <- extractFilteredRdrTyVars hs_ty
; rnImplicitBndrs True vars hs_ty $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
rnImplicitBndrs :: Bool
-> FreeKiTyVars
-> LHsType RdrName
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
= do { let real_tv_rdrs
| no_implicit_if_forall
, L _ (HsForAllTy {}) <- hs_ty = []
| otherwise = freeKiTyVarsTypeVars free_vars
real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
ppr real_rdrs)
; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$
ppr real_rdrs)
; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
; bindLocalNamesFV vars $
thing_inside vars }
rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, 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 Name 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 RdrName -> RnM (LHsType Name, FreeVars)
rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, 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 RdrName -> RnM (LHsContext Name, FreeVars)
rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
rnLHsTyKi :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsTyKi env (L loc ty)
= setSrcSpan loc $
do { (ty', fvs) <- rnHsTyKi env ty
; return (L loc ty', fvs) }
rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, 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 Name]] -> [Located Name]
-> [[LHsType Name]] -> [Located Name]
-> ([[LHsType Name]], [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 Name] -> RnM (LHsType Name)
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 Name] -> [Located Name] -> RnM (LHsType Name)
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 RdrName -> 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 RdrName -> RnM (HsWildCardInfo Name)
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 RdrName)
-> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
= do { bindLHsTyVarBndrs doc mb_in_doc
mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
\ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
thing_inside (HsQTvs { hsq_implicit = rn_kvs
, hsq_explicit = rn_bndrs
, hsq_dependent = dep_var_set }) all_dep_vars }
bindLHsTyVarBndrs :: forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [Located RdrName]
-> [LHsTyVarBndr RdrName]
-> ( [Name]
-> [LHsTyVarBndr Name]
-> NameSet
-> NameSet
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
where
tv_names_w_loc = map hsLTyVarLocName tv_bndrs
go :: [Name]
-> [LHsTyVarBndr Name]
-> NameSet
-> NameSet
-> NameSet
-> [LHsTyVarBndr RdrName]
-> RnM (b, FreeVars)
go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
= bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
\ kv_nms used_dependently tv_bndr' ->
do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
(tv_bndr' : rn_tvs)
(kv_names `extendNameSetList` kv_nms)
(tv_names `extendNameSet` hsLTyVarName tv_bndr')
(dep_vars `unionNameSet` used_dependently)
tv_bndrs
; warn_unused tv_bndr' fvs
; return (b, fvs) }
go rn_kvs rn_tvs _kv_names tv_names dep_vars []
=
bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
all_rn_tvs = reverse rn_tvs
; env <- getLocalRdrEnv
; let all_dep_vars = dep_vars `unionNameSet` others
exp_dep_vars
= mkNameSet [ name
| v <- all_rn_tvs
, let name = hsLTyVarName v
, name `elemNameSet` all_dep_vars ]
; traceRn "bindHsTyVars" (ppr env $$
ppr all_rn_kvs $$
ppr all_rn_tvs $$
ppr exp_dep_vars)
; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
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
-> NameSet
-> NameSet
-> LHsTyVarBndr RdrName
-> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
= case hs_tv_bndr of
L loc (UserTyVar lrdr@(L lv rdr)) ->
do { check_dup loc rdr []
; nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
; check_dup lv rdr (map unLoc free_kvs)
; sig_ok <- xoptM LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
; bindImplicitKvs doc mb_assoc free_kvs tv_names $
\ new_kv_nms other_kv_nms ->
do { (kind', fvs1) <- rnLHsKind doc kind
; tv_nm <- newTyVarNameRn mb_assoc lrdr
; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
thing_inside new_kv_nms other_kv_nms
(L loc (KindedTyVar (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }}
where
check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM ()
check_dup loc rdr kindFreeVars
= do {
when (rdr `elem` kindFreeVars) $
addErrAt loc (vcat [ ki_ty_self_err rdr
, pprHsDocContext doc ])
; m_name <- lookupLocalOccRn_maybe rdr
; whenIsJust m_name $ \name ->
do { when (name `elemNameSet` kv_names) $
addErrAt loc (vcat [ ki_ty_err_msg name
, pprHsDocContext doc ])
; when (name `elemNameSet` tv_names) $
dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
text "used as a kind variable before being bound" $$
text "as a type variable. Perhaps reorder your variables?"
ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+>
text "is used in the kind signature of its" $$
text "declaration as a type variable."
bindImplicitKvs :: HsDocContext
-> Maybe a
-> [Located RdrName]
-> NameSet
-> ([Name] -> NameSet -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindImplicitKvs _ _ [] _ thing_inside
= thing_inside [] emptyNameSet
bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
= do { rdr_env <- getLocalRdrEnv
; let part_kvs lrdr@(L loc kv_rdr)
= case lookupLocalRdrEnv rdr_env kv_rdr of
Just kv_name -> Left (L loc kv_name)
_ -> Right lrdr
(bound_kvs, new_kvs) = partitionWith part_kvs free_kvs
; type_in_type <- xoptM LangExt.TypeInType
; unless type_in_type $
mapM_ (check_tv_used_in_kind tv_names) bound_kvs
; poly_kinds <- xoptM LangExt.PolyKinds
; unless poly_kinds $
addErr (badKindBndrs doc new_kvs)
; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
; bindLocalNamesFV kv_nms $
thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
where
check_tv_used_in_kind :: NameSet
-> Located Name
-> RnM ()
check_tv_used_in_kind tv_names (L loc kv_name)
= when (kv_name `elemNameSet` tv_names) $
addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
text "used in a kind." $$
text "Did you mean to use TypeInType?"
, pprHsDocContext doc ])
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 Name -> [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 Name] -> [Name]
collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
where
go (UserTyVar _) = []
go (KindedTyVar _ ki) = collectAnonWildCards ki
rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName]
-> RnM ([LConDeclField Name], 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 RdrName
-> RnM (LConDeclField Name, 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 RdrName -> FieldOcc Name
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 Name -> LHsType Name -> HsType Name)
-> Name -> Fixity -> LHsType Name -> LHsType Name
-> RnM (HsType Name)
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 Name -> LHsType Name -> HsType Name)
-> Name -> Fixity -> LHsType Name
-> (LHsType Name -> LHsType Name -> HsType Name)
-> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
-> RnM (HsType Name)
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 Name
-> LHsExpr Name -> Fixity
-> LHsExpr Name
-> RnM (HsExpr Name)
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 Name)
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 Name -> 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 Name -> 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 Name
-> LHsExpr Name -> Fixity
-> LHsCmdTop Name
-> RnM (HsCmd Name)
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 Name -> LPat Name
-> RnM (Pat Name)
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 Name -> Bool
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
not_op_pat _ = True
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
checkPrecMatch op (MG { mg_alts = L _ ms })
= mapM_ check ms
where
check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
check _ = return ()
checkPrec :: Name -> Pat Name -> 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 RdrName
-> LHsExpr Name -> LHsExpr Name -> 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 RdrName -> 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 RdrName -> SDoc
unexpectedTypeSigErr ty
= hang (text "Illegal type signature:" <+> quotes (ppr ty))
2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
badKindBndrs doc kvs
= withHsDocContext doc $
hang (text "Unexpected kind variable" <> plural kvs
<+> pprQuotedList kvs)
2 (text "Perhaps you intended to use PolyKinds")
badKindSigErr :: HsDocContext -> LHsType RdrName -> 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 RdrName -> 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 RdrName -> SDoc
inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> 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 RdrName -> 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] }
instance Outputable FreeKiTyVars where
ppr (FKTV kis tys) = ppr (kis, tys)
emptyFKTV :: FreeKiTyVars
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 RdrName -> RnM FreeKiTyVars
extractHsTyRdrTyVars ty
= do { FKTV kis tys <- extract_lty TypeLevel ty emptyFKTV
; return (FKTV (nubL kis)
(nubL tys)) }
extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars
extractHsTysRdrTyVars tys
= rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars
extractHsTysRdrTyVarsDups tys
= extract_ltys TypeLevel tys emptyFKTV
rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
rmDupsInRdrTyVars (FKTV kis tys)
= FKTV (nubL kis) (nubL tys)
extractRdrKindSigVars :: LFamilyResultSig RdrName -> 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 RdrName -> 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 RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars
extract_mlctxt Nothing acc = return acc
extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
extract_lctxt :: TypeOrKind
-> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
extract_ltys :: TypeOrKind
-> [LHsType RdrName] -> 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 RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
extract_lkind = extract_lty KindLevel
extract_lty :: TypeOrKind -> LHsType RdrName -> 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 RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> LHsAppType RdrName -> 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 RdrName] -> FreeKiTyVars
-> FreeKiTyVars -> RnM FreeKiTyVars
extract_hs_tv_bndrs tvs
(FKTV acc_kvs acc_tvs)
(FKTV body_kvs body_tvs)
| null tvs
= return $
FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)
| otherwise
= do { FKTV bndr_kvs _
<- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]
; let locals = map hsLTyVarName tvs
; return $
FKTV (filterOut ((`elem` locals) . unLoc) (bndr_kvs ++ body_kvs)
++ acc_kvs)
(filterOut ((`elem` locals) . unLoc) body_tvs ++ acc_tvs) }
extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
extract_tv t_or_k ltv@(L _ tv) acc
| isRdrTyVar tv = case acc of
FKTV kvs tvs
| isTypeLevel t_or_k
-> do { when (ltv `elemRdr` kvs) $
mixedVarsErr ltv
; return (FKTV kvs (ltv : tvs)) }
| otherwise
-> do { when (ltv `elemRdr` tvs) $
mixedVarsErr ltv
; return (FKTV (ltv : kvs) tvs) }
| otherwise = return acc
where
elemRdr x = any (eqLocated x)
mixedVarsErr :: Located RdrName -> RnM ()
mixedVarsErr (L loc tv)
= do { typeintype <- xoptM LangExt.TypeInType
; unless typeintype $
addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>
text "used as both a kind and a type" $$
text "Did you intend to use TypeInType?" }
nubL :: Eq a => [Located a] -> [Located a]
nubL = nubBy eqLocated