[Git][ghc/ghc][wip/sand-witch/pattern- at a-binders] Apply int-index suggestions about naming and checking type level literals
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Mon Jul 10 06:28:46 UTC 2023
Andrei Borzenkov pushed to branch wip/sand-witch/pattern- at a-binders at Glasgow Haskell Compiler / GHC
Commits:
6c214e64 by Andrei Borzenkov at 2023-07-10T10:28:33+04:00
Apply int-index suggestions about naming and checking type level literals
- - - - -
3 changed files:
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Types.hs
Changes:
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,
rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType, rnHsTyLit,
- HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigTypeOnLevel,
+ HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind,
newTyVarNameRn,
rnConDeclFields,
lookupField, mkHsOpTyRn,
@@ -138,7 +138,7 @@ rnHsSigWcType doc (HsWC { hswc_body =
; (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
+ do { (wcs, body_ty', fvs) <- rnWcBodyType 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' }}
@@ -149,9 +149,16 @@ rnHsPatSigType :: HsPatSigTypeScoping
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-rnHsPatSigType = rnHsPatSigTypeOnLevel TypeLevel
+rnHsPatSigType = rnHsPatSigTyKi TypeLevel
-rnHsPatSigTypeOnLevel :: TypeOrKind
+rnHsPatSigKind :: HsPatSigTypeScoping
+ -> HsDocContext
+ -> HsPatSigType GhcPs
+ -> (HsPatSigType GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rnHsPatSigKind = rnHsPatSigTyKi KindLevel
+
+rnHsPatSigTyKi :: TypeOrKind
-> HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
@@ -164,7 +171,7 @@ rnHsPatSigTypeOnLevel :: TypeOrKind
-- Wildcards are allowed
--
-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
-rnHsPatSigTypeOnLevel level scoping ctx sig_ty thing_inside
+rnHsPatSigTyKi level 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)
@@ -174,7 +181,7 @@ rnHsPatSigTypeOnLevel level scoping ctx sig_ty thing_inside
AlwaysBind -> tv_rdrs
NeverBind -> []
; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs ->
- do { (nwcs, pat_sig_ty', fvs1) <- rnWcBodyOnLevel level ctx nwc_rdrs pat_sig_ty
+ do { (nwcs, pat_sig_ty', fvs1) <- rnWcBodyTyKi level 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'
@@ -187,18 +194,18 @@ 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
+ ; (wcs, hs_ty', fvs) <- rnWcBodyType ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
-rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
+rnWcBodyType :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
-rnWcBody = rnWcBodyOnLevel TypeLevel
+rnWcBodyType = rnWcBodyTyKi TypeLevel
-rnWcBodyOnLevel :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
+rnWcBodyTyKi :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
-rnWcBodyOnLevel level ctxt nwc_rdrs hs_ty
+rnWcBodyTyKi level ctxt nwc_rdrs hs_ty
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs
; let env = RTKE { rtke_level = level
, rtke_what = RnTypeBody
@@ -616,13 +623,8 @@ rnHsTyKi env sumTy@(HsSumTy x tys)
rnHsTyKi env tyLit@(HsTyLit src t)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env tyLit))
- ; when (negLit t) (addErr $ TcRnNegativeNumTypeLiteral tyLit)
- ; return (HsTyLit src (rnHsTyLit t), emptyFVs) }
- where
- negLit :: HsTyLit (GhcPass p) -> Bool
- negLit (HsStrTy _ _) = False
- negLit (HsNumTy _ i) = i < 0
- negLit (HsCharTy _ _) = False
+ ; t' <- rnHsTyLit t
+ ; return (HsTyLit src t', emptyFVs) }
rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
@@ -687,10 +689,13 @@ rnHsTyKi env (HsWildCardTy _)
; return (HsWildCardTy noExtField, emptyFVs) }
-rnHsTyLit :: HsTyLit GhcPs -> HsTyLit GhcRn
-rnHsTyLit (HsStrTy x s) = HsStrTy x s
-rnHsTyLit (HsNumTy x i) = HsNumTy x i
-rnHsTyLit (HsCharTy x c) = HsCharTy x c
+rnHsTyLit :: HsTyLit GhcPs -> RnM (HsTyLit GhcRn)
+rnHsTyLit (HsStrTy x s) = pure (HsStrTy x s)
+rnHsTyLit tyLit@(HsNumTy x i) = do
+ when (i < 0) $
+ addErr $ TcRnNegativeNumTypeLiteral tyLit
+ pure (HsNumTy x i)
+rnHsTyLit (HsCharTy x c) = pure (HsCharTy x c)
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1327,13 +1327,8 @@ rn_ty_pat ty@(HsExplicitTupleTy _ tys) = do
rn_ty_pat tyLit@(HsTyLit src t) = do
data_kinds <- liftRn $ xoptM LangExt.DataKinds
unless data_kinds (liftRn $ addErr (TcRnDataKindsError TypeLevel tyLit))
- when (negLit t) (liftRn $ addErr $ TcRnNegativeNumTypeLiteral tyLit)
- pure (HsTyLit src (rnHsTyLit t))
- where
- negLit :: HsTyLit (GhcPass p) -> Bool
- negLit (HsStrTy _ _) = False
- negLit (HsNumTy _ i) = i < 0
- negLit (HsCharTy _ _) = False
+ t' <- liftRn $ rnHsTyLit t
+ pure (HsTyLit src t')
rn_ty_pat (HsWildCardTy _) =
pure (HsWildCardTy noExtField)
@@ -1343,7 +1338,7 @@ rn_ty_pat (HsKindSig an ty ki) = do
kind_sigs_ok <- liftRn $ xoptM LangExt.KindSignatures
unless kind_sigs_ok (liftRn $ badKindSigErr ctxt ki)
~(HsPS hsps ki') <- liftRnWithCont $
- rnHsPatSigTypeOnLevel KindLevel AlwaysBind ctxt (HsPS noAnn ki)
+ rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki)
ty' <- rn_lty_pat ty
tellTPB (tpb_hsps hsps)
pure (HsKindSig an ty' ki')
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -717,7 +717,7 @@ data TcRnMessage where
Test cases: th/T8412
typecheck/should_fail/T8306
-}
- TcRnNegativeNumTypeLiteral :: HsType GhcPs -> TcRnMessage
+ TcRnNegativeNumTypeLiteral :: HsTyLit GhcPs -> TcRnMessage
{-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever
the record wildcards '..' are used inside a constructor without labeled fields.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c214e6433738ca6423dcebb4ac30714ff7bc77f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c214e6433738ca6423dcebb4ac30714ff7bc77f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230710/38f0927d/attachment-0001.html>
More information about the ghc-commits
mailing list