remove makeAbsolute

Author: soulomoon

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

@@ -437,8 +437,13 @@ getHieDbLoc dir = do
 loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)
 loadSession recorder = loadSessionWithOptions recorder def
 
+toAbsolute :: FilePath -> FilePath -> FilePath
+toAbsolute dir file
+    | isAbsolute file = file
+    | otherwise = dir </> file
 loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
+  let toAbsolutePath = toAbsolute dir
   cradle_files <- newIORef []
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
@@ -459,7 +464,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
       -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
       -- try and normalise that
       -- e.g. see https://github.com/haskell/ghcide/issues/126
-      res' <- traverse makeAbsolute res
+      let res' = toAbsolutePath <$> res
       return $ normalise <$> res'
 
   dummyAs <- async $ return (error "Uninitialised")
@@ -521,7 +526,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
         packageSetup (hieYaml, cfp, opts, libDir) = do
           -- Parse DynFlags for the newly discovered component
           hscEnv <- emptyHscEnv ideNc libDir
-          newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv)
+          newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) dir
           let deps = componentDependencies opts ++ maybeToList hieYaml
           dep_info <- getDependencyInfo deps
           -- Now lookup to see whether we are combining with an existing HscEnv
@@ -588,7 +593,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
           -- HscEnv but set the active component accordingly
           hscEnv <- emptyHscEnv ideNc _libDir
           let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv
-          all_target_details <- new_cache old_deps new_deps
+          all_target_details <- new_cache old_deps new_deps dir
 
           this_dep_info <- getDependencyInfo $ maybeToList hieYaml
           let (all_targets, this_flags_map, this_options)
@@ -713,7 +718,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
             modifyVar_ hscEnvs (const (return Map.empty))
 
           v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags
-          cfp <- makeAbsolute file
+          let cfp = toAbsolutePath file
           case HM.lookup (toNormalizedFilePath' cfp) v of
             Just (opts, old_di) -> do
               deps_ok <- checkDependencyInfo old_di
@@ -735,7 +740,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
     -- before attempting to do so.
     let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         getOptions file = do
-            ncfp <- toNormalizedFilePath' <$> makeAbsolute file
+            let ncfp = toNormalizedFilePath' (toAbsolutePath file)
             cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap
             hieYaml <- cradleLoc file
             sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
@@ -747,7 +752,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
         void $ wait as
         asyncRes <- async $ getOptions file
         return (asyncRes, wait asyncRes)
-      pure opts
+      pure $ (fmap . fmap) toAbsolutePath opts
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.
 -- This then builds dependencies or whatever based on the cradle, gets the
@@ -814,19 +819,20 @@ fromTargetId :: [FilePath]          -- ^ import paths
              -> TargetId
              -> IdeResult HscEnvEq
              -> DependencyInfo
+             -> FilePath
              -> IO [TargetDetails]
 -- For a target module we consider all the import paths
-fromTargetId is exts (GHC.TargetModule modName) env dep = do
+fromTargetId is exts (GHC.TargetModule modName) env dep dir = do
     let fps = [i </> moduleNameSlashes modName -<.> ext <> boot
               | ext <- exts
               , i <- is
               , boot <- ["", "-boot"]
               ]
-    locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps
+    let locs = fmap (toNormalizedFilePath' . toAbsolute dir) fps
     return [TargetDetails (TargetModule modName) env dep locs]
 -- For a 'TargetFile' we consider all the possible module names
-fromTargetId _ _ (GHC.TargetFile f _) env deps = do
-    nf <- toNormalizedFilePath' <$> makeAbsolute f
+fromTargetId _ _ (GHC.TargetFile f _) env deps dir = do
+    let nf = toNormalizedFilePath' $ toAbsolute dir f
     let other
           | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)
           | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")
@@ -915,8 +921,9 @@ newComponentCache
          -> HscEnv             -- ^ An empty HscEnv
          -> [ComponentInfo]    -- ^ New components to be loaded
          -> [ComponentInfo]    -- ^ old, already existing components
+         -> FilePath           -- ^ root dir
          -> IO [ [TargetDetails] ]
-newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
+newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do
     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
         -- When we have multiple components with the same uid,
         -- prefer the new one over the old.
@@ -961,7 +968,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
 
     forM (Map.elems cis) $ \ci -> do
       let df = componentDynFlags ci
-      let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
+      let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath
       thisEnv <- do
 #if MIN_VERSION_ghc(9,3,0)
             -- In GHC 9.4 we have multi component support, and we have initialised all the units
@@ -986,7 +993,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
       logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)
       evaluate $ liftRnf rwhnf $ componentTargets ci
 
-      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
+      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends dir
       ctargets <- concatMapM mk (componentTargets ci)
 
       return (L.nubOrdOn targetTarget ctargets)
@@ -1171,8 +1178,8 @@ addUnit unit_str = liftEwM $ do
   putCmdLineState (unit_str : units)
 
 -- | Throws if package flags are unsatisfiable
-setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target]))
-setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
+setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -> m (NonEmpty (DynFlags, [GHC.Target]))
+setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do
     ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)
     case NE.nonEmpty units of
       Just us -> initMulti us
@@ -1195,7 +1202,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
         --
         -- If we don't end up with a target for the current file in the end, then
         -- we will report it as an error for that file
-        abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)
+        let abs_fp = toAbsolute dir (fromNormalizedFilePath cfp)
         let special_target = Compat.mkSimpleTarget df abs_fp
         pure $ (df, special_target : targets) :| []
     where

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

@@ -159,8 +159,7 @@ import           Language.LSP.Server                          (LspT)
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.VFS
 import           Prelude                                      hiding (mod)
-import           System.Directory                             (doesFileExist,
-                                                               makeAbsolute)
+import           System.Directory                             (doesFileExist)
 import           System.Info.Extra                            (isWindows)
 
 
@@ -719,8 +718,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do
         -- add the deps to the Shake graph
         let addDependency fp = do
                 -- VSCode uses absolute paths in its filewatch notifications
-                afp <- liftIO $ makeAbsolute fp
-                let nfp = toNormalizedFilePath' afp
+                let nfp = toNormalizedFilePath' fp
                 itExists <- getFileExists nfp
                 when itExists $ void $ do
                   use_ GetModificationTime nfp
@@ -848,7 +846,7 @@ getModIfaceFromDiskAndIndexRule recorder =
       hie_loc = Compat.ml_hie_file $ ms_location ms
   fileHash <- liftIO $ Util.getFileHash hie_loc
   mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))
-  hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
+  let hie_loc' = HieDb.hieModuleHieFile <$> mrow
   case mrow of
     Just row
       | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row)

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

@@ -67,8 +67,9 @@ initialise :: Recorder (WithPriority Log)
            -> WithHieDb
            -> IndexQueue
            -> Monitoring
+           -> FilePath
            -> IO IdeState
-initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do
+initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -86,11 +87,12 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
         hiedbChan
         (optShakeOptions options)
         metrics
-          $ do
+        (do
             addIdeGlobal $ GlobalIdeOptions options
             ofInterestRules (cmapWithPrio LogOfInterest recorder)
             fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv
-            mainRule
+            mainRule)
+        rootDir
 
 -- | Shutdown the Compiler Service.
 shutdown :: IdeState -> IO ()

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

@@ -535,6 +535,7 @@ data IdeState = IdeState
     ,shakeExtras          :: ShakeExtras
     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
     ,stopMonitoring       :: IO ()
+    ,rootDir              :: FilePath
     }
 
 
@@ -623,11 +624,12 @@ shakeOpen :: Recorder (WithPriority Log)
           -> ShakeOptions
           -> Monitoring
           -> Rules ()
+          -> FilePath
           -> IO IdeState
 shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
   shakeProfileDir (IdeReportProgress reportProgress)
   ideTesting@(IdeTesting testing)
-  withHieDb indexQueue opts monitoring rules = mdo
+  withHieDb indexQueue opts monitoring rules rootDir = mdo
 
 #if MIN_VERSION_ghc(9,3,0)
     ideNc <- initNameCache 'r' knownKeyNames

ghcide/src/Development/IDE/Main.hs

@@ -353,6 +353,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                       withHieDb
                       hieChan
                       monitoring
+                      rootPath
                   putMVar ideStateVar ide
                   pure ide
 
@@ -404,7 +405,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                         , optCheckProject = pure False
                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                         }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
 
@@ -442,7 +443,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                     , optCheckProject = pure False
                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                     }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
             c ide

ghcide/src/Development/IDE/Types/HscEnvEq.hs

@@ -29,7 +29,6 @@ import           Development.IDE.GHC.Util        (lookupPackageConfig)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap)
 import           OpenTelemetry.Eventlog          (withSpan)
-import           System.Directory                (makeAbsolute)
 import           System.FilePath
 
 -- | An 'HscEnv' with equality. Two values are considered equal
@@ -58,15 +57,19 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do
   let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv }
   update <$> Unique.newUnique
 
+toAbsolute :: FilePath -> FilePath -> FilePath
+toAbsolute root path
+    | isAbsolute path = path
+    | otherwise = root </> path
 -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
-newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEq cradlePath hscEnv0 deps = do
+newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
+newHscEnvEq root cradlePath hscEnv0 deps = do
     let relativeToCradle = (takeDirectory cradlePath </>)
         hscEnv = removeImportPaths hscEnv0
 
     -- Make Absolute since targets are also absolute
     importPathsCanon <-
-      mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
+      mapM (return . toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
 
     newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
 

plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs

@@ -58,7 +58,6 @@ import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import           Language.LSP.Server
 import           Language.LSP.VFS                     (virtualFileText)
-import           System.Directory                     (makeAbsolute)
 import           System.FilePath                      (dropExtension, normalise,
                                                        pathSeparator,
                                                        splitDirectories,
@@ -133,6 +132,10 @@ action recorder state uri = do
             in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code]
       _ -> pure []
 
+toAbsolute :: FilePath -> FilePath -> FilePath
+toAbsolute root path
+    | isAbsolute path = path
+    | otherwise = root </> path
 -- | Possible module names, as derived by the position of the module in the
 -- source directories.  There may be more than one possible name, if the source
 -- directories are nested inside each other.
@@ -150,7 +153,7 @@ pathModuleNames recorder state normFilePath filePath
       let paths = map (normalise . (<> pure pathSeparator)) srcPaths
       logWith recorder Debug (NormalisedPaths paths)
 
-      mdlPath <- liftIO $ makeAbsolute filePath
+      mdlPath <- liftIO $ (toAbsolute $ rootDir state) filePath
       logWith recorder Debug (AbsoluteFilePath mdlPath)
 
       let suffixes = mapMaybe (`stripPrefix` mdlPath) paths

plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs

@@ -129,7 +129,6 @@ import           Retrie.SYB                           (everything, extQ,
                                                        listify, mkQ)
 import           Retrie.Types
 import           Retrie.Universe                      (Universe)
-import           System.Directory                     (makeAbsolute)
 
 #if MIN_VERSION_ghc(9,3,0)
 import           GHC.Types.PkgQual
@@ -760,9 +759,14 @@ reuseParsedModule state f = do
         (fixities, pm') <- fixFixities state f (fixAnns pm)
         return (fixities, pm')
 
+toAbsolute :: FilePath -> FilePath -> FilePath
+toAbsolute dir file
+    | isAbsolute file = file
+    | otherwise = dir </> file
+
 getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule)
 getCPPmodule recorder state session t = do
-    nt <- toNormalizedFilePath' <$> makeAbsolute t
+    nt <- toNormalizedFilePath' <$> (toAbsolute $ rootDir state) t
     let getParsedModule f contents = do
           modSummary <- msrModSummary <$>
             useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt