[Git][ghc/ghc][wip/warn-badly-staged-types] Add warning for badly staged types.
Oleg Grenrus (@phadej)
gitlab at gitlab.haskell.org
Thu Aug 31 18:43:35 UTC 2023
Oleg Grenrus pushed to branch wip/warn-badly-staged-types at Glasgow Haskell Compiler / GHC
Commits:
57a46064 by Oleg Grenrus at 2023-08-31T21:43:20+03:00
Add warning for badly staged types.
Resolves #23829.
The stage violation results in out-of-bound names in splices.
Technically this is an error, but someone might rely on this!?
Internal changes:
- we now track stages for TyVars.
- thLevel (RunSplice _) = 0, instead of panic, as reifyInstances does
in fact rename its argument type, and it can contain variables.
- - - - -
20 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Splice.hs-boot
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/using-warnings.rst
- libraries/Cabal
- + testsuite/tests/th/T23829_hasty.hs
- + testsuite/tests/th/T23829_hasty.stderr
- + testsuite/tests/th/T23829_hasty_b.hs
- + testsuite/tests/th/T23829_hasty_b.stderr
- + testsuite/tests/th/T23829_tardy.ghc.stderr
- + testsuite/tests/th/T23829_tardy.hs
- + testsuite/tests/th/T23829_tardy.stdout
- + testsuite/tests/th/T23829_timely.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -693,6 +693,7 @@ data WarningFlag =
| Opt_WarnImplicitRhsQuantification -- Since 9.8
| Opt_WarnIncompleteExportWarnings -- Since 9.8
| Opt_WarnIncompleteRecordSelectors -- Since 9.10
+ | Opt_WarnBadlyStagedTypes -- Since 9.10
deriving (Eq, Ord, Show, Enum)
-- | Return the names of a WarningFlag
@@ -804,6 +805,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| []
Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| []
Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| []
+ Opt_WarnBadlyStagedTypes -> "badly-staged-types" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
@@ -942,6 +944,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnUnicodeBidirectionalFormatCharacters,
Opt_WarnGADTMonoLocalBinds,
Opt_WarnLoopySuperclassSolve,
+ Opt_WarnBadlyStagedTypes,
Opt_WarnTypeEqualityRequiresOperators
]
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -44,7 +44,7 @@ module GHC.Rename.HsType (
import GHC.Prelude
-import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )
+import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType, checkThLocalTyName )
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Hs
@@ -59,6 +59,7 @@ import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Ppr ( pprHsDocContext )
import GHC.Tc.Utils.Monad
+import GHC.Unit.Module ( getModule )
import GHC.Types.Name.Reader
import GHC.Builtin.Names
import GHC.Types.Hint ( UntickedPromotedThing(..) )
@@ -535,6 +536,9 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
-- Any type variable at the kind level is illegal without the use
-- of PolyKinds (see #14710)
; name <- rnTyVar env rdr_name
+ ; this_mod <- getModule
+ ; when (nameIsLocalOrFrom this_mod name) $
+ checkThLocalTyName name
; when (isDataConName name && not (isPromoted ip)) $
-- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
@@ -12,7 +13,8 @@ module GHC.Rename.Splice (
-- Brackets
rnTypedBracket, rnUntypedBracket,
- checkThLocalName, traceSplice, SpliceInfo(..)
+ checkThLocalName, traceSplice, SpliceInfo(..),
+ checkThLocalTyName,
) where
import GHC.Prelude
@@ -903,6 +905,34 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
+checkThLocalTyName :: Name -> RnM ()
+checkThLocalTyName name
+ | isUnboundName name -- Do not report two errors for
+ = return () -- $(not_in_scope args)
+
+ | otherwise
+ = do { traceRn "checkThLocalTyName" (ppr name)
+ ; mb_local_use <- getStageAndBindLevel name
+ ; case mb_local_use of {
+ Nothing -> return () ; -- Not a locally-bound thing
+ Just (top_lvl, bind_lvl, use_stage) ->
+ do { let use_lvl = thLevel use_stage
+ -- We don't check the well stageness of name here.
+ -- this would break test for #20969
+ --
+ -- Consequently there is no check&restiction for top level splices.
+ -- But it's annoying anyway.
+ --
+ -- Therefore checkCrossStageLiftingTy shouldn't assume anything
+ -- about bind_lvl and use_lvl relation.
+ --
+ -- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
+
+ ; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl
+ <+> ppr use_stage
+ <+> ppr use_lvl)
+ ; checkCrossStageLiftingTy top_lvl bind_lvl use_stage use_lvl name } } }
+
checkThLocalName :: Name -> RnM ()
checkThLocalName name
| isUnboundName name -- Do not report two errors for
@@ -975,6 +1005,24 @@ check_cross_stage_lifting top_lvl name ps_var
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }
+checkCrossStageLiftingTy :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> TcM ()
+checkCrossStageLiftingTy top_lvl bind_lvl _use_stage use_lvl name
+ | isTopLevel top_lvl
+ = return ()
+
+ -- There is no liftType (yet), so we could error, or more conservatively, just warn.
+ --
+ -- For now, we check here for both untyped and typed splices, as we don't create splices.
+ | use_lvl > bind_lvl
+ = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl
+
+ -- See comment in checkThLocalTyName: this can also happen.
+ | bind_lvl < use_lvl
+ = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl
+
+ | otherwise
+ = return ()
+
{-
Note [Keeping things alive for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Rename/Splice.hs-boot
=====================================
@@ -2,6 +2,7 @@ module GHC.Rename.Splice where
import GHC.Hs
import GHC.Tc.Utils.Monad
+import GHC.Types.Name (Name)
import GHC.Types.Name.Set
@@ -13,3 +14,5 @@ rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntyp
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
+
+checkThLocalTyName :: Name -> RnM ()
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1421,6 +1421,11 @@ instance Diagnostic TcRnMessage where
text "Stage error:" <+> pprStageCheckReason reason <+>
hsep [text "is bound at stage" <+> ppr bind_lvl,
text "but used at stage" <+> ppr use_lvl]
+ TcRnBadlyStagedType name bind_lvl use_lvl
+ -> mkSimpleDecorated $
+ text "Badly staged type:" <+> ppr name <+>
+ hsep [text "is bound at stage" <+> ppr bind_lvl,
+ text "but used at stage" <+> ppr use_lvl]
TcRnStageRestriction reason
-> mkSimpleDecorated $
sep [ text "GHC stage restriction:"
@@ -2283,6 +2288,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnBadlyStaged{}
-> ErrorWithoutFlag
+ TcRnBadlyStagedType{}
+ -> WarningWithFlag Opt_WarnBadlyStagedTypes
TcRnStageRestriction{}
-> ErrorWithoutFlag
TcRnTyThingUsedWrong{}
@@ -2920,6 +2927,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnBadlyStaged{}
-> noHints
+ TcRnBadlyStagedType{}
+ -> noHints
TcRnStageRestriction{}
-> noHints
TcRnTyThingUsedWrong{}
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3292,6 +3292,21 @@ data TcRnMessage where
:: !StageCheckReason -- ^ The binding being spliced.
-> TcRnMessage
+ {-| TcRnBadlyStagedWarn is a warning that occurs when a TH type binding is
+ used in an invalid stage.
+
+ Controlled by flags:
+ - Wbadly-staged-type
+
+ Test cases:
+ T23829_timely T23829_tardy T23829_hasty
+ -}
+ TcRnBadlyStagedType
+ :: !Name -- ^ The type binding being spliced.
+ -> !Int -- ^ The binding stage.
+ -> !Int -- ^ The stage at which the binding is used.
+ -> TcRnMessage
+
{-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another
thing was expected.
=====================================
compiler/GHC/Tc/Types/TH.hs
=====================================
@@ -17,7 +17,6 @@ import qualified Language.Haskell.TH as TH
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
import GHC.Prelude
-import GHC.Utils.Panic
import GHC.Tc.Types.TcRef
import GHC.Tc.Types.Constraint
import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )
@@ -105,7 +104,7 @@ thLevel :: ThStage -> ThLevel
thLevel (Splice _) = 0
thLevel Comp = 1
thLevel (Brack s _) = thLevel s + 1
-thLevel (RunSplice _) = panic "thLevel: called when running a splice"
+thLevel (RunSplice _) = 0 -- previously: panic "thLevel: called when running a splice"
-- See Note [RunSplice ThLevel].
{- Note [RunSplice ThLevel]
@@ -113,6 +112,12 @@ thLevel (RunSplice _) = panic "thLevel: called when running a splice"
The 'RunSplice' stage is set when executing a splice, and only when running a
splice. In particular it is not set when the splice is renamed or typechecked.
+However, this is not true. `reifyInstances` for example does rename the given type,
+and these types may contain variables (#9262 allow free variables in reifyInstances).
+Therefore here we assume that thLevel (RunSplice _) = 0.
+Proper fix would probably require renaming argument `reifyInstances` separately prior
+to evaluation of the overall splice.
+
'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert
the finalizer (see Note [Delaying modFinalizers in untyped splices]), and
'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -644,8 +644,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
-- (GlobalRdrEnv handles the top level)
, tcl_th_bndrs = extendNameEnvList th_bndrs
- [(n, thlvl) | (n, ATcId {}) <- extra_env]
- -- We only track Ids in tcl_th_bndrs
+ [(n, thlvl) | (n, _) <- extra_env]
, tcl_env = extendNameEnvList lcl_type_env extra_env }
-- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -532,6 +532,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333
GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254
GhcDiagnosticCode "TcRnBadlyStaged" = 28914
+ GhcDiagnosticCode "TcRnBadlyStagedType" = 86357
GhcDiagnosticCode "TcRnStageRestriction" = 18157
GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969
GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -78,6 +78,7 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Wforall-identifier`
* :ghc-flag:`-Wgadt-mono-local-binds`
* :ghc-flag:`-Wtype-equality-requires-operators`
+ * :ghc-flag:`-Wbadly-staged-types"
.. ghc-flag:: -W
:shortdesc: enable normal warnings
@@ -2531,4 +2532,21 @@ sanity, not yours.)
import A
When :ghc-flag:`-Wincomplete-export-warnings` is enabled, GHC warns about exports
- that are not deprecating a name that is deprecated with another export in that module.
\ No newline at end of file
+ that are not deprecating a name that is deprecated with another export in that module.
+
+.. ghc-flag:: -Wbadly-staged-types
+ :shortdesc: warn when type binding is used at the wrong TH stage.
+ :type: dynamic
+ :reverse: -Wno-badly-staged-types
+
+ :since: 9.10.1
+
+ Consider an example: ::
+
+ tardy :: forall a. Proxy a -> IO Type
+ tardy _ = [t| a |]
+
+ The type binding ``a`` is bound at stage 1 but used on stage 2.
+
+ This is badly staged program, and the ``tardy (Proxy @Int)`` won't produce
+ a type representation of ``Int``, but rather a local name ``a``.
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit baa767a90dd8c0d3bafd82b48ff8e83b779f238a
+Subproject commit 75e340ceb9beaea9dfc4347684519b0ca3d6a8f8
=====================================
testsuite/tests/th/T23829_hasty.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskellQuotes, TypeApplications #-}
+module Main (main) where
+
+import Language.Haskell.TH
+import Data.Proxy
+
+hasty :: Q Type -> Int
+hasty ty = const @Int @($ty) 42
+
+main :: IO ()
+main = print $ hasty [| Char |]
=====================================
testsuite/tests/th/T23829_hasty.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23829_hasty.hs:8:26: error: [GHC-18157]
+ • GHC stage restriction:
+ ‘ty’ is used in a top-level splice, quasi-quote, or annotation,
+ and must be imported, not defined locally
+ • In the untyped splice: $ty
=====================================
testsuite/tests/th/T23829_hasty_b.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskellQuotes, TypeApplications #-}
+module Main (main) where
+
+import Language.Haskell.TH
+import Data.Proxy
+
+hasty :: IO Type
+hasty = [t| forall (ty :: TypeQ). Proxy $ty |]
+
+main :: IO ()
+main = hasty >>= print
=====================================
testsuite/tests/th/T23829_hasty_b.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23829_hasty_b.hs:8:42: error: [GHC-28914]
+ • Stage error: ‘ty’ is bound at stage 2 but used at stage 1
+ • In the untyped splice: $ty
+ In the Template Haskell quotation
+ [t| forall (ty :: TypeQ). Proxy $ty |]
=====================================
testsuite/tests/th/T23829_tardy.ghc.stderr
=====================================
@@ -0,0 +1,11 @@
+[1 of 2] Compiling Main ( T23829_tardy.hs, T23829_tardy.o )
+
+T23829_tardy.hs:9:15: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
+ Badly staged type: a is bound at stage 1 but used at stage 2
+
+T23829_tardy.hs:12:19: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
+ Badly staged type: a is bound at stage 1 but used at stage 2
+
+T23829_tardy.hs:15:20: warning: [GHC-86357] [-Wbadly-staged-types (in -Wdefault)]
+ Badly staged type: a is bound at stage 1 but used at stage 2
+[2 of 2] Linking T23829_tardy
=====================================
testsuite/tests/th/T23829_tardy.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskellQuotes, TypeApplications #-}
+module Main (main) where
+
+import Language.Haskell.TH
+import Data.Char
+import Data.Proxy
+
+tardy :: forall a. Proxy a -> IO Type
+tardy _ = [t| a |]
+
+tardy2 :: forall a. Proxy a -> IO Exp
+tardy2 _ = [| id @a |]
+
+tardy3 :: forall a. Proxy a -> Code IO (a -> a)
+tardy3 _ = [|| id @a ||]
+
+main :: IO ()
+main = do
+ tardy (Proxy @Int) >>= putStrLn . filt . show
+ tardy2 (Proxy @Int) >>= putStrLn . filt . show
+ examineCode (tardy3 (Proxy @Int)) >>= putStrLn . filt . show . unType
+
+-- ad-hoc filter uniques, a_12313 -> a
+filt :: String -> String
+filt = go where
+ go [] = []
+ go ('_' : rest) = go (dropWhile isDigit rest)
+ go (c:cs) = c : go cs
=====================================
testsuite/tests/th/T23829_tardy.stdout
=====================================
@@ -0,0 +1,3 @@
+VarT a
+AppTypeE (VarE GHC.Base.id) (VarT a)
+AppTypeE (VarE GHC.Base.id) (VarT a)
=====================================
testsuite/tests/th/T23829_timely.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskellQuotes, TypeApplications #-}
+module T99999_timely (main) where
+
+import Language.Haskell.TH
+import Data.Proxy
+
+timely :: IO Type
+timely = [t| forall a. a |]
+
+type Foo = Int
+
+timely_top :: IO Type
+timely_top = [t| Foo |]
+
+main :: IO ()
+main = do
+ timely >>= print
+ timely_top >>= print
\ No newline at end of file
=====================================
testsuite/tests/th/all.T
=====================================
@@ -583,3 +583,7 @@ test('T23525', normal, compile, [''])
test('CodeQ_HKD', normal, compile, [''])
test('T23748', normal, compile, [''])
test('T23796', normal, compile, [''])
+test('T23829_timely', normal, compile, [''])
+test('T23829_tardy', normal, warn_and_run, [''])
+test('T23829_hasty', normal, compile_fail, [''])
+test('T23829_hasty_b', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57a46064248336a24b32c91adbee0642555c6979
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57a46064248336a24b32c91adbee0642555c6979
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/20230831/f5713691/attachment-0001.html>
More information about the ghc-commits
mailing list