Fixes redundant hash in ghcide cache path (getCacheDirsDefault) (#4854)

Author: adpad-13

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

@@ -223,7 +223,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   -- | Given the project name and a set of command line flags,
   --   return the path for storing generated GHC artifacts,
   --   or 'Nothing' to respect the cradle setting
-  , getCacheDirs           :: String -> [String] -> IO CacheDirs
+  , getCacheDirs           :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
   , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)
   }

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

@@ -58,6 +58,7 @@ import           GHC.Types.Error                    (errMsgDiagnostic,
                                                      singleMessage)
 import           GHC.Unit.State
 
+
 #if MIN_VERSION_ghc(9,13,0)
 import           GHC.Driver.Make                    (checkHomeUnitsClosed)
 #endif
@@ -79,7 +80,18 @@ instance Pretty Log where
       "New component cache HscEnvEq:" <+> viaShow componentCache
     LogDLLLoadError errorString ->
       "Error dynamically loading libm.so.6:" <+> pretty errorString
-
+-- | Configuration info for a particular home unit.
+data HomeUnitConfig = HomeUnitConfig
+  {
+  -- | The dynamic flags to compile this specific unit.
+    homeUnitDynFlags :: DynFlags
+  -- | All the targets for this unit.
+  , homeUnitTargets  :: [GHC.Target]
+  -- | Optional hash seed to differentiate home units
+  -- with same `-this-unit-id`. Used when `-this-unit-id` is "main",
+  -- which is common when loading a single target.
+  , homeUnitHash     :: Maybe B.ByteString
+  }
 -- This is pristine information about a component
 data RawComponentInfo = RawComponentInfo
   { rawComponentUnitId         :: UnitId
@@ -95,6 +107,8 @@ data RawComponentInfo = RawComponentInfo
   -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
   -- to last modification time. See Note [Multi Cradle Dependency Info].
   , rawComponentDependencyInfo :: DependencyInfo
+  -- | An optional hash seed generated in 'setOptions' for the unit id "main".
+  , rawComponentHash           :: Maybe B.ByteString
   }
 
 -- This is processed information about the component, in particular the dynflags will be modified.
@@ -209,13 +223,13 @@ setOptions :: GhcMonad m
     -> ComponentOptions
     -> DynFlags
     -> FilePath -- ^ root dir, see Note [Root Directory]
-    -> m (NonEmpty (DynFlags, [GHC.Target]))
+    -> m (NonEmpty HomeUnitConfig)
 setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do
     ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)
     case NE.nonEmpty units of
       Just us -> initMulti us
       Nothing -> do
-        (df, targets) <- initOne (map unLoc theOpts')
+        (HomeUnitConfig df targets mHash) <- initOne (map unLoc theOpts')
         -- A special target for the file which caused this wonderful
         -- component to be created. In case the cradle doesn't list all the targets for
         -- the component, in which case things will be horribly broken anyway.
@@ -235,7 +249,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir =
         -- we will report it as an error for that file
         let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp)
         let special_target = Compat.mkSimpleTarget df abs_fp
-        pure $ (df, special_target : targets) :| []
+        pure $ HomeUnitConfig df (special_target : targets) mHash :| []
     where
       initMulti unitArgFiles =
         forM unitArgFiles $ \f -> do
@@ -246,7 +260,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir =
           initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args
       initOne this_opts = do
         (dflags', targets') <- addCmdOpts this_opts dflags
-        let dflags'' =
+        let (dflags'',mHash) =
                 case unitIdString (homeUnitId_ dflags') of
                      -- cabal uses main for the unit id of all executable packages
                      -- This makes multi-component sessions confused about what
@@ -255,10 +269,11 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir =
                      -- This works because there won't be any dependencies on the
                      -- executable unit.
                      "main" ->
-                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts)
+                       let hashBytes =H.finalize $ H.updates H.init (map B.pack this_opts)
+                           hash =  B.unpack $ B16.encode hashBytes
                            hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))
-                       in setHomeUnitId_ hashed_uid dflags'
-                     _ -> dflags'
+                       in (setHomeUnitId_ hashed_uid dflags', Just hashBytes)
+                     _ -> (dflags', Nothing)
 
         let targets = makeTargetsAbsolute root targets'
             root = case workingDirectory dflags'' of
@@ -279,14 +294,14 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir =
               Compat.setUpTypedHoles $
               makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
               dflags''
-        return (dflags''', targets)
+        return (HomeUnitConfig dflags''' targets mHash)
 
 addComponentInfo ::
   MonadUnliftIO m =>
   Recorder (WithPriority Log) ->
-  (String -> [String] -> IO CacheDirs) ->
+  (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) ->
   DependencyInfo ->
-  NonEmpty (DynFlags, [GHC.Target]) ->
+  NonEmpty HomeUnitConfig->
   (Maybe FilePath, NormalizedFilePath, ComponentOptions) ->
   Map.Map (Maybe FilePath) [RawComponentInfo] ->
   m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo]))
@@ -298,15 +313,15 @@ addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts)
       -- We will modify the unitId and DynFlags used for
       -- compilation but these are the true source of
       -- information.
-      new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags
+      new_deps = fmap (\(HomeUnitConfig df targets mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newDynFlags
       all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps
       -- Get all the unit-ids for things in this component
 
   all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do
     let prefix = show rawComponentUnitId
     -- See Note [Avoiding bad interface files]
     let cacheDirOpts = componentOptions opts
-    cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts
+    cacheDirs <- liftIO $ getCacheDirs prefix rawComponentHash cacheDirOpts
     processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags
     -- The final component information, mostly the same but the DynFlags don't
     -- contain any packages which are also loaded
@@ -422,14 +437,28 @@ setCacheDirs recorder CacheDirs{..} dflags = do
           & maybe id setHieDir hieCacheDir
           & maybe id setODir oCacheDir
 
-getCacheDirsDefault :: String -> [String] -> IO CacheDirs
-getCacheDirsDefault prefix opts = do
-    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
+-- | Append the hash to the unit id to create unique cache folders.
+--
+-- This function generates a single, unified hash.
+-- If an optional base hash (@mFirstHash@) is provided—which
+-- is common for a single target with `-this-unit-id` as "main"-
+-- we set the prefix to "main", extract the context generated
+-- from the @mFirstHash@, and update the @opts@ into the same hash.
+--
+-- This guarantees a unique cache folder for different GHC
+-- options(avoiding incompatible interface files) while
+-- keeping the path short and clean.
+getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs
+getCacheDirsDefault prefix mFirstHash opts = do
+    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix' ++ "-" ++ opts_hash)
     return $ CacheDirs dir dir dir
     where
-        -- Create a unique folder per set of different GHC options, assuming that each different set of
-        -- GHC options will create incompatible interface files.
-        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)
+        -- Create a unique folder per set of different GHC options.
+        prefix' = if isJust mFirstHash then "main" else prefix
+        basectx = case mFirstHash of
+          Just h  -> H.updates H.init [h]
+          Nothing -> H.init
+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts)
 
 setNameCache :: NameCache -> HscEnv -> HscEnv
 setNameCache nc hsc = hsc { hsc_NC = nc }