fix: remove the unsafePerformIO and head usage

The cache is now stored inside the `ShakeExtra`. I'm unsure that's the right location for it. This should fix hlint. Also, not having a cache stored as top level entry may makes it not survive session reinit, which seams sane (for example, during tests). Still 3 `-boot` related tests are failing. 2 are however flaky.

Author: guibou

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

@@ -178,10 +178,9 @@ import System.Info.Extra (isWindows)
 importqualifiedData.IntMapasIM
 importGHC.Fingerprint
 importqualifiedData.Map.StrictasMap
-importSystem.FilePath (takeExtension, takeFileName, normalise, dropTrailingPathSeparator, dropExtension, splitDirectories)
+importSystem.FilePath (takeExtension, takeFileName, normalise, dropExtension, splitDirectories)
 importData.Char (isUpper)
 importSystem.Directory.Extra (listFilesInside)
-importSystem.IO.Unsafe
 
 dataLog
 =LogShakeShake.Log
@@ -625,15 +624,13 @@ getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake rec
  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
  dependencyInfoForFiles (HashSet.toList fs)
 
-{-# NOINLINE cacheVar #-}
--- TODO: this should not use unsaferPerformIO
-cacheVar = unsafePerformIO (newTVarIO mempty)
-
 getModulesPathsRule::Recorder (WithPriorityLog) ->Rules()
 getModulesPathsRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $Rule$\GetModulesPaths file ->do
  env_eq <- use_ GhcSession file
 
- cache <- liftIO (readTVarIO cacheVar)
+ShakeExtras{moduleToPathCache} <- getShakeExtras
+
+ cache <- liftIO (readTVarIO moduleToPathCache)
 caseMap.lookup (envUnique env_eq) cache of
 Just res ->pure (mempty, ([], Just res))
 Nothing->do
@@ -646,7 +643,9 @@ getModulesPathsRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder
  (unzip-> (a, b)) <-flipmapM import_dirs $\(u, dyn) ->do
  (unzip-> (a, b)) <-flipmapM (importPaths dyn) $\dir' ->do
 let dir = normalise dir'
-let predicate path =pure (normalise path == dir || isUpper (head (takeFileName path)))
+let predicate path =pure (normalise path == dir ||case takeFileName path of
+[]->False
+ (x:_) -> isUpper x)
 let dir_number_directories =length (splitDirectories dir)
 let toModule file = mkModuleName (intercalate "."$drop dir_number_directories (splitDirectories (dropExtension file)))
 
@@ -662,7 +661,7 @@ getModulesPathsRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder
 pure (fmap (u,) $mconcat a, fmap (u, ) $mconcat b)
 
 let res = (mconcat a, mconcat b)
- liftIO $ atomically $ modifyTVar' cacheVar (Map.insert (envUnique env_eq) res)
+ liftIO $ atomically $ modifyTVar' moduleToPathCache (Map.insert (envUnique env_eq) res)
 
 pure (mempty, ([], Just res))
 

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

@@ -135,7 +135,7 @@ import Development.IDE.Core.WorkerThread
 importDevelopment.IDE.GHC.Compat (NameCache,
 NameCacheUpdater,
 initNameCache,
-knownKeyNames)
+knownKeyNames, ModuleName, UnitId)
 importDevelopment.IDE.GHC.Orphans ()
 importDevelopment.IDE.Graphhiding (ShakeValue,
 action)
@@ -178,6 +178,7 @@ import System.FilePath hiding (makeRelative)
 importSystem.IO.Unsafe (unsafePerformIO)
 importSystem.Time.Extra
 importUnliftIO (MonadUnliftIO (withRunInIO))
+importData.Map.Strict (Map)
 
 
 dataLog
@@ -310,6 +311,10 @@ data ShakeExtras = ShakeExtras
  ,ideNc::NameCache
 --| A mapping of module name to known target (or candidate targets, if missing)
  ,knownTargetsVar::TVar (HashedKnownTargets)
+ ,moduleToPathCache::TVar (Map
+Unique
+ (MapModuleName (UnitId, NormalizedFilePath),
+MapModuleName (UnitId, NormalizedFilePath)))
 --| A mapping of exported identifiers for local modules. Updated on kick
  ,exportsMap::TVarExportsMap
 --| A work queue for actions added via 'runInShakeSession'
@@ -704,6 +709,8 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
  dirtyKeys <- newTVarIO mempty
 -- Take one VFS snapshot at the start
  vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
+
+ moduleToPathCache <- newTVarIO mempty
 pureShakeExtras{shakeRecorder = recorder, ..}
  shakeDb <-
  shakeNewDatabase
@@ -1481,3 +1488,5 @@ runWithSignal msgStart msgEnd files rule = do
  kickSignal testing lspEnv files msgStart
  void $ uses rule files
  kickSignal testing lspEnv files msgEnd
+
+