module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,
HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
lookupField,
rnLTyVar,
rnScaledLHsType,
NegationHandling(..),
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars, filterInScopeM,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
nubL, nubN
) where
import GHC.Prelude
import GHC.Rename.Splice( rnSpliceType )
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Driver.Session
import GHC.Hs
import GHC.Rename.Env
import GHC.Rename.Doc
import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV
, typeAppErr, newLocalBndrRn, checkDupRdrNamesN
, checkShadowedRdrNames, warnForallIdentifier )
import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Ppr ( pprScopeError
, inHsDocContext, withHsDocContext, pprHsDocContext )
import GHC.Tc.Utils.Monad
import GHC.Types.Name.Reader
import GHC.Builtin.Names
import GHC.Types.Hint ( UntickedPromotedThing(..) )
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
import GHC.Types.FieldLabel
import GHC.Types.Error
import GHC.Utils.Misc
import GHC.Types.Fixity ( compareFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..) )
import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import Data.List (sortBy, nubBy, partition)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Control.Monad
data HsPatSigTypeScoping
= AlwaysBind
| NeverBind
rnHsSigWcType :: HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType doc (HsWC { hswc_body =
sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) })
= do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty)
; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' ->
do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty
; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $
HsSig { sig_ext = noExtField
, sig_bndrs = outer_bndrs', sig_body = body_ty' }}
, fvs) } }
rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType scoping ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)
; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty)
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = nubN nwc_rdrs'
implicit_bndrs = case scoping of
AlwaysBind -> tv_rdrs
NeverBind -> []
; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs ->
do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty
; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
where
pat_sig_ty = hsPatSigType sig_ty
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)
; (nwc_rdrs', _) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
; (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) }
rnHsPatSigTypeBindingVars :: HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (r, FreeVars))
-> RnM (r, FreeVars)
rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of
(HsPS { hsps_body = hs_ty }) -> do
rdr_env <- getLocalRdrEnv
let (varsInScope, varsNotInScope) =
partition (inScope rdr_env . unLoc) (extractHsTyRdrTyVars hs_ty)
when (not (null varsInScope)) $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
vcat
[ text "Type variable" <> plural varsInScope
<+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))
<+> isOrAre varsInScope
<+> text "already in scope."
, text "Type applications in patterns must bind fresh variables, without shadowing."
]
(wcVars, ibVars) <- partition_nwcs varsNotInScope
rnImplicitTvBndrs ctxt Nothing ibVars $ \ ibVars' -> do
(wcVars', hs_ty', fvs) <- rnWcBody ctxt wcVars hs_ty
let sig_ty = HsPS
{ hsps_body = hs_ty'
, hsps_ext = HsPSRn
{ hsps_nwcs = wcVars'
, hsps_imp_tvs = ibVars'
}
}
(res, fvs') <- thing_inside sig_ty
return (res, fvs `plusFV` fvs')
rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody ctxt nwc_rdrs hs_ty
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs
; let env = RTKE { rtke_level = TypeLevel
, rtke_what = RnTypeBody
, rtke_nwcs = mkNameSet nwcs
, rtke_ctxt = ctxt }
; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
rn_lty env hs_ty
; return (nwcs, hs_ty', fvs) }
where
rn_lty env (L loc hs_ty)
= setSrcSpanA 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 (HsForAllTy { hst_tele = tele, hst_body = hs_body })
= bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
do { (hs_body', fvs) <- rn_lty env hs_body
; return (HsForAllTy { hst_xforall = noExtField
, hst_tele = tele', 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
; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, 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 = noExtField
, 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 Nothing mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
= Just $ ExtraConstraintWildcardNotAllowed
SoleExtraConstraintWildcardNotAllowed
| DerivDeclCtx {} <- rtke_ctxt env
, not (null hs_ctxt)
= Just $ ExtraConstraintWildcardNotAllowed
SoleExtraConstraintWildcardAllowed
| otherwise
= Nothing
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
DerivDeclCtx {} -> True
StandaloneKindSigCtx {} -> False
_ -> False
partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars)
partition_nwcs free_vars
= do { wildcards_enabled <- xoptM LangExt.NamedWildCards
; return $
if wildcards_enabled
then partition is_wildcard free_vars
else ([], free_vars) }
where
is_wildcard :: LocatedN RdrName -> Bool
is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
rnHsSigType :: HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType ctx level
(L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
= setSrcSpanA loc $
do { traceRn "rnHsSigType" (ppr sig_ty)
; case outer_bndrs of
HsOuterExplicit{} -> checkPolyKinds env sig_ty
HsOuterImplicit{} -> pure ()
; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body
; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' ->
do { (body', fvs) <- rnLHsTyKi env body
; return ( L loc $ HsSig { sig_ext = noExtField
, sig_bndrs = outer_bndrs', sig_body = body' }
, fvs ) } }
where
env = mkTyKiEnv ctx level RnTypeBody
rnImplicitTvOccs :: Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside
= do { let implicit_vs = nubN implicit_vs_with_dups
; traceRn "rnImplicitTvOccs" $
vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
; loc <- getSrcSpanM
; let loc' = noAnnSrcSpan loc
; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs
; bindLocalNamesFV vars $
thing_inside vars }
rnImplicitTvBndrs :: HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside
= do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case
(x :| []) -> return x
(x :| _) -> do
let msg = TcRnUnknownMessage $ mkPlainError noHints $
text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."
addErr msg
return x
; traceRn "rnImplicitTvBndrs" $
vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
; vars <- mapM (newTyVarNameRn mb_assoc) implicit_vs
; bindLocalNamesFV vars $
thing_inside vars }
data RnTyKiEnv
= RTKE { rtke_ctxt :: HsDocContext
, rtke_level :: TypeOrKind
, rtke_what :: RnTyKiWhat
, rtke_nwcs :: NameSet
}
data RnTyKiWhat = RnTypeBody
| RnTopConstraint
| RnConstraint
instance Outputable RnTyKiEnv where
ppr (RTKE { rtke_level = lev, rtke_what = what
, rtke_nwcs = wcs, rtke_ctxt = ctxt })
= text "RTKE"
<+> braces (sep [ ppr lev, ppr what, ppr wcs
, pprHsDocContext ctxt ])
instance Outputable RnTyKiWhat where
ppr RnTypeBody = text "RnTypeBody"
ppr RnTopConstraint = text "RnTopConstraint"
ppr RnConstraint = text "RnConstraint"
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv cxt level what
= RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
, rtke_what = what, rtke_ctxt = cxt }
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
isRnKindLevel _ = False
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType doc (HsScaled w ty) = do
(w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w
(ty', fvs) <- rnLHsType doc ty
return (HsScaled w' ty', fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg ctxt (HsValArg ty)
= do { (tys_rn, fvs) <- rnLHsType ctxt ty
; return (HsValArg tys_rn, fvs) }
rnLHsTypeArg ctxt (HsTypeArg l ki)
= do { (kis_rn, fvs) <- rnLHsKind ctxt ki
; return (HsTypeArg l kis_rn, fvs) }
rnLHsTypeArg _ (HsArgPar sp)
= return (HsArgPar sp, emptyFVs)
rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
-> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext env (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
rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext _ Nothing = return (Nothing, emptyFVs)
rnMaybeContext doc (Just theta)
= do { (theta', fvs) <- rnContext doc theta
; return (Just theta', fvs)
}
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi env (L loc ty)
= setSrcSpanA 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_tele = tele, hst_body = tau })
= do { checkPolyKinds env ty
; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
do { (tau', fvs) <- rnLHsTyKi env tau
; return ( HsForAllTy { hst_xforall = noExtField
, hst_tele = tele' , hst_body = tau' }
, fvs) } }
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env ty))
; (ctxt', fvs1) <- rnTyKiContext env lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'
, hst_body = tau' }
, fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
= do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
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
; when (isDataConName name && not (isPromoted ip)) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
; return (HsTyVar noAnn ip (L loc name), unitFV name) }
rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
= setSrcSpan (getLocA l_op) $
do { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
; let op_name = unLoc l_op'
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'
; when (isDataConName op_name && not (isPromoted prom)) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsParTy noAnn ty', fvs) }
rnHsTyKi env (HsBangTy x b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsBangTy x b ty', fvs) }
rnHsTyKi env ty@(HsRecTy _ flds)
= do { let ctxt = rtke_ctxt env
; fls <- get_fields ctxt
; (flds', fvs) <- rnConDeclFields ctxt fls flds
; return (HsRecTy noExtField flds', fvs) }
where
get_fields (ConDeclCtx names)
= concatMapM (lookupConstructorFields . unLoc) names
get_fields _
= do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(hang (text "Record syntax is illegal here:") 2 (ppr ty))
; return [] }
rnHsTyKi env (HsFunTy u mult ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; (mult', w_fvs) <- rnHsArrow env mult
; return (HsFunTy u mult' ty1' ty2'
, plusFVs [fvs1, fvs2, w_fvs]) }
rnHsTyKi env listTy@(HsListTy x ty)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env listTy))
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsListTy x ty', fvs) }
rnHsTyKi env (HsKindSig x ty k)
= do { kind_sigs_ok <- xoptM LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
; (ty', lhs_fvs) <- rnLHsTyKi env ty
; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) }
rnHsTyKi env tupleTy@(HsTupleTy x 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 x tup_con tys', fvs) }
rnHsTyKi env sumTy@(HsSumTy x 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 x 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)
; return (HsTyLit noExtField t, emptyFVs) }
where
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
negLit (HsCharTy _ _) = False
negLitErr :: TcRnMessage
negLitErr = TcRnUnknownMessage $ mkPlainError noHints $
text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsAppKindTy l ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr "kind" k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy x n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
; return (HsIParamTy x n ty', fvs) }
rnHsTyKi _ (HsStarTy _ isUni)
= return (HsStarTy noExtField isUni, emptyFVs)
rnHsTyKi _ (HsSpliceTy _ sp)
= rnSpliceType sp
rnHsTyKi env (HsDocTy x ty haddock_doc)
= do { (ty', fvs) <- rnLHsTyKi env ty
; haddock_doc' <- rnLHsDoc haddock_doc
; return (HsDocTy x ty' haddock_doc', fvs) }
rnHsTyKi env (XHsType ty)
= do mapM_ (check_in_scope . nameRdrName) fvs_list
return (XHsType ty, fvs)
where
fvs_list = map getName $ tyCoVarsOfTypeList ty
fvs = mkFVs fvs_list
check_in_scope :: RdrName -> RnM ()
check_in_scope rdr_name = do
mb_name <- lookupLocalOccRn_maybe rdr_name
when (isNothing mb_name) $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
withHsDocContext (rtke_ctxt env) $
pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name)
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; unless (isPromoted ip) $
addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
; return (HsExplicitListTy noExtField ip tys', fvs) }
rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitTupleTy noExtField tys', fvs) }
rnHsTyKi env (HsWildCardTy _)
= do { checkAnonWildCard env
; return (HsWildCardTy noExtField, emptyFVs) }
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)
rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs)
rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs)
rnHsArrow env (HsExplicitMult pct p arr)
= (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar env rdr_name
= do { name <- lookupTypeOccRn rdr_name
; checkNamedWildCard env name
; return name }
rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
rnLTyVar (L loc rdr_name)
= do { tyvar <- lookupTypeOccRn rdr_name
; return (L loc tyvar) }
rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName
-> RnM (LocatedN Name, FreeVars)
rnHsTyOp env overall_ty (L loc op)
= do { op' <- rnTyVar env op
; unlessXOptM LangExt.TypeOperators $
if (op' `hasKey` eqTyConKey)
then addDiagnostic TcRnTypeEqualityRequiresOperators
else addErr $ TcRnIllegalTypeOperator overall_ty op
; return (L loc op', unitFV op') }
checkWildCard :: RnTyKiEnv
-> Maybe Name
-> Maybe BadAnonWildcardContext
-> RnM ()
checkWildCard env mb_name (Just bad)
= addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)
checkWildCard _ _ Nothing
= return ()
checkAnonWildCard :: RnTyKiEnv -> RnM ()
checkAnonWildCard env
= checkWildCard env Nothing mb_bad
where
mb_bad :: Maybe BadAnonWildcardContext
mb_bad | not (wildCardsAllowed env)
= Just WildcardsNotAllowedAtAll
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnTopConstraint -> Just WildcardNotLastInConstraint
RnConstraint -> Just WildcardNotLastInConstraint
checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
checkNamedWildCard env name
= checkWildCard env (Just name) mb_bad
where
mb_bad | not (name `elemNameSet` rtke_nwcs env)
= Nothing
| not (wildCardsAllowed env)
= Just WildcardsNotAllowedAtAll
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnTopConstraint -> Nothing
RnConstraint -> Just WildcardNotLastInConstraint
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
TypBrCtx {} -> True
SpliceTypeCtx {} -> True
ExprWithTySigCtx {} -> True
PatCtx {} -> True
RuleCtx {} -> True
FamPatCtx {} -> True
GHCiCtx {} -> True
HsTypeCtx {} -> True
StandaloneKindSigCtx {} -> False
_ -> False
checkPolyKinds :: Outputable ty
=> RnTyKiEnv
-> ty
-> RnM ()
checkPolyKinds env ty
| isRnKindLevel env
= do { polykinds <- xoptM LangExt.PolyKinds
; unless polykinds $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(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 $ TcRnUnknownMessage $ mkPlainError noHints $
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 }
bindHsQTyVars :: forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
= do { let bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
; let
bndrs, implicit_kvs :: [LocatedN RdrName]
bndrs = map hsLTyVarLocName hs_tv_bndrs
implicit_kvs = filterFreeVarsToBind bndrs $
bndr_kv_occs ++ body_kv_occs
body_remaining = filterFreeVarsToBind bndr_kv_occs $
filterFreeVarsToBind bndrs body_kv_occs
all_bound_on_lhs = null body_remaining
; traceRn "checkMixedVars3" $
vcat [ text "bndrs" <+> ppr hs_tv_bndrs
, text "bndr_kv_occs" <+> ppr bndr_kv_occs
, text "body_kv_occs" <+> ppr body_kv_occs
, text "implicit_kvs" <+> ppr implicit_kvs
, text "body_remaining" <+> ppr body_remaining
]
; rnImplicitTvOccs mb_assoc implicit_kvs $ \ implicit_kv_nms' ->
bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
do { let
implicit_kv_nms = map (`setNameLoc` bndrs_loc) implicit_kv_nms'
; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
, hsq_explicit = rn_bndrs })
all_bound_on_lhs } }
where
hs_tv_bndrs = hsQTvExplicit hsq_bndrs
bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of
[] -> panic "bindHsQTyVars.bndrs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan
get_bndr_loc (L _ (UserTyVar _ _ ln)) = getLocA ln
get_bndr_loc (L _ (KindedTyVar _ _ ln lk))
= combineSrcSpans (getLocA ln) (getLocA lk)
bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
=> HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
case outer_bndrs of
HsOuterImplicit{} ->
rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->
thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->
thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
, hso_bndrs = exp_bndrs' }
bindHsForAllTelescope :: HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope doc tele thing_inside =
case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
thing_inside $ mkHsForAllVisTele noAnn bndrs'
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
thing_inside $ mkHsForAllInvisTele noAnn bndrs'
data WarnUnusedForalls
= WarnUnusedForalls
| NoWarnUnusedForalls
instance Outputable WarnUnusedForalls where
ppr wuf = text $ case wuf of
WarnUnusedForalls -> "WarnUnusedForalls"
NoWarnUnusedForalls -> "NoWarnUnusedForalls"
bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed)
=> HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
; checkDupRdrNamesN 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 wuf of
WarnUnusedForalls -> warnUnusedForAll doc tv_bndr fvs
NoWarnUnusedForalls -> return ()
bindLHsTyVarBndr :: HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr _doc mb_assoc (L loc
(UserTyVar x fl
lrdr@(L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside (L loc (UserTyVar x fl (L lv nm))) }
bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl 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 fl (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
newTyVarNameRn :: Maybe a
-> LocatedN RdrName -> RnM Name
newTyVarNameRn mb_assoc lrdr@(L _ rdr)
= do { rdr_env <- getLocalRdrEnv
; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
(Just _, Just n) -> return n
_ -> newLocalBndrRn lrdr }
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 { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names
; let new_names = map (fmap (lookupField fl_env)) names
; (new_ty, fvs) <- rnLHsTyKi env ty
; haddock_doc' <- traverse rnLHsDoc haddock_doc
; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')
, fvs) }
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField fl_env (FieldOcc _ (L lr rdr)) =
FieldOcc (flSelector fl) (L lr rdr)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl
mkHsOpTyRn :: PromotionFlag
-> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }
mkHsOpTyRn prom1 op1 _ ty1 ty2
= return (HsOpTy noAnn prom1 ty1 op1 ty2)
mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-> LHsType GhcRn -> SrcSpanAnnA
-> RnM (HsType GhcRn)
mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2
| nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1)
(NormalOp (unLoc op2),fix2)
; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }
| associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))
| otherwise = do {
new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a
; return (noLocA new_ty `op2ty` ty2b) }
where
lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs
lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn :: NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) 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 negation_handling e1b op2 fix2 e2
return (OpApp fix1 e1a op1 (L loc' new_e))
where
loc'= combineLocsA e1b e2
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn ReassociateNegation 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 ReassociateNegation neg_arg op2 fix2 e2
return (NegApp noExtField (L loc' new_e) neg_name)
where
loc' = combineLocsA neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
mkOpAppRn ReassociateNegation 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
= assertPpr (right_op_ok fix (unLoc e2))
(ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $
return (OpApp fix e1 op e2)
data NegationHandling = ReassociateNegation | KeepNegationIntact
data OpName = NormalOp Name
| NegateOp
| UnboundOp OccName
| RecFldOp (FieldOcc 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 _ n)) = NormalOp (unLoc n)
get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
get_op (L _ (HsRecSel _ 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 GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
mkNegAppRn neg_arg neg_name
= assert (not_op_app (unLoc neg_arg)) $
return (NegApp noExtField neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp {}) = False
not_op_app _ = True
mkOpFormRn :: LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity
-> LHsCmdTop GhcRn
-> RnM (HsCmd GhcRn)
mkOpFormRn e1@(L loc
(HsCmdTop _
(L _ (HsCmdArrForm x op1 f (Just fix1)
[e1a,e1b]))))
op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])
| associate_right
= do new_c <- mkOpFormRn e1a op2 fix2 e2
return (HsCmdArrForm noExtField op1 f (Just fix1)
[e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpFormRn arg1 op fix arg2
= return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])
mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) 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 $ ConPat
{ pat_con_ext = noExtField
, pat_con = op2
, pat_args = InfixCon p1 p2
}
}
else if associate_right then do
{ new_p <- mkConOpPatRn op2 fix2 p1b p2
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op1
, pat_args = InfixCon p1a (L loc new_p)
}
}
else return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op2
, pat_args = InfixCon p1 p2
}
}
mkConOpPatRn op _ p1 p2
= assert (not_op_pat (unLoc p2)) $
return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op
, pat_args = InfixCon p1 p2
}
not_op_pat :: Pat GhcRn -> Bool
not_op_pat (ConPat NoExtField _ (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 (locA $ combineSrcSpansA l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
check _ = return ()
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPat NoExtField 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 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 $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Precedence parsing error")
4 (hsep [text "cannot mix", ppr_opfix op1, text "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 $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [text "The operator" <+> ppr_opfix op <+> text "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)
unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage
unexpectedPatSigTypeErr ty
= TcRnUnknownMessage $ mkPlainError noHints $
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)
= setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $
withHsDocContext doc $
hang (text "Illegal kind signature:" <+> quotes (ppr ty))
2 (text "Perhaps you intended to use KindSignatures")
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage
dataKindsErr env thing
= TcRnUnknownMessage $ mkPlainError noHints $
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"
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tv) used_names
= unless (hsTyVarName tv `elemNameSet` used_names) $ do
let msg = TcRnUnknownMessage $
mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $
vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
, inHsDocContext doc ]
addDiagnosticAt (locA loc) msg
type FreeKiTyVars = [LocatedN RdrName]
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM vars
= do { rdr_env <- getLocalRdrEnv
; return (filterInScope rdr_env vars) }
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_tyarg (HsValArg ty) acc = extract_lty ty acc
extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
extract_tyarg (HsArgPar _) acc = acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_tyargs args acc = foldr extract_tyarg acc args
extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
extractHsTyArgRdrKiTyVars args
= extract_tyargs args []
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars ty = extract_lty ty []
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars (L _ ty) =
case ty of
HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
HsKindSig _ _ ki -> extractHsTyRdrTyVars ki
_ -> []
extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extractHsTysRdrTyVars tys = extract_ltys tys
extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
extractRdrKindSigVars (L _ resultSig) = case resultSig of
KindSig _ k -> extractHsTyRdrTyVars k
TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
_ -> []
extractConDeclGADTDetailsTyVars ::
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractConDeclGADTDetailsTyVars con_args = case con_args of
PrefixConGADT args -> extract_scaled_ltys args
RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVars
extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
= maybe [] extractHsTyRdrTyVars ksig
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
-> FreeKiTyVars -> FreeKiTyVars
extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_ltys tys acc = foldr extract_lty acc tys
extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty (L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv ltv acc
HsBangTy _ _ ty -> extract_lty ty acc
HsRecTy _ flds -> foldr (extract_lty
. cd_fld_type . unLoc) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
HsAppKindTy _ ty k -> extract_lty ty $
extract_lty k acc
HsListTy _ ty -> extract_lty ty acc
HsTupleTy _ _ tys -> extract_ltys tys acc
HsSumTy _ tys -> extract_ltys tys acc
HsFunTy _ w ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 $
extract_hs_arrow w acc
HsIParamTy _ _ ty -> extract_lty ty acc
HsOpTy _ _ ty1 tv ty2 -> extract_tv tv $
extract_lty ty1 $
extract_lty ty2 acc
HsParTy _ ty -> extract_lty ty acc
HsSpliceTy {} -> acc
HsDocTy _ ty _ -> extract_lty ty acc
HsExplicitListTy _ _ tys -> extract_ltys tys acc
HsExplicitTupleTy _ tys -> extract_ltys tys acc
HsTyLit _ _ -> acc
HsStarTy _ _ -> acc
HsKindSig _ ty ki -> extract_lty ty $
extract_lty ki acc
HsForAllTy { hst_tele = tele, hst_body = ty }
-> extract_hs_for_all_telescope tele acc $
extract_lty ty []
HsQualTy { hst_ctxt = ctxt, hst_body = ty }
-> extract_lctxt ctxt $
extract_lty ty acc
XHsType {} -> acc
HsWildCardTy {} -> acc
extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
extractHsOuterTvBndrs outer_bndrs $ extract_lty body []
extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
FreeKiTyVars
extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc
extract_hs_arrow _ acc = acc
extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-> FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
extract_hs_for_all_telescope tele acc_vars body_fvs =
case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
extract_hs_tv_bndrs bndrs acc_vars body_fvs
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
extract_hs_tv_bndrs bndrs acc_vars body_fvs
extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs
-> FreeKiTyVars
-> FreeKiTyVars
extractHsOuterTvBndrs outer_bndrs body_fvs =
case outer_bndrs of
HsOuterImplicit{} -> body_fvs
HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs
extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars
where
new_vars
| null tv_bndrs = body_vars
| otherwise = filterFreeVarsToBind tv_bndr_rdrs $ bndr_vars ++ body_vars
bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs tv_bndrs =
foldr extract_lty []
[k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]
extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv tv acc =
if isRdrTyVar (unLoc tv) then tv:acc else acc
nubL :: Eq a => [GenLocated l a] -> [GenLocated l a]
nubL = nubBy eqLocated
nubN :: Eq a => [LocatedN a] -> [LocatedN a]
nubN = nubBy eqLocated
filterFreeVarsToBind :: FreeKiTyVars
-> FreeKiTyVars
-> FreeKiTyVars
filterFreeVarsToBind bndrs = filterOut is_in_scope
where
is_in_scope locc = any (eqLocated locc) bndrs