* I updated the function so it now also returns the generated inside the monadic tuple (earlier, it was only returning the flags and the target).

* To thread this down, I added a new  field (as a ) to the  data type. This passes the hash from  straight into .
* Inside , I added a check:
  * If we have , I set the prefix to 'main'. Then, I initiate a new hash and update it with  using , storing this mutated context as .
  * If it's ,  just gets a standard .
* Finally, to build , it takes that  and updates it with the  string (converted via ). This gives out the final 40-character hex string for the SHA1 hash.
* (Also updated  in the session loading to accept the ByteString).

This keeps the path short and stops Windows from crashing

Author: adpad-13

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

@@ -43,6 +43,7 @@ import qualified Data.List.NonEmpty                  as NE
 import qualified Data.Map.Strict                     as Map
 import           Data.Maybe
 import           Data.Proxy
+
 import qualified Data.Text                           as T
 import           Data.Time.Clock
 import           Data.Version
@@ -238,7 +239,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)
   }
@@ -512,7 +513,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                   -- 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) newTargetDfs
+                  new_deps = fmap (\(df, targets,mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newTargetDfs
                   all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps
                   -- Get all the unit-ids for things in this component
                   _inplace = map rawComponentUnitId $ NE.toList all_deps
@@ -521,7 +522,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = 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
@@ -1026,6 +1027,9 @@ 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
+  -- | The initial hash generated for a unit id , if UnitId is "main" then Just B.ByteString else Nothing
+  , rawComponentHash :: Maybe B.ByteString
+  
   }
 
 -- This is processed information about the component, in particular the dynflags will be modified.
@@ -1121,13 +1125,13 @@ setOptions :: GhcMonad m
     -> ComponentOptions
     -> DynFlags
     -> FilePath -- ^ root dir, see Note [Root Directory]
-    -> m (NonEmpty (DynFlags, [GHC.Target]))
+    -> m (NonEmpty (DynFlags, [GHC.Target],Maybe B.ByteString))
 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')
+        (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.
@@ -1147,7 +1151,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 $ (df, special_target : targets,mHash) :| []
     where
       initMulti unitArgFiles =
         forM unitArgFiles $ \f -> do
@@ -1158,7 +1162,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
@@ -1167,10 +1171,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
@@ -1191,7 +1196,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir =
               Compat.setUpTypedHoles $
               makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
               dflags''
-        return (dflags''', targets)
+        return (dflags''', targets,mHash)
 
 setIgnoreInterfacePragmas :: DynFlags -> DynFlags
 setIgnoreInterfacePragmas df =
@@ -1218,14 +1223,22 @@ setODir f d =
     -- override user settings to avoid conflicts leading to recompilation
     d { objectDir = Just f}
 
-getCacheDirsDefault :: String -> [String] -> IO CacheDirs
-getCacheDirsDefault prefix opts = do
-    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
+      
+    
+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
+
+        prefix' = if isJust mFirstHash then "main" else prefix
+        basectx = case mFirstHash of
+          Just h  -> H.updates H.init [h]
+          Nothing -> H.init
         -- 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)
+        --
+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts)
 
 -- | Sub directory for the cache path
 cacheDir :: String