ghcide: implement level-aware module graph edges for GHC 9.14+

ghcide-test/exe/THTests.hs

@@ -4,6 +4,7 @@ module THTests (tests) where
 import           Config
 import           Control.Monad.IO.Class      (liftIO)
 import qualified Data.Text                   as T
+import           Development.IDE.GHC.Compat  (GhcVersion (..), ghcVersion)
 import           Development.IDE.GHC.Util
 import           Development.IDE.Test        (expectCurrentDiagnostics,
                                               expectDiagnostics,
@@ -18,8 +19,7 @@ import           Test.Tasty.HUnit
 
 tests :: TestTree
 tests =
-  testGroup
-    "TemplateHaskell"
+  testGroup "TemplateHaskell" $
     [ -- Test for https://github.com/haskell/ghcide/pull/212
       testWithDummyPluginEmpty "load" $ do
         let sourceA =
@@ -104,6 +104,116 @@ tests =
     _ <- openDoc cPath "haskell"
     expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A", Just "GHC-38417")] ) ]
     ]
+    -- Regression test for GHC 9.14 ExplicitLevelImports.
+    -- Without level-aware module graph edges, HLS crashes with
+    -- `expectJust` in mgQueryZero when `import splice` is used.
+    ++ if ghcVersion >= GHC914
+       then
+        [ testWithDummyPluginEmpty "ExplicitLevelImports-splice-import" $ do
+            let sourceA =
+                  T.unlines
+                    [ "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module A (a) where"
+                    , "import Language.Haskell.TH"
+                    , "a :: ExpQ"
+                    , "a = [| 42 :: Int |]"
+                    ]
+                sourceB =
+                  T.unlines
+                    [ "{-# OPTIONS_GHC -Wall #-}"
+                    , "{-# LANGUAGE ExplicitLevelImports #-}"
+                    , "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module B where"
+                    , "import splice A (a)"
+                    , "b :: Int"
+                    , "b = $a"
+                    , "dummy = 5 :: Int"
+                    ]
+            _ <- createDoc "A.hs" "haskell" sourceA
+            _ <- createDoc "B.hs" "haskell" sourceB
+            expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (7, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
+        , testWithDummyPluginEmpty "ExplicitLevelImports-dual-import" $ do
+            let sourceM =
+                  T.unlines
+                    [ "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module M (m) where"
+                    , "import Language.Haskell.TH"
+                    , "m :: ExpQ"
+                    , "m = [| 100 :: Int |]"
+                    ]
+                sourceC =
+                  T.unlines
+                    [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
+                    , "{-# LANGUAGE ExplicitLevelImports #-}"
+                    , "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module C where"
+                    , "import splice M (m)"
+                    , "import M (m)" -- Normal import alongside splice import
+                    , "c :: Int"
+                    , "c = $m"
+                    , "dummy = 5 :: Int"
+                    ]
+            _ <- createDoc "M.hs" "haskell" sourceM
+            _ <- createDoc "C.hs" "haskell" sourceC
+            expectDiagnostics [ ( "C.hs", [(DiagnosticSeverity_Warning, (8, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
+        , testWithDummyPluginEmpty "ExplicitLevelImports-redundant-mix" $ do
+            let sourceM =
+                  T.unlines
+                    [ "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module M (m) where"
+                    , "import Language.Haskell.TH"
+                    , "m :: ExpQ"
+                    , "m = [| 1 :: Int |]"
+                    ]
+                sourceD =
+                  T.unlines
+                    [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
+                    , "{-# LANGUAGE ExplicitLevelImports #-}"
+                    , "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module D where"
+                    , "import splice M"
+                    , "import M"
+                    , "import splice M" -- Redundant splice import
+                    , "d :: Int"
+                    , "d = $m"
+                    , "dummy = 5 :: Int"
+                    ]
+            _ <- createDoc "M.hs" "haskell" sourceM
+            _ <- createDoc "D.hs" "haskell" sourceD
+            expectDiagnostics [ ( "D.hs", [(DiagnosticSeverity_Warning, (9, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
+        , testWithDummyPluginEmpty "ExplicitLevelImports-transitive" $ do
+            let sourceBase =
+                  T.unlines
+                    [ "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module BaseTH (baseMacro) where"
+                    , "import Language.Haskell.TH"
+                    , "baseMacro :: ExpQ"
+                    , "baseMacro = [| 50 :: Int |]"
+                    ]
+                sourceInter =
+                  T.unlines
+                    [ "{-# LANGUAGE ExplicitLevelImports #-}"
+                    , "{-# LANGUAGE TemplateHaskell #-}"
+                    , "module Intermediate where"
+                    , "import splice BaseTH" -- Splice import here
+                    , "interVal :: Int"
+                    , "interVal = $baseMacro"
+                    ]
+                sourceConsumer =
+                  T.unlines
+                    [ "{-# OPTIONS_GHC -Wall #-}"
+                    , "module Consumer where"
+                    , "import Intermediate" -- Normal import here
+                    , "cons :: Int"
+                    , "cons = interVal"
+                    , "dummy = 5 :: Int"
+                    ]
+            _ <- createDoc "BaseTH.hs" "haskell" sourceBase
+            _ <- createDoc "Intermediate.hs" "haskell" sourceInter
+            _ <- createDoc "Consumer.hs" "haskell" sourceConsumer
+            expectDiagnostics [ ( "Consumer.hs", [(DiagnosticSeverity_Warning, (5, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
+        ]
+       else []
 
 
 -- | Test that all modules have linkables
@@ -147,7 +257,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
     expectDiagnostics
         [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])
         ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Just "GHC-38417")])
-        ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin", Just "GHC-38417")])
+        ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])
         ]
 
     closeDoc adoc

ghcide/src/Development/IDE/Core/Compile.hs

@@ -155,7 +155,7 @@ import           GHC.Unit.Home.Graph                          (UnitEnvGraph(..),
 import           GHC.Unit.Home.PackageTable                   (hptInternalTableRef, hptInternalTableFromRef)
 import           GHC.Unit.Module.ModIface                     (IfaceTopEnv(..))
 import           GHC.Types.Avail                              (emptyDetOrdAvails)
-import           GHC.Types.Basic                              (ImportLevel(..))
+import           GHC.Types.Basic                              (ImportLevel(..), convImportLevel)
 #endif
 
 #if MIN_VERSION_ghc(9,12,0)
@@ -1215,7 +1215,19 @@ getModSummaryFromImports env fp _modTime mContents = do
 #if MIN_VERSION_ghc(9,13,0)
         -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel
         srcImports = map snd $ rn_imps $ map convImport src_idecls
-        textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) $ rn_imps $ map convImport (implicit_imports ++ ordinary_imps)
+
+        -- Extract import level along with pkg qualifier and module name
+        convImportWithLevel (L _ i) = (convImportLevel (ideclLevelSpec i)
+                                      , ideclPkgQual i
+                                      , reLoc $ ideclName i)
+
+        -- Rename package qualifiers while preserving import levels
+        rn_imps_with_level = fmap (\(lvl, pk, lmn@(L _ mn)) -> (lvl, rn_pkg_qual mn pk, lmn))
+
+        -- Implicit imports (prelude) are always NormalLevel;
+        -- explicit user imports preserve their declared level
+        textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) (rn_imps $ map convImport implicit_imports)
+                      ++ rn_imps_with_level (map convImportWithLevel ordinary_imps)
 #else
         srcImports = rn_imps $ map convImport src_idecls
         textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)

ghcide/src/Development/IDE/Core/Rules.hs

@@ -86,7 +86,7 @@ import           Data.IntMap.Strict                           (IntMap)
 import qualified Data.IntMap.Strict                           as IntMap
 import           Data.IORef
 import           Data.List
-import           Data.List.Extra                              (nubOrdOn)
+import           Data.List.Extra                              (nubOrd, nubOrdOn)
 import qualified Data.Map                                     as M
 import           Data.Maybe
 import           Data.Proxy
@@ -143,7 +143,10 @@ import           GHC.Iface.Ext.Utils                          (generateReference
 import qualified GHC.LanguageExtensions                       as LangExt
 #if MIN_VERSION_ghc(9,13,0)
 import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual))
-import           GHC.Types.Basic                              (ImportLevel (NormalLevel))
+import           GHC.Types.Basic                              (ImportLevel (..))
+import           GHC.Unit.Types                               (GenWithIsBoot(..))
+import           GHC.Unit.Module.Graph                        (mkModuleEdge)
+import           GHC.Unit.Module.ModNodeKey                   (mnkModuleName)
 #endif
 import           HIE.Bios.Ghc.Gap                             (hostIsDynamic)
 import qualified HieDb
@@ -639,6 +642,22 @@ getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake rec
   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
   dependencyInfoForFiles (HashSet.toList fs)
 
+#if MIN_VERSION_ghc(9,13,0)
+-- | Build level-aware module graph edges from a ModSummary and a list of dependency NodeKeys.
+-- A module can be imported at multiple levels (e.g. @import splice M@ + @import M@),
+-- so we collect ALL levels per module and produce one edge per (module, level) pair.
+-- This is required for GHC 9.14's level-aware module graph (@mg_zero_graph@).
+mkLevelEdges :: ModSummary -> [NodeKey] -> [ModuleNodeEdge]
+mkLevelEdges ms dep_node_keys = concatMap (\nk -> map (\lvl -> mkModuleEdge lvl nk) (lookupLevels nk)) dep_node_keys
+  where
+    importLevelsMap = M.map nubOrd $ M.fromListWith (++)
+      [(unLoc mn, [lvl]) | (lvl, _pkg, mn) <- ms_textual_imps ms]
+    lookupLevels nk = case nk of
+      NodeKey_Module mnk ->
+        M.findWithDefault [NormalLevel] (gwib_mod $ mnkModuleName mnk) importLevelsMap
+      _ -> [NormalLevel]
+#endif
+
 dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)
 dependencyInfoForFiles fs = do
   (rawDepInfo, bm) <- rawDependencyInformation fs
@@ -651,7 +670,8 @@ dependencyInfoForFiles fs = do
 #if MIN_VERSION_ghc(9,13,0)
       go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_edges (ModuleNodeCompile ms)
         where this_dep_ids = mapMaybe snd xs
-              this_dep_edges = map mkNormalEdge $ mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
+              this_dep_node_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
+              this_dep_edges = mkLevelEdges ms this_dep_node_keys
       go (Just ms) _ = Just $ ModuleNode [] (ModuleNodeCompile ms)
 #else
       go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
@@ -794,8 +814,9 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file =
                   dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
                   return $!! map (NodeKey_Module . msKey) dep_mss
 #if MIN_VERSION_ghc(9,13,0)
+                let final_dep_edges = mkLevelEdges ms final_deps
                 let module_graph_nodes =
-                      nubOrdOn mkNodeKey (ModuleNode (map mkNormalEdge final_deps) (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs)
+                      nubOrdOn mkNodeKey (ModuleNode final_dep_edges (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs)
 #else
                 let module_graph_nodes =
                       nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)