Matthew Pickering pushed to branch wip/t29090 at Glasgow Haskell Compiler / GHC Commits: 0437e7b1 by Matthew Pickering at 2025-08-06T14:50:01+01:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 17 changed files: - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Name/Reader.hs - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T Changes: ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Module.Warnings @@ -312,7 +313,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod ; addDiagnostic (TcRnMissingExportList $ moduleName _this_mod) ; let avails = - map fix_faminst . gresToAvailInfo + map fix_faminst . gresToAvailInfo . mapMaybe pickLevelZeroGRE . filter isLocalGRE . globalRdrEnvElts $ rdr_env ; return (Nothing, emptyDefaultEnv, avails, []) } where @@ -384,6 +385,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do { let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + -- NB: this filters out non level 0 exports ; new_gres = [ gre' | (gre, _) <- gre_prs , gre' <- expand_tyty_gre gre ] @@ -451,6 +453,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod let avail = availFromGRE gre name = greName gre + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie [gre] (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -499,6 +502,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs occs ie [gre] return (Just avail, occs', exp_dflts) + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans dont_warn_export @@ -526,6 +530,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -563,6 +568,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -589,17 +595,19 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt -> RnM [GlobalRdrElt] - lookup_ie_kids_all ie (L _ rdr) gre = + lookup_ie_kids_all ie (L _loc rdr) gre = do { let name = greName gre gres = findChildren kids_env name - ; addUsedKids (ieWrappedName rdr) gres - ; when (null gres) $ + -- We only choose level 0 exports when filling in part of an export list implicitly. + ; let kids_0 = mapMaybe pickLevelZeroGRE gres + ; addUsedKids (ieWrappedName rdr) kids_0 + ; when (null kids_0) $ if isTyConName name then addTcRnDiagnostic (TcRnDodgyExports gre) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (TcRnExportHiddenComponents ie) - ; return gres } + ; return kids_0 } ------------- @@ -696,6 +704,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod addUsedKids parent_rdr kid_gres = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) + +ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn +ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l + -- | In what namespaces should we go looking for an import/export item -- that is out of scope, for suggestions in error messages? ieWrappedNameWhatLooking :: IEWrappedName GhcPs -> WhatLooking @@ -800,6 +812,7 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) ; return (replaceLWrappedName n child_nm, child) } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -69,7 +69,7 @@ module GHC.Types.Name.Reader ( lookupGRE_Name, lookupGRE_FieldLabel, getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, + transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE, -- * GlobalRdrElts availFromGRE, @@ -144,7 +144,7 @@ import GHC.Utils.Panic import GHC.Utils.Binary import Control.DeepSeq -import Control.Monad ( guard ) +import Control.Monad ( guard , (>=>) ) import Data.Data import Data.List ( sort ) import qualified Data.List.NonEmpty as NE @@ -641,7 +641,7 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -greLevels :: GlobalRdrElt -> Set.Set ImportLevel +greLevels :: GlobalRdrEltX info -> Set.Set ImportLevel greLevels g = if gre_lcl g then Set.singleton NormalLevel else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g))) @@ -1604,7 +1604,14 @@ pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,Glo -- -- Used only for the 'module M' item in export list; -- see 'GHC.Tc.Gen.Export.exports_from_avail' -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- This function also only chooses GREs which are at level zero. +pickGREsModExp mod gres = mapMaybe (pickLevelZeroGRE >=> pickBothGRE mod) gres + +pickLevelZeroGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickLevelZeroGRE gre = + if NormalLevel `Set.member` greLevels gre + then Just gre + else Nothing -- | isBuiltInSyntax filter out names for built-in syntax They -- just clutter up the environment (esp tuples), and the ===================================== testsuite/tests/splice-imports/DodgyLevelExport.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module DodgyLevelExport ( T(..) ) where + +import quote DodgyLevelExportA +import DodgyLevelExportA (T) ===================================== testsuite/tests/splice-imports/DodgyLevelExport.stderr ===================================== @@ -0,0 +1,4 @@ +DodgyLevelExport.hs:2:27: warning: [GHC-75356] [-Wdodgy-exports (in -Wextra)] + The export item ‘T(..)’ suggests that + ‘T’ has (in-scope) constructors or record fields, but it has none + ===================================== testsuite/tests/splice-imports/DodgyLevelExportA.hs ===================================== @@ -0,0 +1,3 @@ +module DodgyLevelExportA where + +data T = T { a :: Int } ===================================== testsuite/tests/splice-imports/LevelImportExports.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module LevelImportExports ( module LevelImportExportsA, T(..) ) where + +import quote LevelImportExportsA +import splice LevelImportExportsA +import LevelImportExportsA(a, T) ===================================== testsuite/tests/splice-imports/LevelImportExports.stdout ===================================== @@ -0,0 +1,6 @@ +[1 of 2] Compiling LevelImportExportsA ( LevelImportExportsA.hs, LevelImportExportsA.o ) +[2 of 2] Compiling LevelImportExports ( LevelImportExports.hs, LevelImportExports.o ) +exports: + LevelImportExportsA.a + LevelImportExportsA.T +defaults: ===================================== testsuite/tests/splice-imports/LevelImportExportsA.hs ===================================== @@ -0,0 +1,6 @@ +module LevelImportExportsA where + +a = 100 +b = 100 + +data T = T { c :: Int } ===================================== testsuite/tests/splice-imports/Makefile ===================================== @@ -24,5 +24,9 @@ SI10_oneshot: "$(TEST_HC)" $(TEST_HC_OPTS) -c InstanceA.hs "$(TEST_HC)" $(TEST_HC_OPTS) -c SI10.hs +LevelImportExports: + "$(TEST_HC)" $(TEST_HC_OPTS) -haddock LevelImportExports.hs + "$(TEST_HC)" --show-iface LevelImportExports.hi | grep -A3 "^exports:" + clean: rm -f *.o *.hi ===================================== testsuite/tests/splice-imports/ModuleExport.hs ===================================== @@ -0,0 +1,4 @@ +module ModuleExport where + +-- Should fail +import ModuleExportA (a) ===================================== testsuite/tests/splice-imports/ModuleExport.stderr ===================================== @@ -0,0 +1,3 @@ +ModuleExport.hs:4:23: error: [GHC-61689] + Module ‘ModuleExportA’ does not export ‘a’. + ===================================== testsuite/tests/splice-imports/ModuleExportA.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitLevelImports #-} +-- Module export only exports level 0 things (b) +module ModuleExportA (module ModuleExportB) where + +-- Everything at level 1 +import quote ModuleExportB +-- Only b at level 0 +import ModuleExportB (b) ===================================== testsuite/tests/splice-imports/ModuleExportB.hs ===================================== @@ -0,0 +1,6 @@ +module ModuleExportB where + +a = () +b = () + + ===================================== testsuite/tests/splice-imports/T26090.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26090 ( a --varaible + , T(..) -- WithAll + , S(s) -- With + , R -- Abs + ) where + +import quote T26090A +import T26090A (T(T), S) + ===================================== testsuite/tests/splice-imports/T26090.stderr ===================================== @@ -0,0 +1,16 @@ +T26090.hs:2:17: error: [GHC-28914] + • Level error: ‘a’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + +T26090.hs:4:17: error: [GHC-28914] + • Level error: ‘s’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + • In the export: S(s) + +T26090.hs:5:17: error: [GHC-28914] + • Level error: ‘R’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + ===================================== testsuite/tests/splice-imports/T26090A.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26090A where + +import Language.Haskell.TH + +a :: Q Exp +a = [| True |] + +data T = T { t :: () } + +data S = S { s :: () } + +data R = R { r :: () } + ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -48,3 +48,7 @@ test('SI35', test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0']) test('T26087', [], multimod_compile_fail, ['T26087A', '']) test('T26088', [], multimod_compile_fail, ['T26088A', '-v0']) +test('T26090', [], multimod_compile_fail, ['T26090', '-v0']) +test('ModuleExport', [], multimod_compile_fail, ['ModuleExport', '-v0']) +test('LevelImportExports', [], makefile_test, []) +test('DodgyLevelExport', [], multimod_compile, ['DodgyLevelExport', '-v0 -Wdodgy-exports']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0437e7b17e4f3d280b9cbf58db03ec71... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0437e7b17e4f3d280b9cbf58db03ec71... You're receiving this email because of your account on gitlab.haskell.org.