[Git][ghc/ghc][wip/sand-witch/pattern- at a-binders] Add flag checks where they are needed
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Tue Jul 4 08:53:55 UTC 2023
Andrei Borzenkov pushed to branch wip/sand-witch/pattern- at a-binders at Glasgow Haskell Compiler / GHC
Commits:
bb242bfb by Andrei Borzenkov at 2023-07-04T12:53:39+04:00
Add flag checks where they are needed
- - - - -
7 changed files:
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- + testsuite/tests/rename/should_fail/T22478e.hs
- + testsuite/tests/rename/should_fail/T22478e.stderr
- + testsuite/tests/rename/should_fail/T22478f.hs
- + testsuite/tests/rename/should_fail/T22478f.stderr
- testsuite/tests/rename/should_fail/all.T
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,
+ HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigTypeOnLevel,
newTyVarNameRn,
rnConDeclFields,
lookupField, mkHsOpTyRn,
@@ -37,7 +37,9 @@ module GHC.Rename.HsType (
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
- nubL, nubN
+ nubL, nubN,
+ -- Error helpers
+ badKindSigErr
) where
import GHC.Prelude
@@ -147,6 +149,14 @@ rnHsPatSigType :: HsPatSigTypeScoping
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
+rnHsPatSigType = rnHsPatSigTypeOnLevel TypeLevel
+
+rnHsPatSigTypeOnLevel :: TypeOrKind
+ -> HsPatSigTypeScoping
+ -> HsDocContext
+ -> HsPatSigType GhcPs
+ -> (HsPatSigType GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
-- Used for
-- - Pattern type signatures, which are only allowed with ScopedTypeVariables
-- - Signatures on binders in a RULE, which are allowed even if
@@ -154,7 +164,7 @@ rnHsPatSigType :: HsPatSigTypeScoping
-- Wildcards are allowed
--
-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
-rnHsPatSigType scoping ctx sig_ty thing_inside
+rnHsPatSigTypeOnLevel 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)
@@ -164,7 +174,7 @@ rnHsPatSigType scoping ctx sig_ty thing_inside
AlwaysBind -> tv_rdrs
NeverBind -> []
; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs ->
- do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty
+ do { (nwcs, pat_sig_ty', fvs1) <- rnWcBodyOnLevel 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'
@@ -183,10 +193,14 @@ rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
+ -> RnM ([Name], LHsType GhcRn, FreeVars)
+rnWcBody = rnWcBodyOnLevel TypeLevel
+
+rnWcBodyOnLevel :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
-rnWcBody ctxt nwc_rdrs hs_ty
+rnWcBodyOnLevel level ctxt nwc_rdrs hs_ty
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs
- ; let env = RTKE { rtke_level = TypeLevel
+ ; let env = RTKE { rtke_level = level
, rtke_what = RnTypeBody
, rtke_nwcs = mkNameSet nwcs
, rtke_ctxt = ctxt }
@@ -576,7 +590,7 @@ rnHsTyKi env listTy@(HsListTy x ty)
rnHsTyKi env (HsKindSig x ty k)
= do { kind_sigs_ok <- xoptM LangExt.KindSignatures
- ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
+ ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) k)
; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
; (ty', lhs_fvs) <- bindSigTyVarsFV (hsScopedKvs k') $
rnLHsTyKi env ty
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -56,7 +56,7 @@ import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkUnusedRecordWildcard
, checkDupNames, checkDupAndShadowedNames
- , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier, delLocalNames )
+ , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier, delLocalNames, typeAppErr )
import GHC.Rename.HsType
import GHC.Builtin.Names
@@ -80,7 +80,7 @@ import GHC.Builtin.Types ( nilDataCon )
import GHC.Core.DataCon
import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad ( when, ap, guard )
+import Control.Monad ( when, ap, guard, unless )
import Data.Foldable
import Data.Function ( on )
import Data.Functor.Identity ( Identity (..) )
@@ -93,6 +93,8 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Functor ((<&>))
import GHC.Rename.Doc (rnLHsDoc)
+import GHC.Types.Hint
+import GHC.Types.Fixity (LexicalFixity(..))
{-
*********************************************************
@@ -1256,6 +1258,8 @@ rn_ty_pat (HsAppTy _ fun_ty arg_ty) = do
pure (HsAppTy noExtField fun_ty' arg_ty')
rn_ty_pat (HsAppKindTy _ ty at ki) = do
+ kind_app <- liftRn $ xoptM LangExt.TypeApplications
+ unless kind_app (liftRn $ addErr (typeAppErr KindLevel ki))
ty' <- rn_lty_pat ty
ki' <- rn_lty_pat ki
pure (HsAppKindTy noExtField ty' at ki')
@@ -1283,6 +1287,9 @@ rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do
l_op' <- rn_ty_pat_var l_op
ty2' <- rn_lty_pat ty2
fix <- liftRn $ lookupTyFixityRn l_op'
+ let op_name = unLoc l_op'
+ when (isDataConName op_name && not (isPromoted prom)) $
+ liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2'
rn_ty_pat (HsParTy an ty) = do
@@ -1301,23 +1308,42 @@ rn_ty_pat (HsDocTy an ty haddock_doc) = do
haddock_doc' <- liftRn $ rnLHsDoc haddock_doc
pure (HsDocTy an ty' haddock_doc')
-rn_ty_pat (HsExplicitListTy _ prom tys) = do
+rn_ty_pat ty@(HsExplicitListTy _ prom tys) = do
+ data_kinds <- liftRn $ xoptM LangExt.DataKinds
+ unless data_kinds (liftRn $ addErr (TcRnDataKindsError TypeLevel ty))
+
+ unless (isPromoted prom) $
+ liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
+
tys' <- mapM rn_lty_pat tys
pure (HsExplicitListTy noExtField prom tys')
-rn_ty_pat (HsExplicitTupleTy _ tys) = do
+rn_ty_pat ty@(HsExplicitTupleTy _ tys) = do
+ data_kinds <- liftRn $ xoptM LangExt.DataKinds
+ unless data_kinds (liftRn $ addErr (TcRnDataKindsError TypeLevel ty))
tys' <- mapM rn_lty_pat tys
pure (HsExplicitTupleTy noExtField tys')
-rn_ty_pat (HsTyLit src lit) =
- pure (HsTyLit src (rnHsTyLit lit))
+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
rn_ty_pat (HsWildCardTy _) =
pure (HsWildCardTy noExtField)
rn_ty_pat (HsKindSig an ty ki) = do
ctxt <- askDocContext
- ~(HsPS hsps ki') <- liftRnWithCont $ rnHsPatSigType AlwaysBind ctxt (HsPS noAnn ki)
+ 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)
ty' <- rn_lty_pat ty
tellTPB (tpb_hsps hsps)
pure (HsKindSig an ty' ki')
=====================================
testsuite/tests/rename/should_fail/T22478e.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE NoTypeApplications, NoKindSignatures, NoDataKinds #-}
+module T where
+
+data Proxy a = P
+
+f (P @[a,b]) = ()
+g (P @1) = ()
+h (P @(t @k)) = ()
+j (P @(t :: k)) = ()
+k (P @('(a,b))) = ()
+l (P @"str") = ()
+d (P @'c') = ()
=====================================
testsuite/tests/rename/should_fail/T22478e.stderr
=====================================
@@ -0,0 +1,29 @@
+
+T22478e.hs:6:4: error: [GHC-68567]
+ Illegal type: ‘[a, b]’
+ Suggested fix: Perhaps you intended to use DataKinds
+
+T22478e.hs:7:4: error: [GHC-68567]
+ Illegal type: ‘1’
+ Suggested fix: Perhaps you intended to use DataKinds
+
+T22478e.hs:8:4: error: [GHC-23482]
+ Illegal visible kind application: @k
+ Suggested fix: Perhaps you intended to use TypeApplications
+
+T22478e.hs:9:13: error: [GHC-49378]
+ • Illegal kind signature ‘k’
+ • In a type argument in a pattern
+ Suggested fix: Perhaps you intended to use KindSignatures
+
+T22478e.hs:10:4: error: [GHC-68567]
+ Illegal type: ‘'(a, b)’
+ Suggested fix: Perhaps you intended to use DataKinds
+
+T22478e.hs:11:4: error: [GHC-68567]
+ Illegal type: ‘"str"’
+ Suggested fix: Perhaps you intended to use DataKinds
+
+T22478e.hs:12:4: error: [GHC-68567]
+ Illegal type: ‘'c'’
+ Suggested fix: Perhaps you intended to use DataKinds
=====================================
testsuite/tests/rename/should_fail/T22478f.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -Werror=unticked-promoted-constructors #-}
+module T where
+
+data Proxy a = P
+data Op a b = a :- b
+
+f (P @[a,b]) = ()
+g (P @(a :- b)) = ()
=====================================
testsuite/tests/rename/should_fail/T22478f.stderr
=====================================
@@ -0,0 +1,8 @@
+
+T22478f.hs:8:4: error: [GHC-49957] [-Wunticked-promoted-constructors, Werror=unticked-promoted-constructors]
+ Unticked promoted list.
+ Suggested fix: Add a promotion tick, e.g. '[x,y,z].
+
+T22478f.hs:9:4: error: [GHC-49957] [-Wunticked-promoted-constructors, Werror=unticked-promoted-constructors]
+ Unticked promoted constructor: :-
+ Suggested fix: Use ':- instead of :-
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -207,3 +207,5 @@ test('T23512a', normal, compile_fail, [''])
test('DifferentExportWarnings', normal, multimod_compile_fail, ['DifferentExportWarnings', '-v0'])
test('T22478b', normal, compile_fail, [''])
test('T22478d', normal, compile_fail, [''])
+test('T22478e', normal, compile_fail, [''])
+test('T22478f', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb242bfb763cb7e8eee108029286ed8d2aab4f0f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb242bfb763cb7e8eee108029286ed8d2aab4f0f
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/20230704/37a3b025/attachment-0001.html>
More information about the ghc-commits
mailing list