Explicitly model more dependencies on cradle startup

hie-bios.cabal

@@ -170,6 +170,7 @@ Library
   Build-Depends:
                         base                 >= 4.16 && < 5,
                         aeson                >= 1.4.4 && < 2.3,
+                        async                >= 2.1 && <2.3,
                         base16-bytestring    >= 0.1.1 && < 1.1,
                         bytestring           >= 0.10.8 && < 0.13,
                         co-log-core          ^>= 0.3.0,
@@ -199,7 +200,7 @@ Executable hie-bios
   Main-Is:              Main.hs
   Other-Modules:        Paths_hie_bios
   autogen-modules:      Paths_hie_bios
-  GHC-Options:          -Wall
+  GHC-Options:          -threaded -Wall
   HS-Source-Dirs:       exe
   Build-Depends:        base >= 4.16 && < 5
                       , co-log-core

src/HIE/Bios/Cradle.hs

@@ -1,10 +1,9 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecursiveDo #-}
-{-# LANGUAGE RecordWildCards #-}
 module HIE.Bios.Cradle (
       findCradle
     , loadCradle
@@ -28,11 +27,13 @@
 
     -- expose to tests
     , makeVersions
+    , getGhcVersion
     , isCabalMultipleCompSupported
-    , ProgramVersions
+    , BuildToolVersions
   ) where
 
 import Control.Applicative ((<|>), optional)
+import Control.Concurrent.Async (mapConcurrently)
 import Control.DeepSeq
 import Control.Exception (handleJust)
 import qualified Data.Yaml as Yaml
@@ -46,7 +47,7 @@
 import Control.Monad.Trans.Cont
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
-import Data.Aeson ((.:))
+import Data.Aeson ((.:), (.:?))
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.Bifunctor (first)
@@ -56,12 +57,14 @@
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Text as C
 import qualified Data.HashMap.Strict as Map
-import Data.Maybe (fromMaybe)
+import Data.Foldable (for_)
+import Data.Maybe (fromMaybe, isJust, maybe)
 import Data.List
 import Data.List.Extra (trimEnd, nubOrd)
 import Data.Ord (Down(..))
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Data.Traversable (for)
 import System.Environment
 import System.FilePath
 import System.PosixCompat.Files
@@ -81,7 +84,6 @@
 import GHC.ResponseFile (escapeArgs)
 
 import Data.Version
-import Data.IORef
 import Text.ParserCombinators.ReadP (readP_to_S)
 import Data.Tuple.Extra (fst3, snd3, thd3)
 
@@ -154,37 +156,20 @@
 -- each prefix we know how to handle
 data ResolvedCradles a
  = ResolvedCradles
  { cradleRoot :: FilePath
  , resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity
- , cradleProgramVersions :: ProgramVersions
+ , cradleBuildToolVersions :: BuildToolVersions
  }
 
-data ProgramVersions =
-  ProgramVersions { cabalVersion  :: CachedIO (Maybe Version)
-                  , stackVersion  :: CachedIO (Maybe Version)
-                  , ghcVersion    :: CachedIO (Maybe Version)
-                  }
-
-newtype CachedIO a = CachedIO (IORef (Either (IO a) a))
-
-makeCachedIO :: IO a -> IO (CachedIO a)
-makeCachedIO act = CachedIO <$> newIORef (Left act)
-
-runCachedIO :: CachedIO a -> IO a
-runCachedIO (CachedIO ref) =
-  readIORef ref >>= \case
-    Right x -> pure x
-    Left act -> do
-      x <- act
-      writeIORef ref (Right x)
-      pure x
-
-makeVersions :: LogAction IO (WithSeverity Log) -> FilePath -> ([String] -> IO (CradleLoadResult String)) -> IO ProgramVersions
-makeVersions l wdir ghc = do
-  cabalVersion <- makeCachedIO $ getCabalVersion l wdir
-  stackVersion <- makeCachedIO $ getStackVersion l wdir
-  ghcVersion   <- makeCachedIO $ getGhcVersion ghc
-  pure ProgramVersions{..}
+type BuildToolVersions = BuildToolVersions' (Maybe Version)
+data BuildToolVersions' v =
+  BuildToolVersions { cabalVersion  :: v
+                    , stackVersion  :: v
+                    }
+  deriving (Functor, Foldable, Traversable)
+
+makeVersions :: LogAction IO (WithSeverity Log) -> FilePath -> IO BuildToolVersions
+makeVersions l wdir = mapConcurrently (\v -> v l wdir) $ BuildToolVersions getCabalVersion getStackVersion
 
 getCabalVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version)
 getCabalVersion l wdir = do
@@ -223,9 +208,11 @@
       (\err -> CradleFail (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps }))
       (\(ComponentOptions os' dir ds) -> CradleSuccess (ComponentOptions os' dir (ds `union` deps)))
 
-
 resolvedCradlesToCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> [ResolvedCradle b] -> IO (Cradle a)
-resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
+resolvedCradlesToCradle logger buildCustomCradle root cs = do
+  versions <- makeVersions logger root
+  cradleActions <- for cs $ \c ->
+    fmap (c,) $ resolveCradleAction logger buildCustomCradle (ResolvedCradles root cs versions) root c
   let run_ghc_cmd args =
         -- We're being lazy here and just returning the ghc path for the
         -- first non-none cradle. This shouldn't matter in practice: all
@@ -236,9 +223,6 @@
             runGhcCmd
               act
               args
-  versions <- makeVersions logger root run_ghc_cmd
-  let rcs = ResolvedCradles root cs versions
-      cradleActions = [ (c, resolveCradleAction logger buildCustomCradle rcs root c) | c <- cs ]
       err_msg fp
         = ["Multi Cradle: No prefixes matched"
           , "pwd: " ++ root
@@ -296,15 +280,15 @@
     notNoneType _ = True
 
 
-resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
-resolveCradleAction l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $
+resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> IO (CradleAction a)
+resolveCradleAction l buildCustomCradle cs root cradle = fmap addLoadStyleLogToCradleAction $
   case concreteCradle cradle of
     ConcreteCabal t -> cabalCradle l cs root (cabalComponent t) (projectConfigFromMaybe root (cabalProjectFile t))
-    ConcreteStack t -> stackCradle l root (stackComponent t) (projectConfigFromMaybe root (stackYaml t))
-    ConcreteBios bios deps mbGhc -> biosCradle l cs root bios deps mbGhc
-    ConcreteDirect xs -> directCradle l root xs
-    ConcreteNone -> noneCradle
-    ConcreteOther a -> buildCustomCradle a
+    ConcreteStack t -> pure $ stackCradle l root (stackComponent t) (projectConfigFromMaybe root (stackYaml t))
+    ConcreteBios bios deps mbGhc -> pure $ biosCradle l root bios deps mbGhc
+    ConcreteDirect xs -> pure $ directCradle l root xs
+    ConcreteNone -> pure $ noneCradle
+    ConcreteOther a -> pure $ buildCustomCradle a
   where
     -- Add a log message to each loading operation.
     addLoadStyleLogToCradleAction crdlAct = crdlAct
@@ -489,13 +473,14 @@
 
 -- | Find a cradle by finding an executable `hie-bios` file which will
 -- be executed to find the correct GHC options to use.
-biosCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> CradleAction a
-biosCradle l rc wdir biosCall biosDepsCall mbGhc
+biosCradle :: LogAction IO (WithSeverity Log) -> FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> CradleAction a
+biosCradle l wdir biosCall biosDepsCall mbGhc
   = CradleAction
       { actionName = Types.Bios
-      , runCradle = biosAction rc wdir biosCall biosDepsCall l
-      , runGhcCmd = \args -> readProcessWithCwd l wdir (fromMaybe "ghc" mbGhc) args ""
+      , runCradle = biosAction runGhcCmd wdir biosCall biosDepsCall l
+      , runGhcCmd = runGhcCmd
       }
+      where runGhcCmd = \args -> readProcessWithCwd l wdir (fromMaybe "ghc" mbGhc) args ""
 
 biosWorkDir :: FilePath -> MaybeT IO FilePath
 biosWorkDir = findFileUpwards ".hie-bios"
@@ -514,23 +499,22 @@
 biosDepsAction _ _ Nothing _ _ = return []
 
 biosAction
-  :: ResolvedCradles a
+  :: ([String] -> IO (CradleLoadResult String))
   -> FilePath
   -> Callable
   -> Maybe Callable
   -> LogAction IO (WithSeverity Log)
   -> FilePath
   -> LoadStyle
   -> IO (CradleLoadResult ComponentOptions)
-biosAction rc wdir bios bios_deps l fp loadStyle = do
-  ghc_version <- liftIO $ runCachedIO $ ghcVersion $ cradleProgramVersions rc
+biosAction runGhcCmd wdir bios bios_deps l fp loadStyle = do
+  ghc_version <- getGhcVersion runGhcCmd
   determinedLoadStyle <- case ghc_version of
     Just ghc
-      -- Multi-component supported from ghc 9.4
       -- We trust the assertion for a bios program, as we have no way of
       -- checking its version
       | LoadWithContext _ <- loadStyle ->
-          if ghc >= makeVersion [9,4]
+          if isCabalMultipleCompSupported Nothing (Just ghc)
             then pure loadStyle
             else do
               liftIO $ l <& WithSeverity
@@ -574,7 +558,7 @@
   old_env <- getEnvironment
   case files of
     [] -> action $ (proc canon_path []){env = Nothing}
-    (x : _) -> 
+    (x : _) ->
       runContT (withHieBiosMultiArg files) $ \multi_file -> do
         let updated_env = Just $
               (hie_bios_multi_arg, multi_file) : old_env
@@ -604,23 +588,35 @@
 
 -- |Cabal Cradle
 -- Works for new-build by invoking `v2-repl`.
-cabalCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a
-cabalCradle l cs wdir mc projectFile
-  = CradleAction
-    { actionName = Types.Cabal
-    , runCradle = \fp -> runCradleResultT . cabalAction cs wdir mc l projectFile fp
-    , runGhcCmd = \args -> runCradleResultT $ do
-        let vs = cradleProgramVersions cs
-        callCabalPathForCompilerPath l vs wdir projectFile >>= \case
+cabalCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> IO (CradleAction a)
+cabalCradle l cs wdir mc projectFile = do
+  res <- runCradleResultT $ callCabalPathForCompilerPath l (cradleBuildToolVersions cs) wdir projectFile
+  let
+    cabalPathOutput = case res of
+      CradleSuccess out -> out
+      _ -> Nothing
+
+    ghcPath = fst <$> cabalPathOutput
+    ghcVersion = snd =<< cabalPathOutput
+
+    runGhcCmd args = runCradleResultT $ do
+        case ghcPath of
           Just p -> readProcessWithCwd_ l wdir p args ""
           Nothing -> do
             buildDir <- liftIO $ cabalBuildDir wdir
             -- Workaround for a cabal-install bug on 3.0.0.0:
             -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
             liftIO $ createDirectoryIfMissing True (buildDir </> "tmp")
             -- Need to pass -v0 otherwise we get "resolving dependencies..."
-            cabalProc <- cabalProcess l vs projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args
+            cabalProc <- cabalProcess l projectFile wdir Nothing "v2-exec" $ ["ghc", "-v0", "--"] ++ args
             readProcessWithCwd' l cabalProc ""
+
+  pure $ CradleAction
+    { actionName = Types.Cabal
+    , runCradle = \fp ls -> do
+        v <- maybe (getGhcVersion runGhcCmd) (pure . Just) ghcVersion
+        runCradleResultT $ cabalAction cs wdir ghcPath v mc l projectFile fp ls
+    , runGhcCmd = runGhcCmd
     }
 
 
@@ -633,9 +629,9 @@
 -- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which
 -- the custom ghc wrapper may use as a fallback if it can not respond to certain
 -- queries, such as ghc version or location of the libdir.
-cabalProcess :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess
-cabalProcess l vs cabalProject workDir command args = do
-  ghcDirs@(ghcBin, libdir) <- callCabalPathForCompilerPath l vs workDir cabalProject >>= \case
+cabalProcess :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> Maybe FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess
+cabalProcess l cabalProject workDir ghcPath command args = do
+  ghcDirs@(ghcBin, libdir) <- case ghcPath of
     Just p -> do
       libdir <- readProcessWithCwd_ l workDir p ["--print-libdir"] ""
       pure (p, trimEnd libdir)
@@ -861,48 +857,53 @@
   where
     projectFileArgs = projectFileProcessArgs cabalProject
 
-callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath)
+callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> BuildToolVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe (FilePath, Maybe Version))
 callCabalPathForCompilerPath l vs workDir projectFile = do
-  isCabalPathSupported vs >>= \case
+  case isCabalPathSupported vs of
     False -> pure Nothing
     True -> do
       let
         args = ["path", "--output-format=json"] <> projectFileProcessArgs projectFile
         bs = BS.fromStrict . T.encodeUtf8 . T.pack
-        parse_compiler_path = Aeson.parseEither ((.: "compiler") >=>  (.: "path")) <=< Aeson.eitherDecode
-
       compiler_info <- readProcessWithCwd_ l workDir "cabal" args ""
-      case parse_compiler_path (bs compiler_info) of
+      let
+        parsed = do
+          json <- Aeson.eitherDecode (bs compiler_info)
+          flip Aeson.parseEither json $ \o -> do
+            c <- o .: "compiler"
+            p <- c .: "path"
+            i <- c .:? "id"
+            let v = versionMaybe . T.unpack . T.takeWhileEnd (/= '-') . T.pack =<< i
+            pure (p, v)
+
+      case parsed of
         Left err -> do
           liftIO $ l <& WithSeverity (LogCabalPath $ T.pack err) Warning
           pure Nothing
-        Right a -> pure a
+        Right a -> pure $ Just a
 
-isCabalPathSupported :: MonadIO m => ProgramVersions -> m Bool
-isCabalPathSupported vs = do
-  v <- liftIO $ runCachedIO $ cabalVersion vs
-  pure $ maybe False (>= makeVersion [3,14]) v
+isCabalPathSupported :: BuildToolVersions -> Bool
+isCabalPathSupported = maybe False (>= makeVersion [3,14]) . cabalVersion
 
-isCabalMultipleCompSupported :: MonadIO m => ProgramVersions -> m Bool
-isCabalMultipleCompSupported vs = do
-  cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
-  ghc_version <- liftIO $ runCachedIO $ ghcVersion vs
-  -- determine which load style is supported by this cabal cradle.
-  case (cabal_version, ghc_version) of
-    (Just cabal, Just ghc) -> pure $ ghc >= makeVersion [9, 4] && cabal >= makeVersion [3, 11]
-    _ -> pure False
+isCabalMultipleCompSupported :: Maybe BuildToolVersions -> Maybe Version -> Bool
+isCabalMultipleCompSupported mvs ghcVersion = isJust $ do
+  let atLeast v = guard . maybe False (makeVersion v <=)
+  atLeast [9,4] ghcVersion
+  for_ mvs $ \vs -> atLeast [3,11] $ cabalVersion vs -- Only gate on cabal version if known
 
 cabalAction
   :: ResolvedCradles a
   -> FilePath
+  -> Maybe FilePath
+  -> Maybe Version
   -> Maybe String
   -> LogAction IO (WithSeverity Log)
   -> CradleProjectConfig
   -> FilePath
   -> LoadStyle
   -> CradleLoadResultT IO ComponentOptions
-cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do
-  multiCompSupport <- isCabalMultipleCompSupported vs
+cabalAction (ResolvedCradles root cs vs) workDir ghcPath ghcVersion mc l projectFile fp loadStyle = do
+  let multiCompSupport = isCabalMultipleCompSupported (Just vs) ghcVersion
   -- determine which load style is supported by this cabal cradle.
   determinedLoadStyle <- case loadStyle of
     LoadWithContext _ | not multiCompSupport -> do
@@ -932,7 +933,7 @@
   let cabalCommand = "v2-repl"
 
   cabalProc <-
-    cabalProcess l vs projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do
+    cabalProcess l projectFile workDir ghcPath cabalCommand cabalArgs `modCradleError` \err -> do
       deps <- cabalCradleDependencies projectFile workDir workDir
       pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps}
 

tests/Utils.hs

@@ -319,8 +319,9 @@ isCabalMultipleCompSupported' :: TestM Bool
 isCabalMultipleCompSupported' = do
   cr <- askCradle
   root <- askRoot
-  versions <- liftIO $ makeVersions (cradleLogger cr) root ((runGhcCmd . cradleOptsProg) cr)
-  liftIO $ isCabalMultipleCompSupported versions
+  versions <- liftIO $ makeVersions (cradleLogger cr) root
+  v <- liftIO $ getGhcVersion ((runGhcCmd . cradleOptsProg) cr)
+  pure $ isCabalMultipleCompSupported (Just versions) v
 
 inCradleRootDir :: TestM a -> TestM a
 inCradleRootDir act = do