GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

3bd7dd44

by mangoiv at 2025-12-04T04:36:45-05:00

Renamer: reinstate the template haskell level check in notFound

Out-of-scope names might be caused by a staging error, as is explained by
Note [Out of scope might be a staging error] in GHC.Tc.Utils.Env.hs.
This logic was assumed to be dead code after 217caad1 and has thus been
removed. This commit reintroduces it and thus fixes issue #26099.

4 changed files:

compiler/GHC/Tc/Utils/Env.hs
+ testsuite/tests/th/T26099.hs
+ testsuite/tests/th/T26099.stderr
testsuite/tests/th/all.T

Changes:

compiler/GHC/Tc/Utils/Env.hs

@@ -8,6 +8,7 @@
                                        -- in module Language.Haskell.Syntax.Extension
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE LambdaCase #-}
 +{-# LANGUAGE MultiWayIf #-}
  module GHC.Tc.Utils.Env(
          TyThing(..), TcTyThing(..), TcId,
@@ -1213,6 +1214,20 @@ pprBinders bndrs  = pprWithCommas ppr bndrs
  notFound :: Name -> TcM TyThing
  notFound name
    = do { lcl_env <- getLclEnv
 +       ; lvls <- getCurrentAndBindLevel name
 +       ; if    -- See Note [Out of scope might be a staging error]
 +           | isUnboundName name -> failM  -- If the name really isn't in scope
 +                                          -- don't report it again (#11941)
 +                                          -- the
 +                                          -- the 'Nothing' case of 'getCurrentAndBindLevel'
 +                                          -- currently means 'isUnboundName' but to avoid
 +                                          -- introducing bugs after a refactoring of that
 +                                          -- function, we check this completely independently
 +                                          -- before scrutinizing lvls
 +           | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls
 +               -> failWithTc (TcRnBadlyLevelled (LevelCheckSplice name Nothing) bind_lvls (thLevelIndex lvl) Nothing ErrorWithoutFlag)
 +           | otherwise  -> pure ()
++
         ; if isTermVarOrFieldNameSpace (nameNameSpace name)
             then
                 -- This code path is only reachable with RequiredTypeArguments enabled
@@ -1243,14 +1258,23 @@ wrongThingErr expected thing name =
  {- Note [Out of scope might be a staging error]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Consider
 -  x = 3
 -  data T = MkT $(foo x)
 +  type T = Int
 +  foo = $(1 :: T)
++
 +GHC currently leaves the user some liberty when it comes to using
 +types in a manner that is theoretically not well-staged.
 +E.g. if `T` here were to be a value, we would reject the program with
 +a staging error. Since it is a type though, we allow it for backwards
 +compatibility reasons.
++
 +However, in this case, we're just in the process of renaming a splice
 +when trying to type check an expression involving a type, that hasn't
 +even been added to the (type checking) environment yet. That is, why
 +it is out of scope.
 -where 'foo' is imported from somewhere.
 +The reason why we cannot recognise this issue earlier is, that if we
 +are not actually type checking the splice, i.e. if we're only using the
 +name of the type (e.g. ''T), the program should be accepted.
 -This is really a staging error, because we can't run code involving 'x'.
 -But in fact the type checker processes types first, so 'x' won't even be
 -in the type envt when we look for it in $(foo x).  So inside splices we
 -report something missing from the type env as a staging error.
 -See #5752 and #5795.
 +We stop and report a staging error.
  -}

testsuite/tests/th/T26099.hs

 +{-# LANGUAGE TemplateHaskell #-}
 +module M where
++
 +type T = Int
++
 +a = $(3 :: T)

testsuite/tests/th/T26099.stderr

 +T26099.hs:6:12: error: [GHC-28914]
 +    • Level error: ‘T’ is bound at level 0 but used at level -1
 +    • In an expression type signature: T
 +      In the expression: 3 :: T
 +      In the untyped splice: $(3 :: T)
++

testsuite/tests/th/all.T

@@ -642,3 +642,4 @@ test('QQInQuote', normal, compile, [''])
  test('QQTopError', normal, compile_fail, ['-fdiagnostics-show-caret'])
  test('GadtConSigs_th_pprint1', normal, compile, [''])
  test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 +test('T26099', normal, compile_fail, [''])