batch load

Author: soulomoon

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

@@ -479,7 +479,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
         -- files in the project so that `knownFiles` can learn about them and
         -- we can generate a complete module graph
     let extendKnownTargets newTargets = do
-          knownTargets <- concatForM  newTargets $ \TargetDetails{..} ->
+          knownTargets <- concatForM newTargets $ \TargetDetails{..} ->
             case targetTarget of
               TargetFile f -> do
                 -- If a target file has multiple possible locations, then we
@@ -563,9 +563,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
               let (new,old) = NE.splitAt (NE.length new_deps) all_deps'
               pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old))
 
+    let restartSession all_targets new_deps = do
+          restartShakeSession VFSUnmodified "new component" [] $ do
+            keys2 <- invalidateShakeCache
+            keys1 <- extendKnownTargets all_targets
+            return [keys1, keys2]
+
+          -- Typecheck all files in the project on startup
+          checkProject <- getCheckProject
+          unless (null new_deps || not checkProject) $ do
+                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
+                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
+                    mmt <- uses GetModificationTime cfps'
+                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+                    modIfaces <- uses GetModIface cs_exist
+                    -- update exports map
+                    shakeExtras <- getShakeExtras
+                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
+                    liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
 
     let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-                -> IO (IdeResult HscEnvEq,[FilePath])
+                -> IO ((IdeResult HscEnvEq,[FilePath]), ([TargetDetails], [ComponentInfo]))
         session args@(hieYaml, _cfp, _opts, _libDir) = do
           (new_deps, old_deps) <- packageSetup args
 
@@ -576,14 +594,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
           hscEnv <- emptyHscEnv ideNc _libDir
           let new_cache = newComponentCache recorder optExtensions _cfp hscEnv
           all_target_details <- new_cache old_deps new_deps
-
+          let all_targets' = concat all_target_details
+              flags_map' = HM.fromList (concatMap toFlagsMap all_targets')
           this_dep_info <- getDependencyInfo $ maybeToList hieYaml
+
           let (all_targets, this_flags_map, this_options)
                 = case HM.lookup _cfp flags_map' of
                     Just this -> (all_targets', flags_map', this)
                     Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags)
-                  where all_targets' = concat all_target_details
-                        flags_map' = HM.fromList (concatMap toFlagsMap all_targets')
+                  where
                         this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]
                         this_flags = (this_error_env, this_dep_info)
                         this_error_env = ([this_error], Nothing)
@@ -598,25 +617,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
           -- The VFS doesn't change on cradle edits, re-use the old one.
           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
           -- todo result only when batch cradle loading is done
-          keys2 <- invalidateShakeCache
-          restartShakeSession VFSUnmodified "new component" [] $ do
-            keys1 <- extendKnownTargets all_targets
-            return [keys1, keys2]
-
-          -- Typecheck all files in the project on startup
-          checkProject <- getCheckProject
-          unless (null new_deps || not checkProject) $ do
-                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
-                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-                    mmt <- uses GetModificationTime cfps'
-                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
-                    modIfaces <- uses GetModIface cs_exist
-                    -- update exports map
-                    shakeExtras <- getShakeExtras
-                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
-                    liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
-
-          return $ second Map.keys this_options
+        --   restartSession all_targets new_deps
+          return $ (second Map.keys this_options, (all_targets, new_deps))
 
     let eoptsHscEnv (hieYaml, cfp, cradle, eopts) =
            case eopts of
@@ -629,8 +631,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                  ((runTime, _):_)
                    | compileTime == runTime -> do
                      atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
-                     session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
-                   | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
+                     fmap (fmap Just) $ session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
+                   | otherwise -> return ((([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]), Nothing)
              -- Failure case, either a cradle error or the none cradle
              Left err -> do
                dep_info <- getDependencyInfo (maybeToList hieYaml)
@@ -639,10 +641,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                void $ modifyVar' fileToFlags $
                     Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))
                void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
-               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
+               return ((res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err), Nothing)
 
-    let consultCradles :: [(Maybe FilePath, FilePath)] -> IO [(IdeResult HscEnvEq, [FilePath])]
-        consultCradles hyCfpList = do
+    let
+      consultCradles [] = return []
+      consultCradles hyCfpList = do
             let cfps = map snd hyCfpList
             let lfpLogs = map (makeRelative rootDir . snd) hyCfpList
             logWith recorder Info $ LogCradlePaths lfpLogs
@@ -656,7 +659,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                    return res
             mapM eoptsHscEnv (zipWith (\((hieYaml, fp), cr) eopts -> (hieYaml, fp, cr, eopts) ) (zip hyCfpList cradles) eoptsList)
 
-    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+    let
+        -- consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         consultCradle hieYaml cfp = do
            let lfpLog = makeRelative rootDir cfp
            logWith recorder Info $ LogCradlePath lfpLog
@@ -697,7 +701,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
 
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]
     -- Returns the Ghc session and the cradle dependencies
-    let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
+    let
+        -- sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
         sessionOpts (hieYaml, file) = do
           Extra.whenM didSessionLoadingPreferenceConfigChange $ do
             logWith recorder Info LogSessionLoadingChanged
@@ -722,7 +727,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                   -- Keep the same name cache
                   modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )
                   consultCradle hieYaml cfp
-                else return (opts, Map.keys old_di)
+                else return ((opts, Map.keys old_di), Nothing)
             Nothing -> consultCradle hieYaml cfp
 
     let readSessionOptsFromCache (hieYaml, file) = do
@@ -748,7 +753,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
             cached <- mapM readSessionOptsFromCache yamlFiles
             let (toConsults, cachedResults) = partitionEithers cached
             results <- consultCradles toConsults
-            let consultMap = Map.fromList $ zip (map snd toConsults) results
+            let envs = map fst results
+            let mergeDeps (x, y) (a, b) = (x <> a, y <> b)
+            let (tgs, deps) = foldr mergeDeps ([], []) $ mapMaybe snd results
+            Extra.whenM (return $ notNull toConsults) (restartSession tgs deps)
+            let consultMap = Map.fromList $ zip (map snd toConsults) envs
             let cachedMap = Map.fromList cachedResults
             return $ consultMap <> cachedMap
 
@@ -767,13 +776,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
     -- at a time. Therefore the IORef contains the currently running cradle, if we try
     -- to get some more options then we wait for the currently running action to finish
     -- before attempting to do so.
-    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-        getOptions file = do
-            let ncfp = toNormalizedFilePath' (toAbsolutePath file)
-            cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap
-            hieYaml <- cradleLoc file
-            sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
-                return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
+    -- let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+    --     getOptions file = do
+    --         let ncfp = toNormalizedFilePath' (toAbsolutePath file)
+    --         cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap
+    --         hieYaml <- cradleLoc file
+    --         sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
+    --             return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
 
     let getOptionsBatch :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         getOptionsBatch file' = do
@@ -799,9 +808,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
 -- how we do batch loading of cradles depends on the the type of cradle we are using
 cradleToOptsAndLibDirs :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> [(Cradle Void, FilePath)] -> [FilePath]
                       -> IO [Either [CradleError] (ComponentOptions, FilePath, String)]
-cradleToOptsAndLibDirs recorder loadConfig cradleFiles old_fps = do
+cradleToOptsAndLibDirs recorder loadConfig [] old_fps = error "cradleToOptsAndLibDirs: empty list of cradles"
+cradleToOptsAndLibDirs recorder loadConfig cradleFiles@(cr:crs) old_fps = do
     -- let result :: [([FilePath], CradleLoadResult ComponentOptions)]
-    results <- HieBios.getCompilerOptionsInBatch (LoadWithContext old_fps) cradleFiles
+    results <- HieBios.getCompilerOptionsInBatch (LoadWithContext old_fps) (cr :| crs)
     let resultMap :: Map.Map FilePath (CradleLoadResult ComponentOptions)
         resultMap = Map.fromList $ [ (fp, r) | (fps, r) <- results, fp <- fps ]
     mapM (\(cr, fp) -> collectBiosResult recorder cr fp (resultMap Map.! fp)) cradleFiles