Boot files (#2377)

* Prefer source modules when combining HPTs

* add a direct import into a module's boot module

* disable boot fake import dependency

* Add a test

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

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

@@ -106,7 +106,7 @@ import           Data.Map                          (Map)
 import           Data.Tuple.Extra                  (dupe)
 import           Data.Unique                       as Unique
 import           Development.IDE.Core.Tracing      (withTrace)
-import           Development.IDE.GHC.Compat.Util   (emptyUDFM, plusUDFM)
+import           Development.IDE.GHC.Compat.Util   (emptyUDFM, plusUDFM_C)
 import qualified Language.LSP.Server               as LSP
 import qualified Language.LSP.Types                as LSP
 import           Unsafe.Coerce
@@ -702,11 +702,15 @@ mergeEnvs env extraModSummaries extraMods envs = do
                 (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
                 $ zip ims ifrs
     return $ loadModulesHome extraMods $ env{
-        hsc_HPT = foldMapBy plusUDFM emptyUDFM hsc_HPT envs,
+        hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
         hsc_FC = newFinderCache,
         hsc_mod_graph = mkModuleGraph $ extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)
     }
     where
+        mergeUDFM = plusUDFM_C combineModules
+        combineModules a b
+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a
+          | otherwise = b
     -- required because 'FinderCache':
     --  1) doesn't have a 'Monoid' instance,
     --  2) is abstract and doesn't export constructors

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

@@ -348,7 +348,22 @@ getLocatedImportsRule =
                 Left diags              -> pure (diags, Just (modName, Nothing))
                 Right (FileImport path) -> pure ([], Just (modName, Just path))
                 Right PackageImport     -> pure ([], Nothing)
-        let moduleImports = catMaybes imports'
+
+        {- IS THIS REALLY NEEDED? DOESNT SEEM SO
+
+        -- does this module have an hs-boot file? If so add a direct dependency
+        let bootPath = toNormalizedFilePath' $ fromNormalizedFilePath file <.> "hs-boot"
+        boot <- use GetFileExists bootPath
+        bootArtifact <- if boot == Just True
+              then do
+                let modName = ms_mod_name ms
+                loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath)
+                return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True))
+              else pure Nothing
+        -}
+        let bootArtifact = Nothing
+
+        let moduleImports = catMaybes $ bootArtifact : imports'
         pure (concat diags, Just moduleImports)
 
 type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
@@ -374,7 +389,7 @@ rawDependencyInformation fs = do
 
     go :: NormalizedFilePath -- ^ Current module being processed
        -> Maybe ModSummary   -- ^ ModSummary of the module
-       -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
+       -> RawDepM FilePathId
     go f msum = do
       -- First check to see if we have already processed the FilePath
       -- If we have, just return its Id but don't update any of the state.

ghcide/src/Development/IDE/GHC/Compat/Util.hs

@@ -62,6 +62,7 @@ module Development.IDE.GHC.Compat.Util (
     -- * UniqDFM
     emptyUDFM,
     plusUDFM,
+    plusUDFM_C,
     -- * String Buffer
     StringBuffer(..),
     hGetStringBuffer,

ghcide/test/data/boot2/A.hs

@@ -0,0 +1,12 @@
+module A where
+
+-- E source imports B
+-- In interface file see source module dependencies: B {-# SOURCE #-}
+import E
+-- C imports B
+-- In interface file see source module dependencies: B
+import C
+
+-- Instance for B only available from B.hi not B.hi-boot, so tests we load
+-- that.
+main = print B

ghcide/test/data/boot2/B.hs

@@ -0,0 +1,8 @@
+module B where
+
+import D
+
+data B = B
+
+instance Show B where
+  show B = "B"

ghcide/test/data/boot2/B.hs-boot

@@ -0,0 +1,3 @@
+module B where
+
+data B = B

ghcide/test/data/boot2/C.hs

@@ -0,0 +1,3 @@
+module C where
+
+import B

ghcide/test/data/boot2/D.hs

@@ -0,0 +1,3 @@
+module D where
+
+import {-# SOURCE #-} B

ghcide/test/data/boot2/E.hs

@@ -0,0 +1,3 @@
+module E(B(B)) where
+
+import {-# SOURCE #-} B

ghcide/test/data/boot2/hie.yaml

@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}}

ghcide/test/exe/Main.hs

@@ -5277,25 +5277,28 @@ ifaceTests = testGroup "Interface loading tests"
     ]
 
 bootTests :: TestTree
-bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do
-  let cPath = dir </> "C.hs"
-  cSource <- liftIO $ readFileUtf8 cPath
-
-  -- Dirty the cache
-  liftIO $ runInDir dir $ do
-    cDoc <- createDoc cPath "haskell" cSource
-    _ <- getHover cDoc $ Position 4 3
-    ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
-      FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-        A.Success fp' <- pure $ fromJSON fp
-        if equalFilePath fp' cPath then pure () else Nothing
-      _ -> Nothing
-    closeDoc cDoc
-
-  cdoc <- createDoc cPath "haskell" cSource
-  locs <- getDefinitions cdoc (Position 7 4)
-  let floc = mkR 9 0 9 1
-  checkDefs locs (pure [floc])
+bootTests = testGroup "boot"
+  [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do
+        let cPath = dir </> "C.hs"
+        cSource <- liftIO $ readFileUtf8 cPath
+        -- Dirty the cache
+        liftIO $ runInDir dir $ do
+            cDoc <- createDoc cPath "haskell" cSource
+            _ <- getHover cDoc $ Position 4 3
+            ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
+                FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
+                    A.Success fp' <- pure $ fromJSON fp
+                    if equalFilePath fp' cPath then pure () else Nothing
+                _ -> Nothing
+            closeDoc cDoc
+        cdoc <- createDoc cPath "haskell" cSource
+        locs <- getDefinitions cdoc (Position 7 4)
+        let floc = mkR 9 0 9 1
+        checkDefs locs (pure [floc])
+  , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do
+      _ <- openDoc (dir </> "A.hs") "haskell"
+      expectNoMoreDiagnostics 2
+  ]
 
 -- | test that TH reevaluates across interfaces
 ifaceTHTest :: TestTree