[Git][ghc/ghc][wip/warn-badly-staged-types] Add warning for badly staged types.

Oleg Grenrus (@phadej) gitlab at gitlab.haskell.org
Fri Sep 1 08:09:48 UTC 2023



Oleg Grenrus pushed to branch wip/warn-badly-staged-types at Glasgow Haskell Compiler / GHC


Commits:
dfd1611b by Oleg Grenrus at 2023-09-01T11:09:35+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.

- - - - -


19 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_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``.


=====================================
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/dfd1611b08737278a73451ba4dfcd98f70d05739

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfd1611b08737278a73451ba4dfcd98f70d05739
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/20230901/68184107/attachment-0001.html>


More information about the ghc-commits mailing list