Allow to use Hadrian as build system, fixes #35

2021-07-20 21:45:24 +02:00 · 2021-07-20 21:45:24 +02:00 · a4a7f73fb7
commit a4a7f73fb7
parent 9e181b8820
6 changed files with 315 additions and 107 deletions
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@ -281,11 +281,31 @@ test:linux:cross-armv7:
    CROSS: "arm-linux-gnueabihf"
  needs: []
  when: manual
+  allow_failure: true
  before_script:
    - ./.gitlab/before_script/linux/install_deps.sh
  script:
    - ./.gitlab/script/ghcup_cross.sh

+test:linux:git:hadrian:
+  stage: test
+  extends:
+    - .test_ghcup_version
+    - .debian
+  variables:
+    GHC_VERSION: "8.10.5"
+    GHC_GIT_TAG: "ghc-9.0.1-release"
+    GHC_GIT_VERSION: "9.0.1"
+    CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
+  needs: []
+  when: manual
+  allow_failure: true
+  before_script:
+    - ./.gitlab/before_script/linux/install_deps.sh
+  script:
+    - ./.gitlab/script/ghcup_git.sh
+

 ######## linux 32bit test ########

--- a/.gitlab/script/ghcup_git.sh
+++ b/.gitlab/script/ghcup_git.sh
@ -0,0 +1,52 @@
+#!/bin/sh
+
+set -eux
+
+. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
+
+mkdir -p "$CI_PROJECT_DIR"/.local/bin
+
+CI_PROJECT_DIR=$(pwd)
+
+ecabal() {
+	cabal "$@"
+}
+
+eghcup() {
+	ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
+}
+
+git describe --always
+
+### build
+
+ecabal update
+
+ecabal build -w ghc-${GHC_VERSION}
+cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
+
+### cleanup
+
+rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
+
+### manual cli based testing
+
+eghcup --numeric-version
+
+eghcup install ghc ${GHC_VERSION}
+eghcup set ghc ${GHC_VERSION}
+eghcup install cabal ${CABAL_VERSION}
+
+cabal --version
+
+eghcup debug-info
+
+eghcup compile ghc -j $(nproc) -g ${GHC_GIT_TAG} -b ${GHC_VERSION} -- --enable-unregisterised
+eghcup set ghc ${GHC_GIT_VERSION}
+
+[ `$(eghcup whereis ghc ${GHC_GIT_VERSION}) --numeric-version` = "${GHC_GIT_VERSION}" ]
+
+# nuke
+eghcup nuke
+[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
+
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -183,6 +183,7 @@ data GHCCompileOptions = GHCCompileOptions
  , setCompile   :: Bool
  , ovewrwiteVer :: Maybe Version
  , buildFlavour :: Maybe String
+  , hadrian      :: Bool
  }

 data UpgradeOpts = UpgradeInplace
@ -995,6 +996,9 @@ ghcCompileOpts =
              "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
            )
          )
+    <*> switch
+          (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
+          )


 toolVersionParser :: Parser ToolVersion
@ -1914,6 +1918,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 8

+            Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
+              runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
+              pure $ ExitFailure 9
            Compile (CompileGHC GHCCompileOptions {..}) ->
              runCompileGHC (do
                case targetGhc of
@ -1935,6 +1942,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                            patchDir
                            addConfArgs
                            buildFlavour
+                            hadrian
                GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                when setCompile $ void $ liftE $
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -1672,6 +1672,7 @@ compileGHC :: ( MonadMask m
           -> Maybe FilePath           -- ^ patch directory
           -> [Text]                   -- ^ additional args to ./configure
           -> Maybe String             -- ^ build flavour
+           -> Bool
           -> Excepts
                '[ AlreadyInstalled
                 , BuildFailed
@ -1690,7 +1691,7 @@ compileGHC :: ( MonadMask m
                 ]
                m
                GHCTargetVersion
-compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour
+compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
  = do
    PlatformRequest { .. } <- lift getPlatformReq
    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -1775,8 +1776,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour
      tmpUnpack
      Nothing
      (do
-        b <- compileBindist bghc tver workdir ghcdir
-        bmk <- liftIO $ B.readFile (build_mk workdir)
+        b <- if hadrian
+             then compileHadrianBindist bghc tver workdir ghcdir
+             else compileMakeBindist bghc tver workdir ghcdir
+        bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
        pure (b, bmk)
      )

@ -1821,31 +1824,224 @@ ifneq "$(BuildFlavour)" ""
 include mk/flavours/$(BuildFlavour).mk
 endif|]

-  compileBindist :: ( MonadReader env m
-                    , HasDirs env
-                    , HasSettings env
-                    , HasPlatformReq env
-                    , MonadThrow m
-                    , MonadCatch m
-                    , MonadLogger m
-                    , MonadIO m
-                    , MonadFail m
-                    )
-                 => Either FilePath FilePath
-                 -> GHCTargetVersion
-                 -> FilePath
-                 -> FilePath
-                 -> Excepts
-                      '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
-                      m
-                      (Maybe FilePath)  -- ^ output path of bindist, None for cross
-  compileBindist bghc tver workdir ghcdir = do
-    lift $ $(logInfo) [i|configuring build|]
-    
+  compileHadrianBindist :: ( MonadReader env m
+                           , HasDirs env
+                           , HasSettings env
+                           , HasPlatformReq env
+                           , MonadThrow m
+                           , MonadCatch m
+                           , MonadLogger m
+                           , MonadIO m
+                           , MonadFail m
+                           )
+                        => Either FilePath FilePath
+                        -> GHCTargetVersion
+                        -> FilePath
+                        -> FilePath
+                        -> Excepts
+                             '[ FileDoesNotExistError
+                              , HadrianNotFound
+                              , InvalidBuildConfig
+                              , PatchFailed
+                              , ProcessError
+                              , NotFoundInPATH
+                              , CopyError]
+                             m
+                             (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileHadrianBindist bghc tver workdir ghcdir = do
+    lEM $ execLogged "python3" ["./boot"] (Just workdir) "ghc-bootstrap" Nothing
+
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    hadrian_build <- liftE $ findHadrianFile workdir
+    lEM $ execLogged hadrian_build
+                          ( maybe [] (\j  -> [[i|-j#{j}|]]         ) jobs
+                         ++ maybe [] (\bf -> [[i|--flavour=#{bf}|]]) buildFlavour
+                         ++ ["binary-dist"]
+                          )
+                          (Just workdir) "ghc-make" Nothing
+    [tar] <- liftIO $ findFiles
+      (workdir </> "_build" </> "bindist")
+      (makeRegexOpts compExtended
+                     execBlank
+                     ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+      )
+    liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")
+
+  findHadrianFile :: (MonadIO m)
+                  => FilePath
+                  -> Excepts
+                       '[HadrianNotFound]
+                       m
+                       FilePath
+  findHadrianFile workdir = do
+#if defined(IS_WINDOWS)
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
+#else   
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
+#endif
+    exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
+    case filter fst exsists of
+      [] -> throwE HadrianNotFound
+      ((_, x):_) -> pure x
+
+  compileMakeBindist :: ( MonadReader env m
+                        , HasDirs env
+                        , HasSettings env
+                        , HasPlatformReq env
+                        , MonadThrow m
+                        , MonadCatch m
+                        , MonadLogger m
+                        , MonadIO m
+                        , MonadFail m
+                        )
+                     => Either FilePath FilePath
+                     -> GHCTargetVersion
+                     -> FilePath
+                     -> FilePath
+                     -> Excepts
+                          '[ FileDoesNotExistError
+                           , HadrianNotFound
+                           , InvalidBuildConfig
+                           , PatchFailed
+                           , ProcessError
+                           , NotFoundInPATH
+                           , CopyError]
+                          m
+                       (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileMakeBindist bghc tver workdir ghcdir = do
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    case mbuildConfig of
+      Just bc -> liftIOException
+        doesNotExistErrorType
+        (FileDoesNotExistError bc)
+        (liftIO $ copyFile bc (build_mk workdir))
+      Nothing ->
+        liftIO $ B.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
+
+    liftE $ checkBuildConfig (build_mk workdir)
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
+
+    if | isCross tver -> do
+          lift $ $(logInfo) [i|Installing cross toolchain...|]
+          lEM $ make ["install"] (Just workdir)
+          pure Nothing
+       | otherwise -> do
+          lift $ $(logInfo) [i|Creating bindist...|]
+          lEM $ make ["binary-dist"] (Just workdir)
+          [tar] <- liftIO $ findFiles
+            workdir
+            (makeRegexOpts compExtended
+                           execBlank
+                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+            )
+          liftE $ fmap Just $ copyBindist tver tar workdir
+
+  build_mk workdir = workdir </> "mk" </> "build.mk"
+
+  copyBindist :: ( MonadReader env m
+                 , HasDirs env
+                 , HasSettings env
+                 , HasPlatformReq env
+                 , MonadIO m
+                 , MonadThrow m
+                 , MonadCatch m
+                 , MonadLogger m
+                 )
+              => GHCTargetVersion
+              -> FilePath           -- ^ tar file
+              -> FilePath           -- ^ workdir
+              -> Excepts
+                   '[CopyError]
+                   m
+                   FilePath
+  copyBindist tver tar workdir = do
    Dirs {..} <- lift getDirs
    pfreq <- lift getPlatformReq
+    c       <- liftIO $ BL.readFile (workdir </> tar)
+    cDigest <-
+      fmap (T.take 8)
+      . lift
+      . throwEither
+      . E.decodeUtf8'
+      . B16.encode
+      . SHA256.hashlazy
+      $ c
+    cTime <- liftIO getCurrentTime
+    let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
+    let tarPath = cacheDir </> tarName
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
+                                                             tarPath
+    lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
+    pure tarPath

-    forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
+  checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
+                   => FilePath
+                   -> Excepts
+                        '[FileDoesNotExistError, InvalidBuildConfig]
+                        m
+                        ()
+  checkBuildConfig bc = do
+    c <- liftIOException
+           doesNotExistErrorType
+           (FileDoesNotExistError bc)
+           (liftIO $ B.readFile bc)
+    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
+
+   -- for cross, we need Stage1Only
+    case targetGhc of
+      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
+        (InvalidBuildConfig
+          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
+        )
+      _ -> pure ()
+
+    forM_ buildFlavour $ \bf ->
+      when ([i|BuildFlavour = #{bf}|] `notElem` lines') $ do
+        lift $ $(logWarn) [i|Customly specified build config overwrites --flavour=#{bf} switch! Waiting 5 seconds...|]
+        liftIO $ threadDelay 5000000
+
+  addBuildFlavourToConf bc = case buildFlavour of
+    Just bf -> [i|BuildFlavour = #{bf}|] <> [s|
+|] <> [i|#{bc}|]
+    Nothing -> bc
+
+  isCross :: GHCTargetVersion -> Bool
+  isCross = isJust . _tvTarget
+
+
+  configureBindist :: ( MonadReader env m
+                      , HasDirs env
+                      , HasSettings env
+                      , HasPlatformReq env
+                      , MonadThrow m
+                      , MonadCatch m
+                      , MonadLogger m
+                      , MonadIO m
+                      , MonadFail m
+                      )
+                   => Either FilePath FilePath
+                   -> GHCTargetVersion
+                   -> FilePath
+                   -> FilePath
+                   -> Excepts
+                        '[ FileDoesNotExistError
+                         , InvalidBuildConfig
+                         , PatchFailed
+                         , ProcessError
+                         , NotFoundInPATH
+                         , CopyError
+                         ]
+                        m
+                        ()
+  configureBindist bghc tver workdir ghcdir = do
+    lift $ $(logInfo) [s|configuring build|]
+    
+    forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)

    cEnv <- liftIO getEnvironment

@ -1886,85 +2082,9 @@ endif|]
          (Just workdir)
          "ghc-conf"
          (Just cEnv)
+    pure ()

-    case mbuildConfig of
-      Just bc -> liftIOException
-        doesNotExistErrorType
-        (FileDoesNotExistError bc)
-        (liftIO $ copyFile bc (build_mk workdir))
-      Nothing ->
-        liftIO $ B.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)

-    liftE $ checkBuildConfig (build_mk workdir)
-
-    lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
-
-    if | isCross tver -> do
-          lift $ $(logInfo) [i|Installing cross toolchain...|]
-          lEM $ make ["install"] (Just workdir)
-          pure Nothing
-       | otherwise -> do
-          lift $ $(logInfo) [i|Creating bindist...|]
-          lEM $ make ["binary-dist"] (Just workdir)
-          [tar] <- liftIO $ findFiles
-            workdir
-            (makeRegexOpts compExtended
-                           execBlank
-                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
-            )
-          c       <- liftIO $ BL.readFile (workdir </> tar)
-          cDigest <-
-            fmap (T.take 8)
-            . lift
-            . throwEither
-            . E.decodeUtf8'
-            . B16.encode
-            . SHA256.hashlazy
-            $ c
-          cTime <- liftIO getCurrentTime
-          let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
-          let tarPath = cacheDir </> tarName
-          handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
-                                                                   tarPath
-          lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
-          pure $ Just tarPath
-
-  build_mk workdir = workdir </> "mk" </> "build.mk"
-
-  checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
-                   => FilePath
-                   -> Excepts
-                        '[FileDoesNotExistError, InvalidBuildConfig]
-                        m
-                        ()
-  checkBuildConfig bc = do
-    c <- liftIOException
-           doesNotExistErrorType
-           (FileDoesNotExistError bc)
-           (liftIO $ B.readFile bc)
-    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-
-   -- for cross, we need Stage1Only
-    case targetGhc of
-      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
-        (InvalidBuildConfig
-          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
-        )
-      _ -> pure ()
-
-    forM_ buildFlavour $ \bf ->
-      when ([i|BuildFlavour = #{bf}|] `notElem` lines') $ do
-        lift $ $(logWarn) [i|Customly specified build config overwrites --flavour=#{bf} switch! Waiting 5 seconds...|]
-        liftIO $ threadDelay 5000000
-
-  addBuildFlavourToConf bc = case buildFlavour of
-    Just bf -> [i|BuildFlavour = #{bf}
-#{bc}|]
-    Nothing -> bc
-
-  isCross :: GHCTargetVersion -> Bool
-  isCross = isJust . _tvTarget



--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@ -31,8 +31,8 @@ import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Haskus.Utils.Variant
-import           Text.PrettyPrint
-import           Text.PrettyPrint.HughesPJClass
+import           Text.PrettyPrint               hiding ( (<>) )
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           URI.ByteString


@ -240,6 +240,13 @@ instance Pretty NoNetwork where
  pPrint NoNetwork =
    text [i|A download was required or requested, but '--offline' was specified.|]

+data HadrianNotFound = HadrianNotFound
+  deriving Show
+
+instance Pretty HadrianNotFound where
+  pPrint HadrianNotFound =
+    text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
+

    -------------------------
    --[ High-level errors ]--
@ -256,11 +263,11 @@ deriving instance Show DownloadFailed


 -- | A build failed.
-data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

 instance Pretty BuildFailed where
  pPrint (BuildFailed path reason) =
-    text [i|BuildFailed failed in dir "#{path}": #{reason}|]
+    text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason

 deriving instance Show BuildFailed

--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -78,6 +78,7 @@ import           System.Win32.Console
 import           System.Win32.File     hiding ( copyFile )
 import           System.Win32.Types
 #endif
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 import           URI.ByteString

@ -882,7 +883,7 @@ getChangeLog dls tool (Right tag) =
 --
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
-runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
+runBuildAction :: (Pretty (V e), Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
               => FilePath          -- ^ build directory (cleaned up depending on Settings)
               -> Maybe FilePath  -- ^ dir to *always* clean up on exception
               -> Excepts e m a