From 5a60f9f037e22a7456642bc447c90ca0a33b7d5a Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Mon, 1 Apr 2024 11:22:25 +0100 Subject: [PATCH] Re #6542 Take a direct approach to `initialBuildSteps` --- ChangeLog.md | 3 + src/setup-shim/StackSetupShim.hs | 142 +++++++++++++++++++++---------- 2 files changed, 100 insertions(+), 45 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 51eec97fe1..3f9f2beab4 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -12,6 +12,9 @@ Behaviour changes: version of GHC. Stack no longer supports such Cabal versions before 2.2, which came with versions of GHC before 8.4. Consequently, the `init` command will not try LTS Haskell before 12.0. +* Stack's `StackSetupShim` executable, when called with `repl` and + `stack-initial-build-steps`, no longer uses Cabal's `replHook` to apply + `initialBuildSteps` but takes a more direct approach. * The `init` command initialises `stack.yaml` with a `snapshot` key rather than a `resolver` key. * After installing GHC or another tool, Stack deletes the archive file which diff --git a/src/setup-shim/StackSetupShim.hs b/src/setup-shim/StackSetupShim.hs index c723a6d3f4..b66add1fbc 100644 --- a/src/setup-shim/StackSetupShim.hs +++ b/src/setup-shim/StackSetupShim.hs @@ -1,63 +1,70 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module StackSetupShim where + import Main -#if defined(MIN_VERSION_Cabal) -#if MIN_VERSION_Cabal(3,8,1) -import Distribution.PackageDescription - ( PackageDescription, emptyHookedBuildInfo ) -#else -import "Cabal" Distribution.PackageDescription - ( PackageDescription, emptyHookedBuildInfo ) -#endif -#else -import Distribution.PackageDescription - ( PackageDescription, emptyHookedBuildInfo ) -#endif -import Distribution.Simple -import Distribution.Simple.Build -import Distribution.Simple.Setup - ( ReplFlags, fromFlag, replDistPref, replVerbosity ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) --- | Temporary, can be removed if initialBuildSteps restored to Cabal's API. -#if defined(MIN_VERSION_Cabal) +import System.Environment ( getArgs ) + +-- | We do not need to test for the existence of the MIN_VERSION_Cabal macro, as +-- Stack no longer supports GHC versions before GHC 8.0. #if MIN_VERSION_Cabal(3,11,0) + +import Data.List ( stripPrefix ) +import Distribution.Parsec ( eitherParsec ) +import Distribution.Simple.Configure ( getPersistBuildConfig ) +import Distribution.Simple.Build ( writeBuiltinAutogenFiles ) +import Distribution.Simple.Errors ( exceptionMessage ) import Distribution.Simple.LocalBuildInfo - ( ComponentLocalBuildInfo, componentBuildDir + ( ComponentLocalBuildInfo, LocalBuildInfo, componentBuildDir , withAllComponentsInBuildOrder ) -import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose ) +import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, findPackageDesc ) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription (..) ) +import Distribution.Types.PackageDescription ( PackageDescription ) import Distribution.Verbosity ( Verbosity ) -#endif -#endif -import System.Environment ( getArgs ) mainOverride :: IO () mainOverride = do - args <- getArgs - if "repl" `elem` args && "stack-initial-build-steps" `elem` args - then do - defaultMainWithHooks simpleUserHooks - { preRepl = \_ _ -> pure emptyHookedBuildInfo - , replHook = stackReplHook - , postRepl = \_ _ _ _ -> pure () - } - else main + args <- getArgs + case args of + arg1:arg2:"repl":"stack-initial-build-steps":[] -> + stackReplHook arg1 arg2 + _ -> main -stackReplHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () -stackReplHook pkg_descr lbi hooks flags args = do - let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) - case args of - ("stack-initial-build-steps":rest) - | null rest -> initialBuildSteps distPref pkg_descr lbi verbosity - | otherwise -> - fail "Misuse of running Setup.hs with stack-initial-build-steps, expected no arguments" - _ -> replHook simpleUserHooks pkg_descr lbi hooks flags args +-- | The name of the function is a mismomer, but is kept for historical reasons. +stackReplHook :: String -> String -> IO () +stackReplHook arg1 arg2 = do + let mRawVerbosity = stripPrefix "--verbose=" arg1 + mRawBuildDir = stripPrefix "--builddir=" arg2 + case (mRawVerbosity, mRawBuildDir) of + (Nothing, _) -> fail $ + "Misuse of running Setup.hs with stack-initial-build-steps, expected " <> + "first argument to start --verbose=" + (_, Nothing) -> fail $ + "Misuse of running Setup.hs with stack-initial-build-steps, expected" <> + "second argument to start --builddir=" + (Just rawVerbosity, Just rawBuildDir) -> case eitherParsec rawVerbosity of + Left msg1 -> fail $ + "Unexpected happened running Setup.hs with " <> + "stack-initial-build-steps, expected to parse Cabal verbosity: " <> msg1 + Right verbosity -> do + eFp <- findPackageDesc "" + case eFp of + Left err -> fail $ + "Unexpected happened running Setup.hs with " <> + "stack-initial-build-steps, expected to find a Cabal file: " <> + exceptionMessage err + Right fp -> do + gpd <- readGenericPackageDescription verbosity fp + let pd = packageDescription gpd + lbi <- getPersistBuildConfig rawBuildDir + initialBuildSteps rawBuildDir pd lbi verbosity -- | Temporary, can be removed if initialBuildSteps restored to Cabal's API. -#if defined(MIN_VERSION_Cabal) -#if MIN_VERSION_Cabal(3,11,0) + -- | Runs 'componentInitialBuildSteps' on every configured component. initialBuildSteps :: FilePath -- ^"dist" prefix @@ -80,5 +87,50 @@ componentInitialBuildSteps :: componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi + +#else + +#if MIN_VERSION_Cabal(3,8,1) +import Distribution.PackageDescription + ( PackageDescription, emptyHookedBuildInfo ) +#else +import "Cabal" Distribution.PackageDescription + ( PackageDescription, emptyHookedBuildInfo ) #endif +import Distribution.Simple +import Distribution.Simple.Build +import Distribution.Simple.Setup + ( ReplFlags, fromFlag, replDistPref, replVerbosity ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) + +mainOverride :: IO () +mainOverride = do + args <- getArgs + if "repl" `elem` args && "stack-initial-build-steps" `elem` args + then do + defaultMainWithHooks simpleUserHooks + { preRepl = \_ _ -> pure emptyHookedBuildInfo + , replHook = stackReplHook + , postRepl = \_ _ _ _ -> pure () + } + else main + +stackReplHook :: + PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () +stackReplHook pkg_descr lbi hooks flags args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + case args of + ("stack-initial-build-steps":rest) + | null rest -> initialBuildSteps distPref pkg_descr lbi verbosity + | otherwise -> fail $ + "Misuse of running Setup.hs with stack-initial-build-steps, " <> + "expected no arguments" + _ -> replHook simpleUserHooks pkg_descr lbi hooks flags args + #endif