From 9d51a5a8f1f2b8e418bddf20e8347a9bb309bab9 Mon Sep 17 00:00:00 2001 From: Fendor Date: Tue, 16 Apr 2024 18:47:24 +0200 Subject: [PATCH] Add Loading Style option to `runAction` Allows users to decide at run-time whether they would like to use experimental features, such as `cabal`'s `multi-repl` feature that will be released in 3.12. The `LoadStyle` can not always be honoured by the respective cradle. For example, if the ghc version or cabal version isn't recent enough. --- exe/Main.hs | 3 +- hie-bios.cabal | 4 +- src/HIE/Bios/Cradle.hs | 103 ++++++++++++++++++++++----------- src/HIE/Bios/Flags.hs | 6 +- src/HIE/Bios/Ghc/Api.hs | 2 +- src/HIE/Bios/Internal/Debug.hs | 2 +- src/HIE/Bios/Types.hs | 36 ++++++++++-- tests/Utils.hs | 2 +- 8 files changed, 108 insertions(+), 50 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index e7a8b43a..1ad45636 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -16,6 +16,7 @@ import HIE.Bios import HIE.Bios.Ghc.Check import HIE.Bios.Ghc.Gap as Gap import HIE.Bios.Internal.Debug +import HIE.Bios.Types (LoadStyle(SingleComponent)) import Paths_hie_bios ---------------------------------------------------------------- @@ -84,7 +85,7 @@ main = do [] -> error "too few arguments" _ -> do res <- forM files $ \fp -> do - res <- getCompilerOptions fp [] cradle + res <- getCompilerOptions fp SingleComponent cradle case res of CradleFail (CradleError _deps _ex err) -> return $ "Failed to show flags for \"" diff --git a/hie-bios.cabal b/hie-bios.cabal index f3cf4f9a..056f247b 100644 --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -172,8 +172,8 @@ Library exceptions ^>= 0.10, cryptohash-sha1 >= 0.11.100 && < 0.12, directory >= 1.3.0 && < 1.4, - filepath >= 1.4.1 && < 1.5, - time >= 1.8.0 && < 1.13, + filepath >= 1.4.1 && < 1.6, + time >= 1.8.0 && < 1.14, extra >= 1.6.14 && < 1.8, prettyprinter ^>= 1.6 || ^>= 1.7.0, ghc >= 9.2.1 && < 9.9, diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index d859acfd..9932db6d 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -284,8 +284,8 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo notNoneType _ = True -resolveCradleAction :: LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a -resolveCradleAction l buildCustomCradle cs root cradle = +resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a +resolveCradleAction l buildCustomCradle cs root cradle = 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)) @@ -293,6 +293,13 @@ resolveCradleAction l buildCustomCradle cs root cradle = ConcreteDirect xs -> directCradle l root xs ConcreteNone -> noneCradle ConcreteOther a -> buildCustomCradle a + where + -- Add a log message to each loading operation. + addLoadStyleLogToCradleAction crdlAct = crdlAct + { runCradle = \fp ls -> do + l <& LogRequestedCradleLoadStyle (T.pack $ show $ actionName crdlAct) ls `WithSeverity` Debug + runCradle crdlAct fp ls + } resolveCradleTree :: FilePath -> CradleConfig a -> [ResolvedCradle a] resolveCradleTree root (CradleConfig confDeps confTree) = go root confDeps confTree @@ -458,7 +465,8 @@ directCradle :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> Cradl directCradle l wdir args = CradleAction { actionName = Types.Direct - , runCradle = \_ _ -> + , runCradle = \_ loadStyle -> do + logCradleHasNoSupportForLoadWithContext l loadStyle "direct" return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir [])) , runGhcCmd = runGhcCmdOnPath l wdir } @@ -480,7 +488,7 @@ biosCradle l wdir biosCall biosDepsCall mbGhc biosWorkDir :: FilePath -> MaybeT IO FilePath biosWorkDir = findFileUpwards (".hie-bios" ==) -biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> [FilePath] -> IO [FilePath] +biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> LoadStyle -> IO [FilePath] biosDepsAction l wdir (Just biosDepsCall) fp _prevs = do biosDeps' <- callableToProcess biosDepsCall (Just fp) -- TODO multi pass the previous files too (ex, sout, serr, [(_, args)]) <- readProcessWithOutputs [hie_bios_output] l wdir biosDeps' @@ -495,16 +503,17 @@ biosAction -> Maybe Callable -> LogAction IO (WithSeverity Log) -> FilePath - -> [FilePath] + -> LoadStyle -> IO (CradleLoadResult ComponentOptions) -biosAction wdir bios bios_deps l fp fps = do +biosAction wdir bios bios_deps l fp loadStyle = do + logCradleHasNoSupportForLoadWithContext l loadStyle "bios" bios' <- callableToProcess bios (Just fp) -- TODO pass all the files instead of listToMaybe (ex, _stdo, std, [(_, res),(_, mb_deps)]) <- readProcessWithOutputs [hie_bios_output, hie_bios_deps] l wdir bios' deps <- case mb_deps of Just x -> return x - Nothing -> biosDepsAction l wdir bios_deps fp fps + Nothing -> biosDepsAction l wdir bios_deps fp loadStyle -- Output from the program should be written to the output file and -- delimited by newlines. -- Execute the bios action and add dependencies of the cradle. @@ -779,7 +788,6 @@ cabalGhcDirs l cabalProject workDir = do where projectFileArgs = projectFileProcessArgs cabalProject - cabalAction :: ResolvedCradles a -> FilePath @@ -787,34 +795,48 @@ cabalAction -> LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath - -> [FilePath] + -> LoadStyle -> CradleLoadResultT IO ComponentOptions -cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp fps = do +cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do cabal_version <- liftIO $ runCachedIO $ cabalVersion vs ghc_version <- liftIO $ runCachedIO $ ghcVersion vs let cabalCommand = "v2-repl" - cabalArgs = case (cabal_version, ghc_version) of - (Just cabal, Just ghc) - -- Multi-component supported from cabal-install 3.11 - -- and ghc 9.4 - | ghc >= makeVersion [9,4] - , cabal >= makeVersion [3,11] - -> case fps of - [] -> [fromMaybe (fixTargetPath fp) mc] - -- Start a multi-component session with all the old files - _ -> "--keep-temp-files" - : "--enable-multi-repl" - : fromMaybe (fixTargetPath fp) mc - : [fromMaybe (fixTargetPath old_fp) old_mc - | old_fp <- fps - -- Lookup the component for the old file - , Just (ResolvedCradle{concreteCradle = ConcreteCabal ct}) <- [selectCradle prefix old_fp cs] - -- Only include this file if the old component is in the same project - , (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile - , let old_mc = cabalComponent ct - ] - _ -> [fromMaybe (fixTargetPath fp) mc] + -- determine which load style is supported by this cabal cradle. + determinedLoadStyle <- case (cabal_version, ghc_version) of + (Just cabal, Just ghc) + -- Multi-component supported from cabal-install 3.11 + -- and ghc 9.4 + | LoadWithContext _ <- loadStyle -> + if ghc >= makeVersion [9,4] && cabal >= makeVersion [3,11] + then pure loadStyle + else do + liftIO $ l <& WithSeverity + (LogLoadWithContextUnsupported "cabal" + $ Just "cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`." + ) + Info + pure SingleComponent + _ -> pure SingleComponent + + let cabalArgs = case determinedLoadStyle of + SingleComponent -> [fromMaybe (fixTargetPath fp) mc] + LoadWithContext fps -> concat + [ [ "--keep-temp-files" + , "--enable-multi-repl" + , fromMaybe (fixTargetPath fp) mc + ] + , [fromMaybe (fixTargetPath old_fp) old_mc + | old_fp <- fps + -- Lookup the component for the old file + , Just (ResolvedCradle{concreteCradle = ConcreteCabal ct}) <- [selectCradle prefix old_fp cs] + -- Only include this file if the old component is in the same project + , (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile + , let old_mc = cabalComponent ct + ] + ] + + liftIO $ l <& LogComputedCradleLoadStyle "cabal" determinedLoadStyle `WithSeverity` Info cabalProc <- cabalProcess l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do deps <- cabalCradleDependencies projectFile workDir workDir @@ -843,8 +865,7 @@ cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp fps = do -- Best effort. Assume the working directory is the -- root of the component, so we are right in trivial cases at least. deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir - throwCE (CradleError deps ex $ - (["Failed to parse result of calling cabal" ] <> errorDetails)) + throwCE (CradleError deps ex $ ["Failed to parse result of calling cabal" ] <> errorDetails) Just (componentDir, final_args) -> do deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) deps @@ -963,9 +984,10 @@ stackAction -> CradleProjectConfig -> LogAction IO (WithSeverity Log) -> FilePath - -> [FilePath] + -> LoadStyle -> IO (CradleLoadResult ComponentOptions) -stackAction workDir mc syaml l _fp _fps = do +stackAction workDir mc syaml l _fp loadStyle = do + logCradleHasNoSupportForLoadWithContext l loadStyle "stack" let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"]) -- Same wrapper works as with cabal wrapper_fp <- withGhcWrapperTool l ghcProcArgs workDir @@ -1234,3 +1256,14 @@ readProcessWithCwd' l createdProcess stdin = do Nothing -> throwCE $ CradleError [] ExitSuccess $ ["Couldn't execute " <> cmdString] <> prettyProcessEnv createdProcess + +-- | Log that the cradle has no supported for loading with context, if and only if +-- 'LoadWithContext' was requested. +logCradleHasNoSupportForLoadWithContext :: Applicative m => LogAction m (WithSeverity Log) -> LoadStyle -> T.Text -> m () +logCradleHasNoSupportForLoadWithContext l (LoadWithContext _) crdlName = + l <& WithSeverity + (LogLoadWithContextUnsupported crdlName + $ Just $ crdlName <> " doesn't support loading multiple components at once." + ) + Info +logCradleHasNoSupportForLoadWithContext _ _ _ = pure () diff --git a/src/HIE/Bios/Flags.hs b/src/HIE/Bios/Flags.hs index a9d9bb44..64a50cf7 100644 --- a/src/HIE/Bios/Flags.hs +++ b/src/HIE/Bios/Flags.hs @@ -8,9 +8,9 @@ import Colog.Core (WithSeverity (..), Severity (..), (<&)) -- file or GHC session according to the provided 'Cradle'. getCompilerOptions :: FilePath -- ^ The file we are loading it because of - -> [FilePath] -- ^ previous files we might want to include in the build + -> LoadStyle -- ^ previous files we might want to include in the build -> Cradle a -> IO (CradleLoadResult ComponentOptions) -getCompilerOptions fp fps cradle = do +getCompilerOptions fp loadStyle cradle = do (cradleLogger cradle) <& LogProcessOutput "invoking build tool to determine build flags (this may take some time depending on the cache)" `WithSeverity` Info - runCradle (cradleOptsProg cradle) fp fps + runCradle (cradleOptsProg cradle) fp loadStyle diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index d2651ddc..f9d1ad14 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -39,7 +39,7 @@ initializeFlagsWithCradleWithMessage :: -> Cradle a -- ^ The cradle we want to load -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not. initializeFlagsWithCradleWithMessage msg fp cradle = - fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp [] cradle) + fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp SingleComponent cradle) -- | Actually perform the initialisation of the session. Initialising the session corresponds to -- parsing the command line flags, setting the targets for the session and then attempting to load diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 2eac8f96..24ceee69 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -30,7 +30,7 @@ debugInfo :: Show a -> IO String debugInfo fp cradle = unlines <$> do let logger = cradleLogger cradle - res <- getCompilerOptions fp [] cradle + res <- getCompilerOptions fp SingleComponent cradle canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' logger canonFp diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index e539618b..4d3d3199 100644 --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -13,9 +13,10 @@ import Control.Monad.Trans.Class #if MIN_VERSION_base(4,9,0) import qualified Control.Monad.Fail as Fail #endif -import Prettyprinter -import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Prettyprinter +import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..)) ---------------------------------------------------------------- -- Environment variables used by hie-bios. @@ -91,11 +92,14 @@ data ActionName a deriving (Show, Eq, Ord, Functor) data Log - = LogAny String + = LogAny !T.Text | LogProcessOutput String | LogCreateProcessRun CreateProcess | LogProcessRun FilePath [FilePath] - deriving Show + | LogRequestedCradleLoadStyle !T.Text !LoadStyle + | LogComputedCradleLoadStyle !T.Text !LoadStyle + | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text) + deriving (Show) instance Pretty Log where pretty (LogAny s) = pretty s @@ -116,11 +120,31 @@ instance Pretty Log where ] where envText = map (indent 2 . pretty) $ prettyProcessEnv cp + pretty (LogRequestedCradleLoadStyle crdlName ls) = + "Request loading" <+> pretty crdlName <+> "cradle using" <+> case ls of + SingleComponent -> "Single Component Strategy" + LoadWithContext fps -> "Multiple Components Strategy:" <> line <> indent 4 (pretty fps) + pretty (LogComputedCradleLoadStyle crdlName ls) = + "Load" <+> pretty crdlName <+> "cradle using" <+> case ls of + SingleComponent -> "Single Component Strategy" + LoadWithContext _ -> "Multiple Components Strategy" + + pretty (LogLoadWithContextUnsupported crdlName mReason) = + "Failed to load" <+> pretty crdlName <+> "cradle with context" <> + case mReason of + Nothing -> "." + Just reason -> ", because: " <+> pretty reason <> "." + <+> "Falling back to 'Single Component' mode." + +data LoadStyle + = SingleComponent + | LoadWithContext [FilePath] + deriving (Show, Eq, Ord) data CradleAction a = CradleAction { actionName :: ActionName a -- ^ Name of the action. - , runCradle :: FilePath -> [FilePath] -> IO (CradleLoadResult ComponentOptions) + , runCradle :: FilePath -> LoadStyle -> IO (CradleLoadResult ComponentOptions) -- ^ Options to compile the given file with. , runGhcCmd :: [String] -> IO (CradleLoadResult String) -- ^ Executes the @ghc@ binary that is usually used to diff --git a/tests/Utils.hs b/tests/Utils.hs index a542960a..a15a28de 100644 --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -269,7 +269,7 @@ loadComponentOptions fp = do a_fp <- normFile fp crd <- askCradle step $ "Initialise flags for: " <> fp - clr <- liftIO $ getCompilerOptions a_fp [] crd + clr <- liftIO $ getCompilerOptions a_fp SingleComponent crd setLoadResult clr loadRuntimeGhcLibDir :: TestM ()