Add hadrian-ghc flag, fixes #1044

lib-opt/GHCup/OptParse/Compile.hs

@@ -69,6 +69,7 @@ data CompileCommand = CompileGHC GHCCompileOptions
 data GHCCompileOptions = GHCCompileOptions
   { targetGhc    :: GHC.GHCVer
   , bootstrapGhc :: Either Version FilePath
+  , hadrianGhc   :: Maybe (Either Version FilePath)
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe FilePath
   , patches      :: Maybe (Either FilePath [URI])
@@ -164,7 +165,7 @@ Examples:
 
 ghcCompileOpts :: Parser GHCCompileOptions
 ghcCompileOpts =
-  (\targetGhc bootstrapGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir -> GHCCompileOptions {..})
+  (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir -> GHCCompileOptions {..})
     <$> ((GHC.SourceDist <$> option
           (eitherReader
             (first (const "Not a valid version") . version . T.pack)
@@ -208,6 +209,18 @@ ghcCompileOpts =
                "The GHC version (or full path) to bootstrap with (must be installed)"
           <> (completer $ versionCompleter [] GHC)
           )
+    <*> optional (option
+          (eitherReader
+            (\x ->
+              (bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
+            )
+          )
+          (  long "hadrian-ghc"
+          <> metavar "HADRIAN_GHC"
+          <> help
+               "The GHC version (or full path) to GHC that will be used to compile hadrian (must be installed)"
+          <> (completer $ versionCompleter [] GHC)
+          ))
     <*> optional
           (option
             (eitherReader (readEither @Int))
@@ -608,6 +621,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     crossTarget
                     overwriteVer
                     bootstrapGhc
+                    hadrianGhc
                     jobs
                     buildConfig
                     patches

lib-tui/GHCup/Brick/Actions.hs

@@ -518,6 +518,7 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do
                     (compopts ^. CompileGHC.crossTarget)
                     (compopts ^. CompileGHC.overwriteVer)
                     (compopts ^. CompileGHC.bootstrapGhc)
+                    (compopts ^. CompileGHC.hadrianGhc)
                     (compopts ^. CompileGHC.jobs)
                     (compopts ^. CompileGHC.buildConfig)
                     (compopts ^. CompileGHC.patches)
@@ -735,4 +736,4 @@ keyHandlers KeyBindings {..} =
     ad <- use appData
     current_app_state <- use appState
     appSettings .= newAppSettings
-    appState    .= constructList ad newAppSettings (Just current_app_state)
+    appState    .= constructList ad newAppSettings (Just current_app_state)

lib-tui/GHCup/Brick/Common.hs

@@ -43,7 +43,7 @@ module GHCup.Brick.Common  (
   BrickSettings(..),
   ResourceId (
       UrlEditBox, SetCheckBox, IsolateEditBox, ForceCheckBox, AdditionalEditBox
-    , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox
+    , TargetGhcEditBox, BootstrapGhcEditBox, HadrianGhcEditBox, JobsEditBox, BuildConfigEditBox
     , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox
     , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton
     , CompileGHCButton, CompileHLSButton, CabalProjectEditBox
@@ -97,6 +97,8 @@ pattern TargetGhcEditBox :: ResourceId
 pattern TargetGhcEditBox = ResourceId 6
 pattern BootstrapGhcEditBox :: ResourceId
 pattern BootstrapGhcEditBox = ResourceId 7
+pattern HadrianGhcEditBox :: ResourceId
+pattern HadrianGhcEditBox = ResourceId 17
 pattern JobsEditBox :: ResourceId
 pattern JobsEditBox = ResourceId 8
 pattern BuildConfigEditBox :: ResourceId

lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs

@@ -21,6 +21,7 @@ module GHCup.Brick.Widgets.Menus.CompileGHC (
   handler,
   draw,
   bootstrapGhc,
+  hadrianGhc,
   jobs,
   buildConfig,
   patches,
@@ -60,6 +61,7 @@ import qualified GHCup.Utils.Parsers as Utils
 
 data CompileGHCOptions = CompileGHCOptions
   { _bootstrapGhc :: Either Version FilePath
+  , _hadrianGhc   :: Maybe (Either Version FilePath)
   , _jobs         :: Maybe Int
   , _buildConfig  :: Maybe FilePath
   , _patches      :: Maybe (Either FilePath [URI])
@@ -87,6 +89,7 @@ create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields
         Nothing
         Nothing
         Nothing
+        Nothing
         []
         False
         Nothing
@@ -119,6 +122,14 @@ create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields
                 else readVersion
         False -> Left "Invalid Empty value"
 
+    hadrianstrapV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either Version FilePath))
+    hadrianstrapV i' =
+        let readVersion = bimap (const "Not a valid version") (Just . Left) . version
+            readPath = bimap T.pack (Just . Right) . Utils.absolutePathParser . T.unpack
+         in if T.any isPathSeparator i'
+              then whenEmpty Nothing readPath i'
+              else whenEmpty Nothing readVersion i'
+
     versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
     versionV = whenEmpty Nothing (bimap T.pack Just . Utils.overWriteVersionParser . T.unpack)
 
@@ -155,6 +166,9 @@ create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields
            & Menu.fieldLabelL .~ "bootstrap-ghc"
            & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)"
            & Menu.fieldStatusL .~ Menu.Invalid "Invalid Empty value"
+      , Menu.createEditableField (Common.MenuElement Common.HadrianGhcEditBox) hadrianstrapV hadrianGhc
+           & Menu.fieldLabelL .~ "hadrian-ghc"
+           & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to GHC that will be used to compile hadrian (must be installed)"
       , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
           & Menu.fieldLabelL .~ "jobs"
           & Menu.fieldHelpMsgL .~ "How many jobs to use for make"

lib/GHCup/GHC.hs

@@ -792,7 +792,8 @@ compileGHC :: ( MonadMask m
            => GHCVer
            -> Maybe Text               -- ^ cross target
            -> Maybe [VersionPattern]
-           -> Either Version FilePath  -- ^ version to bootstrap with
+           -> Either Version FilePath  -- ^ GHC version to bootstrap with
+           -> Maybe (Either Version FilePath)  -- ^ GHC version to compile hadrian with
            -> Maybe Int                -- ^ jobs
            -> Maybe FilePath           -- ^ build config
            -> Maybe (Either FilePath [URI])  -- ^ patches
@@ -827,7 +828,7 @@ compileGHC :: ( MonadMask m
                  ]
                 m
                 GHCTargetVersion
-compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
+compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
   = do
     pfreq@PlatformRequest { .. } <- lift getPlatformReq
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -1096,13 +1097,21 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil
 
     lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..."
     hadrian_build <- liftE $ findHadrianFile workdir
+    hEnv <- case hghc of
+              Nothing -> pure Nothing
+              Just hghc' -> do
+                cEnv <- Map.fromList <$> liftIO getEnvironment
+                ghc <- liftE $ resolveGHC hghc'
+                pure . Just . Map.toList . Map.insert "GHC" ghc $ cEnv
+
+
     lEM $ execLogged hadrian_build
                           ( maybe [] (\j  -> ["-j" <> show j]         ) jobs
                          ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
                          ++ ["binary-dist"]
                           )
                           (Just workdir) "ghc-make"
-                          Nothing
+                          hEnv
     [tar] <- liftIO $ findFiles
       (workdir </> "_build" </> "bindist")
       (makeRegexOpts compExtended
@@ -1317,7 +1326,7 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil
                        -> FilePath         -- ^ log filename (opened in append mode)
                        -> Excepts '[ProcessError, NotFoundInPATH] m ()
   configureWithGhcBoot mtver args dir logf = do
-    bghc <- liftE resolveBootstrapGHC
+    bghc <- liftE $ resolveGHC bstrap
     let execNew = execLogged
                     "sh"
                     ("./configure" : ("GHC=" <> bghc) : args)
@@ -1335,15 +1344,13 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil
        | Nothing   <- mtver               -> lEM execNew -- need some default for git checkouts where we don't know yet
        | otherwise                        -> lEM execOld
 
-  resolveBootstrapGHC :: MonadIO m => Excepts '[NotFoundInPATH] m FilePath
-  resolveBootstrapGHC = case bstrap of
+  resolveGHC :: MonadIO m => Either Version FilePath -> Excepts '[NotFoundInPATH] m FilePath
+  resolveGHC = \case
            Right g    -> pure g
            Left  bver -> do
-             -- https://gitlab.haskell.org/ghc/ghc/-/issues/24682
-             -- need absolute path
              let ghc = "ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt
-             spaths <- liftIO getSearchPath
-             liftIO (searchPath spaths ghc) !? NotFoundInPATH ghc
+             -- https://gitlab.haskell.org/ghc/ghc/-/issues/24682
+             makeAbsolute ghc
 
 
 

lib/GHCup/Prelude/File/Search.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DataKinds             #-}
 
 module GHCup.Prelude.File.Search (
   module GHCup.Prelude.File.Search
   , ProcessError(..)
   , CapturedProcess(..)
   ) where
 
+import           GHCup.Prelude.Internal ((!?))
 import           GHCup.Types(ProcessError(..), CapturedProcess(..))
 
 import           Control.Monad.Reader
@@ -19,6 +21,7 @@ import           System.Directory hiding ( removeDirectory
                                          , removeDirectoryRecursive
                                          , removePathForcibly
                                          , findFiles
+                                         , makeAbsolute
                                          )
 import           System.FilePath
 import           Text.Regex.Posix
@@ -28,8 +31,15 @@ import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
 import Control.Exception.Safe (handleIO)
 import System.Directory.Internal.Prelude (ioeGetErrorType)
+import Haskus.Utils.Variant.Excepts (Excepts)
+import GHCup.Errors (NotFoundInPATH(..))
 
 
+makeAbsolute :: MonadIO m => FilePath -> Excepts '[NotFoundInPATH] m FilePath
+makeAbsolute bin = do
+  spaths <- liftIO getSearchPath
+  liftIO (searchPath spaths bin) !? NotFoundInPATH bin
+
 
 -- | Search for a file in the search paths.
 --

lib/GHCup/Utils/Dirs.hs

@@ -143,6 +143,7 @@ import           System.Directory hiding ( removeDirectory
                                          , removeDirectoryRecursive
                                          , removePathForcibly
                                          , findFiles
+                                         , makeAbsolute
                                          )
 import qualified System.Directory              as SD
 

test/optparse-test/CompileTest.hs

@@ -31,6 +31,7 @@ mkDefaultGHCCompileOptions target boot =
     boot
     Nothing
     Nothing
+    Nothing
     (Just $ Right [])
     Nothing
     []
@@ -96,6 +97,7 @@ compileGhcCheckList = mapSecond CompileGHC
   , (baseCmd <> "-f make", baseOptions{GHC.buildFlavour = Just "make"})
   , (baseCmd <> "--flavour make", baseOptions{GHC.buildFlavour = Just "make"})
   , (baseCmd <> "--hadrian", baseOptions{GHC.buildSystem = Just Hadrian})
+  , (baseCmd <> "--hadrian --hadrian-ghc 9.2.8", baseOptions{GHC.buildSystem = Just Hadrian, GHC.hadrianGhc = Just (Left $(versionQ "9.2.8"))})
   , (baseCmd <> "--make", baseOptions{GHC.buildSystem = Just Make})
 #ifdef IS_WINDOWS
   , (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{GHC.isolateDir = Just "C:\\tmp\\out_dir"})