Merge remote-tracking branch 'oa/load-modules-concurrently'

Author: purefunctor

src/Language/PureScript/Ide.hs

@@ -20,6 +20,7 @@ module Language.PureScript.Ide
 
 import Protolude hiding (moduleName)
 
+import Control.Concurrent.Async.Lifted (mapConcurrently_)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -231,15 +232,15 @@ loadModules moduleNames = do
     efPaths =
         map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) efModules
   efiles <- traverse readExternFile efPaths
-  traverse_ insertExterns efiles
+  mapConcurrently_ insertExterns efiles
 
   -- We parse all source files, log eventual parse failures and insert the
   -- successful parses into the state.
   (failures, allModules) <-
     partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles)
   unless (null failures) $
     logWarnN ("Failed to parse: " <> show failures)
-  traverse_ insertModule allModules
+  mapConcurrently_ insertModule allModules
 
   pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
                     <> show (length allModules) <> " source files."))

src/Language/PureScript/Ide/SourceFile.hs

@@ -22,6 +22,8 @@ module Language.PureScript.Ide.SourceFile
 
 import Protolude
 
+import Control.Concurrent.Async.Lifted (mapConcurrently)
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Parallel.Strategies (withStrategy, parList, rseq)
 import Data.Map qualified as Map
 import Language.PureScript qualified as P
@@ -37,11 +39,11 @@ parseModule path file =
     Right m -> Right (path, m)
 
 parseModulesFromFiles
-  :: (MonadIO m, MonadError IdeError m)
+  :: (MonadIO m, MonadBaseControl IO m, MonadError IdeError m)
   => [FilePath]
   -> m [Either FilePath (FilePath, P.Module)]
 parseModulesFromFiles paths = do
-  files <- traverse ideReadFile paths
+  files <- mapConcurrently ideReadFile paths
   pure (inParallel (map (uncurry parseModule) files))
   where
     inParallel :: [Either e (k, a)] -> [Either e (k, a)]

src/Language/PureScript/Ide/Types.hs

@@ -10,6 +10,7 @@ import Protolude hiding (moduleName)
 import Control.Concurrent.STM (TVar)
 import Control.Lens (Getting, Traversal', makeLenses)
 import Control.Monad.Fail (fail)
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson (ToJSON, FromJSON, (.=))
 import Data.Aeson qualified as Aeson
 import Data.IORef (IORef)
@@ -174,7 +175,7 @@ data IdeEnvironment =
   , ideCacheDbTimestamp :: IORef (Maybe UTCTime)
   }
 
-type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
+type Ide m = (MonadIO m, MonadBaseControl IO m, MonadReader IdeEnvironment m)
 
 data IdeState = IdeState
   { ideFileState :: IdeFileState