Re #6542 Take a direct approach to initialBuildSteps

commercialhaskell · Apr 1, 2024 · 5a60f9f · 5a60f9f
1 parent fa7cd30
commit 5a60f9f
Show file tree

Hide file tree

Showing 2 changed files with 100 additions and 45 deletions.
diff --git 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
@@ -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