Implement lookupMod function

Author: nlander

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

@@ -10,13 +10,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.PluginUtils
 import           Development.IDE.Core.PositionMapping
@@ -33,18 +40,91 @@ import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
                                                        SymbolInformation (..),
                                                        normalizedFilePathToUri,
                                                        uriToNormalizedFilePath)
+import           Language.LSP.Server                  (resRootPath)
+import           System.Directory                     (createDirectoryIfMissing,
+                                                       doesFileExist,
+                                                       getPermissions,
+                                                       setOwnerExecutable,
+                                                       setOwnerWritable,
+                                                       setPermissions)
+import           System.FilePath                      ((</>), (<.>), takeDirectory)
 
 
--- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
--- project. Right now, this is just a stub.
+-- | Generates URIs for files in dependencies, but not in the
+-- project. Dependency files are produced from an HIE file and
+-- placed in the .hls/dependencies directory.
 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
+  -- We need the project root directory to determine where to put
+  -- the .hls directory.
+  mProjectRoot <- (resRootPath =<<) <$> asks lspEnv
+  case mProjectRoot of
+    Nothing -> pure Nothing
+    Just projectRoot -> do
+      -- Database writes happen asynchronously. We use an MVar to mark
+      -- completion of the database update.
+      completionToken <- liftIO $ newEmptyMVar
+      -- Write out the contents of the dependency source to the
+      -- .hls/dependencies directory, generate a URI for that
+      -- location, and update the HieDb database with the source
+      -- file location.
+      moduleUri <- writeAndIndexSource projectRoot completionToken
+      -- Wait for the database update to be completed.
+      -- Reading the completionToken is blocked until it has
+      -- a value.
+      liftIO $ readMVar completionToken
+      pure $ Just moduleUri
+  where
+    writeAndIndexSource :: FilePath -> MVar () -> IdeAction Uri
+    writeAndIndexSource projectRoot completionToken = do
+      fileExists <- liftIO $ doesFileExist writeOutPath
+      -- No need to write out the file if it already exists.
+      unless fileExists $ do
+        nc <- asks ideNc
+        liftIO $ do
+          -- Create the directory where we will put the source.
+          createDirectoryIfMissing True $ takeDirectory writeOutPath
+          -- Load a raw Bytestring of the source from the HIE file.
+          moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile
+          -- Write the source into the .hls/dependencies directory.
+          BS.writeFile writeOutPath moduleSource
+          fileDefaultPermissions <- getPermissions writeOutPath
+          let filePermissions = fileDefaultPermissions
+                              & setOwnerWritable False
+                              & setOwnerExecutable False
+          -- Set the source file to readonly permissions.
+          setPermissions writeOutPath filePermissions
+      liftIO $ atomically $
+        unGetTQueue indexQueue $ \withHieDb -> do
+          withHieDb $ \db ->
+            -- Add a source file to the database row for
+            -- the HIE file.
+            HieDb.addSrcFile db hieFile writeOutPath False
+          -- Mark completion of the database update.
+          putMVar completionToken ()
+      pure $ moduleUri
+      where
+        -- The source will be written out in a directory from the
+        -- name and hash of the package the dependency module is
+        -- found in. The name and hash are both parts of the UnitId.
+        writeOutDir :: FilePath
+        writeOutDir = projectRoot </> ".hls" </> "dependencies" </> show uid
+        -- The module name is separated into directories, with the
+        -- last part of the module name giving the name of the
+        -- haskell file with a .hs extension.
+        writeOutFile :: FilePath
+        writeOutFile = moduleNameSlashes moduleName <.> "hs"
+        writeOutPath :: FilePath
+        writeOutPath = writeOutDir </> writeOutFile
+        moduleUri :: Uri
+        moduleUri = AtPoint.toUri writeOutPath
+
 
 
 -- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined,

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -20,6 +20,7 @@ module Development.IDE.Spans.AtPoint (
   , defRowToSymbolInfo
   , getNamesAtPoint
   , toCurrentLocation
+  , toUri
   , rowToLoc
   , nameToLocation
   , LookupModule