WIP Goto dependency definition

cabal.project

@@ -38,6 +38,11 @@ packages:
          ./plugins/hls-refactor-plugin
          ./plugins/hls-overloaded-record-dot-plugin
 
+source-repository-package
+  type:git
+  location: https://github.com/nlander/HieDb.git
+  tag: f10051a6dc1b809d5f40a45beab92205d1829736
+
 -- Standard location for temporary packages needed for particular environments
 -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script
 -- See https://github.com/haskell/haskell-language-server/blob/master/.gitlab-ci.yml

ghcide/ghcide.cabal

@@ -68,7 +68,7 @@ library
         hls-plugin-api == 2.1.0.0,
         lens,
         list-t,
-        hiedb == 0.4.3.*,
+        hiedb,
         lsp-types ^>= 2.0.0.1,
         lsp ^>= 2.0.0.0 ,
         mtl,
@@ -150,6 +150,7 @@ library
         Development.IDE.Core.Actions
         Development.IDE.Main.HeapStats
         Development.IDE.Core.Debouncer
+        Development.IDE.Core.Dependencies
         Development.IDE.Core.FileStore
         Development.IDE.Core.FileUtils
         Development.IDE.Core.IdeConfiguration

ghcide/session-loader/Development/IDE/Session.hs

@@ -48,6 +48,7 @@ import qualified Data.Text                            as T
 import           Data.Time.Clock
 import           Data.Version
 import           Development.IDE.Core.RuleTypes
+import qualified Development.IDE.Core.Rules           as Rules
 import           Development.IDE.Core.Shake           hiding (Log, Priority,
                                                        withHieDb)
 import qualified Development.IDE.GHC.Compat           as Compat
@@ -127,6 +128,7 @@ data Log
   | LogNoneCradleFound FilePath
   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
   | LogHieBios HieBios.Log
+  | LogRules Rules.Log
 deriving instance Show Log
 
 instance Pretty Log where
@@ -197,6 +199,7 @@ instance Pretty Log where
     LogNewComponentCache componentCache ->
       "New component cache HscEnvEq:" <+> viaShow componentCache
     LogHieBios log -> pretty log
+    LogRules log -> pretty log
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -585,7 +588,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
 
           -- New HscEnv for the component in question, returns the new HscEnvEq and
           -- a mapping from FilePath to the newly created HscEnvEq.
-          let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids
+          let new_cache = newComponentCache recorder extras optExtensions hieYaml _cfp hscEnv uids
           (cs, res) <- new_cache new
           -- Modified cache targets for everything else in the hie.yaml file
           -- which now uses the same EPS and so on
@@ -793,14 +796,15 @@ setNameCache nc hsc = hsc { hsc_NC = nc }
 -- | Create a mapping from FilePaths to HscEnvEqs
 newComponentCache
          :: Recorder (WithPriority Log)
+         -> ShakeExtras
          -> [String]       -- File extensions to consider
          -> Maybe FilePath -- Path to cradle
          -> NormalizedFilePath -- Path to file that caused the creation of this component
          -> HscEnv
          -> [(UnitId, DynFlags)]
          -> ComponentInfo
          -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
+newComponentCache recorder extras exts cradlePath cfp hsc_env uids ci = do
     let df = componentDynFlags ci
     hscEnv' <-
 #if MIN_VERSION_ghc(9,3,0)
@@ -823,7 +827,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
 #endif
 
     let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
-    henv <- newFunc hscEnv' uids
+    henv <- newFunc (cmapWithPrio LogRules recorder) extras hscEnv' uids
     let targetEnv = ([], Just henv)
         targetDepends = componentDependencyInfo ci
         res = (targetEnv, targetDepends)

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

@@ -13,12 +13,20 @@ module Development.IDE.Core.Actions
 , lookupMod
 ) where
 
+import           Control.Concurrent.MVar              (MVar, newEmptyMVar, putMVar, readMVar)
+import           Control.Concurrent.STM               (atomically)
+import           Control.Concurrent.STM.TQueue        (unGetTQueue)
+import           Control.Monad                        (unless)
+import           Control.Monad.Extra                  (mapMaybeM)
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Maybe
+import qualified Data.ByteString                      as BS
+import           Data.Function                        ((&))
 import qualified Data.HashMap.Strict                  as HM
 import           Data.Maybe
 import qualified Data.Text                            as T
 import           Data.Tuple.Extra
+import           Development.IDE.Core.Compile         (loadHieFile)
 import           Development.IDE.Core.OfInterest
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
@@ -31,19 +39,68 @@ import           Development.IDE.Types.HscEnvEq       (hscEnv)
 import           Development.IDE.Types.Location
 import qualified HieDb
 import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
-                                                       SymbolInformation (..))
-
-
--- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
--- project. Right now, this is just a stub.
+                                                       SymbolInformation (..),
+                                                       normalizedFilePathToUri,
+                                                       uriToNormalizedFilePath)
+import           Language.LSP.Server                  (resRootPath)
+import           System.Directory                     (createDirectoryIfMissing,
+                                                       doesFileExist,
+                                                       getPermissions,
+                                                       setOwnerExecutable,
+                                                       setOwnerWritable,
+                                                       setPermissions)
+import           System.FilePath                      ((</>), (<.>), takeDirectory)
+
+
+-- | Generates URIs for files in dependencies, but not in the
+-- project.
 lookupMod
   :: HieDbWriter -- ^ access the database
   -> FilePath -- ^ The `.hie` file we got from the database
   -> ModuleName
   -> Unit
   -> Bool -- ^ Is this file a boot file?
   -> MaybeT IdeAction Uri
-lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing
+lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do
+  mProjectRoot <- (resRootPath =<<) <$> asks lspEnv
+  case mProjectRoot of
+    Nothing -> pure Nothing
+    Just projectRoot -> do
+      completionToken <- liftIO $ newEmptyMVar
+      moduleUri <- writeAndIndexSource projectRoot completionToken
+      liftIO $ readMVar completionToken
+      pure $ Just moduleUri
+  where
+    writeAndIndexSource :: FilePath -> MVar () -> IdeAction Uri
+    writeAndIndexSource projectRoot completionToken = do
+      fileExists <- liftIO $ doesFileExist writeOutPath
+      unless fileExists $ do
+        nc <- asks ideNc
+        liftIO $ do
+          createDirectoryIfMissing True $ takeDirectory writeOutPath
+          moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile
+          BS.writeFile writeOutPath moduleSource
+          fileDefaultPermissions <- getPermissions writeOutPath
+          let filePermissions = fileDefaultPermissions
+                              & setOwnerWritable False
+                              & setOwnerExecutable False
+          setPermissions writeOutPath filePermissions
+      liftIO $ atomically $
+        unGetTQueue indexQueue $ \withHieDb -> do
+          withHieDb $ \db ->
+            HieDb.addSrcFile db hieFile writeOutPath False
+          putMVar completionToken ()
+      pure $ moduleUri
+      where
+        writeOutDir :: FilePath
+        writeOutDir = projectRoot </> ".hls" </> "dependencies" </> show uid
+        writeOutFile :: FilePath
+        writeOutFile = moduleNameSlashes moduleName <.> "hs"
+        writeOutPath :: FilePath
+        writeOutPath = writeOutDir </> writeOutFile
+        moduleUri :: Uri
+        moduleUri = AtPoint.toUri writeOutPath
+
 
 
 -- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined,
@@ -60,16 +117,46 @@ getAtPoint file pos = runMaybeT $ do
   opts <- liftIO $ getIdeOptionsIO ide
 
   (hf, mapping) <- useE GetHieAst file
-  env <- hscEnv . fst <$> useE GhcSession file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)
+  (mEnv, mDkMap) <- case getSourceFileOrigin file of
+    FromDependency -> pure (Nothing, Nothing)
+    FromProject -> do
+      env <- hscEnv . fst <$> useE GhcSession file
+      dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)
+      pure (Just env, Just dkMap)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'
-
-toCurrentLocations :: PositionMapping -> [Location] -> [Location]
-toCurrentLocations mapping = mapMaybe go
+  MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf mDkMap mEnv pos'
+
+-- | For each Loacation, determine if we have the PositionMapping
+-- for the correct file. If not, get the correct position mapping
+-- and then apply the position mapping to the location.
+toCurrentLocations
+  :: PositionMapping
+  -> NormalizedFilePath
+  -> [Location]
+  -> IdeAction [Location]
+toCurrentLocations mapping file = mapMaybeM go
   where
-    go (Location uri range) = Location uri <$> toCurrentRange mapping range
+    go :: Location -> IdeAction (Maybe Location)
+    go (Location uri range) =
+      -- The Location we are going to might be in a different
+      -- file than the one we are calling gotoDefinition from.
+      -- So we check that the location file matches the file
+      -- we are in.
+      if nUri == normalizedFilePathToUri file
+      -- The Location matches the file, so use the PositionMapping
+      -- we have.
+      then pure $ Location uri <$> toCurrentRange mapping range
+      -- The Location does not match the file, so get the correct
+      -- PositionMapping and use that instead.
+      else do
+        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
+          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
+          useE GetHieAst otherLocationFile
+        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
+      where
+        nUri :: NormalizedUri
+        nUri = toNormalizedUri uri
 
 -- | useE is useful to implement functions that aren’t rules but need shortcircuiting
 -- e.g. getDefinition.
@@ -90,15 +177,17 @@ getDefinition file pos = runMaybeT $ do
     (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
     (ImportMap imports, _) <- useE GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
-    toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    MaybeT $ Just <$> toCurrentLocations mapping file locations
 
 getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getTypeDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (hf, mapping) <- useE GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
+    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
+    MaybeT $ Just <$> toCurrentLocations mapping file locations
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do

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

@@ -887,34 +887,32 @@ spliceExpressions Splices{..} =
 -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we
 -- can just increment the 'indexCompleted' TVar and exit.
 --
-indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO ()
-indexHieFile se mod_summary srcPath !hash hf = do
+indexHieFile :: ShakeExtras -> NormalizedFilePath -> HieDb.SourceFile -> Util.Fingerprint -> Compat.HieFile -> IO ()
+indexHieFile se hiePath sourceFile !hash hf = do
  IdeOptions{optProgressStyle} <- getIdeOptionsIO se
  atomically $ do
   pending <- readTVar indexPending
-  case HashMap.lookup srcPath pending of
+  case HashMap.lookup hiePath pending of
     Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled
     _ -> do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
-      modifyTVar' indexPending $ HashMap.insert srcPath hash
+      modifyTVar' indexPending $ HashMap.insert hiePath hash
       writeTQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
           pending <- readTVar indexPending
-          pure $ case HashMap.lookup srcPath pending of
+          pure $ case HashMap.lookup hiePath pending of
             Nothing          -> False
             -- If the hash in the pending list doesn't match the current hash, then skip
             Just pendingHash -> pendingHash /= hash
         unless newerScheduled $ do
           -- Using bracket, so even if an exception happen during withHieDb call,
           -- the `post` (which clean the progress indicator) will still be called.
           bracket_ (pre optProgressStyle) post $
-            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
+            withHieDb (\db -> HieDb.addRefsFromLoaded db (fromNormalizedFilePath hiePath) sourceFile hash hf')
   where
-    mod_location    = ms_location mod_summary
-    targetPath      = Compat.ml_hie_file mod_location
     HieDbWriter{..} = hiedbWriter se
 
     -- Get a progress token to report progress and update it for the current file
@@ -978,15 +976,17 @@ indexHieFile se mod_summary srcPath !hash hf = do
       mdone <- atomically $ do
         -- Remove current element from pending
         pending <- stateTVar indexPending $
-          dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath
+          dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) hiePath
         modifyTVar' indexCompleted (+1)
         -- If we are done, report and reset completed
         whenMaybe (HashMap.null pending) $
           swapTVar indexCompleted 0
       whenJust (lspEnv se) $ \env -> LSP.runLspT env $
         when (coerce $ ideTesting se) $
           LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
-            toJSON $ fromNormalizedFilePath srcPath
+            toJSON $ case sourceFile of
+              HieDb.RealFile sourceFilePath -> sourceFilePath
+              HieDb.FakeFile _ -> fromNormalizedFilePath hiePath
       whenJust mdone $ \done ->
         modifyVar_ indexProgressToken $ \tok -> do
           whenJust (lspEnv se) $ \env -> LSP.runLspT env $
@@ -1007,7 +1007,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =
       GHC.mkHieFile' mod_summary exports ast source
     atomicFileWrite se targetPath $ flip GHC.writeHieFile hf
     hash <- Util.getFileHash targetPath
-    indexHieFile se mod_summary srcPath hash hf
+    indexHieFile se (toNormalizedFilePath' targetPath) (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf
   where
     dflags       = hsc_dflags hscEnv
     mod_location = ms_location mod_summary