diff --git a/hie-bios.cabal b/hie-bios.cabal index 14c17c1d..e06dcc30 100644 --- a/hie-bios.cabal +++ b/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 diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index e7b97894..406db31b 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/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 @@ module HIE.Bios.Cradle ( -- 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.Extra (unlessM) 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.Combinators as C 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.Fingerprint (fingerprintString) import GHC.ResponseFile (escapeArgs) import Data.Version -import Data.IORef import Text.ParserCombinators.ReadP (readP_to_S) import Data.Tuple.Extra (fst3, snd3, thd3) @@ -156,35 +158,18 @@ 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 @@ addActionDeps deps = (\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 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo 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 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo 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 @@ directCradle l wdir args -- | 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,7 +499,7 @@ biosDepsAction l wdir (Just biosDepsCall) fp loadStyle = do biosDepsAction _ _ Nothing _ _ = return [] biosAction - :: ResolvedCradles a + :: ([String] -> IO (CradleLoadResult String)) -> FilePath -> Callable -> Maybe Callable @@ -522,15 +507,14 @@ biosAction -> 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 @@ withCallableToProcess (Program path) files = ContT $ \action -> do 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,14 +588,19 @@ projectLocationOrDefault = \case -- |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 @@ -619,8 +608,15 @@ cabalCradle l cs wdir mc projectFile -- ./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 @@ cabalCradle l cs wdir mc projectFile -- 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 @@ cabalGhcDirs l cabalProject workDir = do 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 @@ cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = 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} diff --git a/tests/Utils.hs b/tests/Utils.hs index b9581869..40732737 100644 --- a/tests/Utils.hs +++ b/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