From dde5f2220e6b02a06ff342637467db74eddb644e Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Thu, 11 Feb 2021 20:53:57 +0000
Subject: [PATCH 1/2] Fix package exports hack

---
 .../src/Development/IDE/Plugin/CodeAction.hs  |  4 +--
 ghcide/src/Development/IDE/Types/HscEnvEq.hs  | 29 +++++++++++++++----
 2 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index c5f0ae6067..3d7160eebd 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -86,10 +86,10 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di
             <*> use GhcSession `traverse` mbFile
             <*> use GetAnnotatedParsedSource `traverse` mbFile
     -- This is quite expensive 0.6-0.7s on GHC
-    let pkgExports = envPackageExports <$> env
+    pkgExports   <- fromMaybe mempty (envPackageExports <$> env)
     localExports <- readVar (exportsMap $ shakeExtras state)
     let
-      exportsMap = localExports <> fromMaybe mempty pkgExports
+      exportsMap = localExports <> pkgExports
       df = ms_hspp_opts . pm_mod_summary <$> parsedModule
       actions =
         [ mkCA title  [x] edit
diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs
index 7495864bb6..92fa959a4a 100644
--- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs
+++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs
@@ -24,8 +24,10 @@ import TcRnMonad (initIfaceLoad, WhereFrom (ImportByUser))
 import LoadIface (loadInterface)
 import qualified Maybes
 import OpenTelemetry.Eventlog (withSpan)
-import System.IO.Unsafe (unsafePerformIO)
-import Control.Monad.Extra (mapMaybeM)
+import Control.Monad.Extra (mapMaybeM, join)
+import Control.Concurrent.Extra (newVar, modifyVar)
+import Control.Concurrent.Async (Async, async, waitCatch)
+import Control.Exception (throwIO, mask)
 
 -- | An 'HscEnv' with equality. Two values are considered equal
 --   if they are created with the same call to 'newHscEnvEq'.
@@ -39,7 +41,7 @@ data HscEnvEq = HscEnvEq
     , envImportPaths :: Maybe [String]
         -- ^ If Just, import dirs originally configured in this env
         --   If Nothing, the env import dirs are unaltered
-    , envPackageExports :: ExportsMap
+    , envPackageExports :: IO ExportsMap
     }
 
 -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
@@ -58,9 +60,8 @@ newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, Dyn
 newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
     envUnique <- newUnique
 
-    let
-    -- evaluate lazily, using unsafePerformIO for a pure API
-      envPackageExports = unsafePerformIO $ withSpan "Package Exports" $ \_sp -> do
+    -- it's very important to delay the package exports computation
+    envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do
         -- compute the package imports
         let pkgst   = pkgState (hsc_dflags hscEnv)
             depends = explicitPackages pkgst
@@ -119,3 +120,19 @@ instance Hashable HscEnvEq where
 instance Binary HscEnvEq where
   put _ = error "not really"
   get = error "not really"
+
+-- | Given an action, produce a wrapped action that runs at most once.
+--   The action is run in an async so it won't be killed by async exceptions
+--   If the function raises an exception, the same exception will be reraised each time.
+onceAsync :: IO a -> IO (IO a)
+onceAsync act = do
+    var <- newVar OncePending
+    let run as = either throwIO pure =<< waitCatch as
+    pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of
+        OnceRunning x -> pure (v, unmask $ run x)
+        OncePending -> do
+            x <- async (unmask act)
+            pure (OnceRunning x, unmask $ run x)
+
+data Once a = OncePending | OnceRunning (Async a)
+

From 048fe5dba36f0e3b9eb09099d10a1f4b3f305d54 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Thu, 11 Feb 2021 21:02:25 +0000
Subject: [PATCH 2/2] hlint

---
 ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 +-
 ghcide/src/Development/IDE/Types/HscEnvEq.hs    | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 3d7160eebd..21c1f716d2 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -86,7 +86,7 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di
             <*> use GhcSession `traverse` mbFile
             <*> use GetAnnotatedParsedSource `traverse` mbFile
     -- This is quite expensive 0.6-0.7s on GHC
-    pkgExports   <- fromMaybe mempty (envPackageExports <$> env)
+    pkgExports   <- maybe mempty envPackageExports env
     localExports <- readVar (exportsMap $ shakeExtras state)
     let
       exportsMap = localExports <> pkgExports
diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs
index 92fa959a4a..fdf29426a5 100644
--- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs
+++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs
@@ -24,7 +24,7 @@ import TcRnMonad (initIfaceLoad, WhereFrom (ImportByUser))
 import LoadIface (loadInterface)
 import qualified Maybes
 import OpenTelemetry.Eventlog (withSpan)
-import Control.Monad.Extra (mapMaybeM, join)
+import Control.Monad.Extra (mapMaybeM, join, eitherM)
 import Control.Concurrent.Extra (newVar, modifyVar)
 import Control.Concurrent.Async (Async, async, waitCatch)
 import Control.Exception (throwIO, mask)
@@ -127,7 +127,7 @@ instance Binary HscEnvEq where
 onceAsync :: IO a -> IO (IO a)
 onceAsync act = do
     var <- newVar OncePending
-    let run as = either throwIO pure =<< waitCatch as
+    let run as = eitherM throwIO pure (waitCatch as)
     pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of
         OnceRunning x -> pure (v, unmask $ run x)
         OncePending -> do