[Git][ghc/ghc][wip/warn-badly-staged-types] Add warning for badly staged types.
Oleg Grenrus (@phadej)
gitlab at gitlab.haskell.org
Fri Aug 11 09:14:03 UTC 2023
Oleg Grenrus pushed to branch wip/warn-badly-staged-types at Glasgow Haskell Compiler / GHC
Commits:
54836465 by Oleg Grenrus at 2023-08-11T12:06:31+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.
- #20969 tests fails earlier, as the type annotation is in badly staged.
Things like
foo :: forall a. (Lift a, Num a) => a
foo = $$(liftTyped 0 :: Code Q a)
cannot work, as e.g. `Num` dictionary is true run time information.
Therefore
foo :: forall a. Num a => a
foo = $$(liftTyped _ :: Code Q a)
could report a type, but as stages are in fact checked before
type-checking, it's impossible now. (For typed-TH they could be
checked during type-checking, as is done for terms).
- - - - -
18 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
- + testsuite/tests/th/T23829_hasty.hs
- + testsuite/tests/th/T23829_hasty.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
- testsuite/tests/typecheck/no_skolem_info/T20969.stderr
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -688,6 +688,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
@@ -799,6 +800,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
@@ -937,6 +939,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,24 @@ 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
+ ; 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 +995,20 @@ 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
+
+ | 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
=====================================
@@ -1417,6 +1417,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:"
@@ -2279,6 +2284,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnBadlyStaged{}
-> ErrorWithoutFlag
+ TcRnBadlyStagedType{}
+ -> WarningWithFlag Opt_WarnBadlyStagedTypes
TcRnStageRestriction{}
-> ErrorWithoutFlag
TcRnTyThingUsedWrong{}
@@ -2916,6 +2923,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnBadlyStaged{}
-> noHints
+ TcRnBadlyStagedType{}
+ -> noHints
TcRnStageRestriction{}
-> noHints
TcRnTyThingUsedWrong{}
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3296,6 +3296,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 bidning being spliced.
+ -> !Int -- ^ The binding stage.
+ -> !Int -- ^ The sstage 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 varialbes (#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``.
=====================================
testsuite/tests/th/T23829_hasty.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskellQuotes, TypeApplications #-}
+module T99999_hasty (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_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,6 @@ 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, [''])
=====================================
testsuite/tests/typecheck/no_skolem_info/T20969.stderr
=====================================
@@ -1,23 +1,8 @@
-T20969.hs:10:40: error: [GHC-39999]
- • No instance for ‘TH.Lift a’ arising from a use of ‘TH.liftTyped’
- • In the expression: TH.liftTyped _ :: TH.Code TH.Q a
- In the first argument of ‘fromList’, namely
- ‘[TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]]’
- In the first argument of ‘sequenceCode’, namely
- ‘(fromList [TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]])’
-
-T20969.hs:10:53: error: [GHC-88464]
- • Found hole: _ :: a
- Where: ‘a’ is a rigid type variable bound by
- the type signature for:
- glumber :: forall a. Num a => a -> Seq a
- at T20969.hs:9:1-40
- • In the first argument of ‘TH.liftTyped’, namely ‘_’
- In the expression: TH.liftTyped _ :: TH.Code TH.Q a
- In the first argument of ‘fromList’, namely
- ‘[TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]]’
- • Relevant bindings include
- x :: a (bound at T20969.hs:10:9)
- glumber :: a -> Seq a (bound at T20969.hs:10:1)
- Valid hole fits include x :: a (bound at T20969.hs:10:9)
+T20969.hs:10:71: error: [GHC-18157]
+ • GHC stage restriction:
+ ‘a’ is used in a top-level splice, quasi-quote, or annotation,
+ and must be imported, not defined locally
+ • In the typed splice:
+ $$(sequenceCode
+ (fromList [TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]]))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54836465cb6e6e12e8f3614e65a43e0f3c260bb3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54836465cb6e6e12e8f3614e65a43e0f3c260bb3
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/20230811/97bab6e4/attachment-0001.html>
More information about the ghc-commits
mailing list