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)
 import qualified Data.IntMap                                  as IM
 import           GHC.Fingerprint
 import qualified Data.Map.Strict as Map
-import System.FilePath (takeExtension, takeFileName, normalise, dropTrailingPathSeparator, dropExtension, splitDirectories)
+import System.FilePath (takeExtension, takeFileName, normalise, dropExtension, splitDirectories)
 import Data.Char (isUpper)
 import System.Directory.Extra (listFilesInside)
-import System.IO.Unsafe
 
 data Log
   = LogShake Shake.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 (WithPriority Log) -> 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)
   case Map.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)) <- flip mapM import_dirs $ \(u, dyn) -> do
         (unzip -> (a, b)) <- flip mapM (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
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          NameCacheUpdater,
                                                          initNameCache,
-                                                         knownKeyNames)
+                                                         knownKeyNames, ModuleName, UnitId)
 import           Development.IDE.GHC.Orphans            ()
 import           Development.IDE.Graph                  hiding (ShakeValue,
                                                          action)
@@ -178,6 +178,7 @@ import           System.FilePath                        hiding (makeRelative)
 import           System.IO.Unsafe                       (unsafePerformIO)
 import           System.Time.Extra
 import           UnliftIO                               (MonadUnliftIO (withRunInIO))
+import Data.Map.Strict (Map)
 
 
 data Log
@@ -310,6 +311,10 @@ data ShakeExtras = ShakeExtras
     ,ideNc :: NameCache
     -- | A mapping of module name to known target (or candidate targets, if missing)
     ,knownTargetsVar :: TVar (Hashed KnownTargets)
+    ,moduleToPathCache :: TVar (Map
+     Unique
+     (Map ModuleName (UnitId, NormalizedFilePath),
+      Map ModuleName (UnitId, NormalizedFilePath)))
     -- | A mapping of exported identifiers for local modules. Updated on kick
     ,exportsMap :: TVar ExportsMap
     -- | 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
         pure ShakeExtras{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
+
+