Allow to build from arbitrary GHC source dists

2022-07-09 23:12:00 +02:00 · 2022-07-09 23:12:00 +02:00 · 9fb2889696
commit 9fb2889696
parent 63f22b28d7
7 changed files with 99 additions and 43 deletions
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@ -12,6 +12,8 @@ module GHCup.OptParse.Compile where


 import           GHCup
+import qualified GHCup.GHC as GHC
+import qualified GHCup.HLS as HLS
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
@ -64,7 +66,7 @@ data CompileCommand = CompileGHC GHCCompileOptions


 data GHCCompileOptions = GHCCompileOptions
-  { targetGhc    :: Either Version GitBranch
+  { targetGhc    :: GHC.GHCVer Version
  , bootstrapGhc :: Either Version FilePath
  , jobs         :: Maybe Int
  , buildConfig  :: Maybe FilePath
@ -80,7 +82,7 @@ data GHCCompileOptions = GHCCompileOptions


 data HLSCompileOptions = HLSCompileOptions
-  { targetHLS    :: HLSVer
+  { targetHLS    :: HLS.HLSVer
  , jobs         :: Maybe Int
  , setCompile   :: Bool
  , ovewrwiteVer :: Either Bool Version
@ -163,7 +165,7 @@ Examples:
 ghcCompileOpts :: Parser GHCCompileOptions
 ghcCompileOpts =
  GHCCompileOptions
-    <$> ((Left <$> option
+    <$> ((GHC.SourceDist <$> option
          (eitherReader
            (first (const "Not a valid version") . version . T.pack)
          )
@ -172,7 +174,7 @@ ghcCompileOpts =
            <> (completer $ versionCompleter Nothing GHC)
          )
          ) <|>
-          (Right <$> (GitBranch <$> option
+          (GHC.GitDist <$> (GitBranch <$> option
          str
          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
            "The git commit/branch/ref to build from"
@ -181,7 +183,18 @@ ghcCompileOpts =
            short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
            <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
            ))
-          )))
+          ))
+          <|>
+          (
+           GHC.RemoteDist <$> (option
+            (eitherReader uriParser)
+            (long "remote-source-dist" <> metavar "URI" <> help
+              "URI (https/http/file) to a GHC source distribution"
+              <> completer fileUri
+            )
+          )
+          )
+          )
    <*> option
          (eitherReader
            (\x ->
@ -273,7 +286,7 @@ ghcCompileOpts =
 hlsCompileOpts :: Parser HLSCompileOptions
 hlsCompileOpts =
  HLSCompileOptions
-    <$> ((SourceDist <$> option
+    <$> ((HLS.SourceDist <$> option
          (eitherReader
            (first (const "Not a valid version") . version . T.pack)
          )
@ -283,7 +296,7 @@ hlsCompileOpts =
          )
          )
          <|>
-          (GitDist <$> (GitBranch <$> option
+          (HLS.GitDist <$> (GitBranch <$> option
          str
          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
            "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
@ -293,7 +306,7 @@ hlsCompileOpts =
          ))
          ))
          <|>
-          (HackageDist <$> (option
+          (HLS.HackageDist <$> (option
            (eitherReader
              (first (const "Not a valid version") . version . T.pack)
            )
@ -304,7 +317,7 @@ hlsCompileOpts =
          ))
          <|>
          (
-           RemoteDist <$> (option
+           HLS.RemoteDist <$> (option
            (eitherReader uriParser)
            (long "remote-source-dist" <> metavar "URI" <> help
              "URI (https/http/file) to a HLS source distribution"
@ -493,7 +506,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
    (CompileHLS HLSCompileOptions { .. }) -> do
      runCompileHLS runAppState (do
        case targetHLS of
-          SourceDist targetVer -> do
+          HLS.SourceDist targetVer -> do
            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
            let vi = getVersionInfo targetVer HLS dls
            forM_ (_viPreCompile =<< vi) $ \msg -> do
@ -544,7 +557,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
    (CompileGHC GHCCompileOptions {..}) ->
      runCompileGHC runAppState (do
        case targetGhc of
-          Left targetVer -> do
+          GHC.SourceDist targetVer -> do
            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
            let vi = getVersionInfo targetVer GHC dls
            forM_ (_viPreCompile =<< vi) $ \msg -> do
@ -552,9 +565,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
              lift $ logInfo
                "...waiting for 5 seconds, you can still abort..."
              liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
-          Right _ -> pure ()
+          _ -> pure ()
        targetVer <- liftE $ compileGHC
-                    (first (GHCTargetVersion crossTarget) targetGhc)
+                    ((\case
+                        GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
+                        GHC.GitDist g -> GHC.GitDist g
+                        GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
                    ovewrwiteVer
                    bootstrapGhc
                    jobs
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -14,6 +14,8 @@ module Main where
 import           BrickMain                    ( brickMain )
 #endif

+import qualified GHCup.GHC as GHC
+import qualified GHCup.HLS as HLS
 import           GHCup.OptParse

 import           GHCup.Download
@ -338,13 +340,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver) = cmp' Stack instVer ver
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
-  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
+  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = SourceDist tver }))
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HackageDist tver }))
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
  alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
  alreadyInstalling _ _ = pure False
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -33,8 +33,8 @@ module GHCup (


 import           GHCup.Cabal
-import           GHCup.GHC
-import           GHCup.HLS
+import           GHCup.GHC             hiding ( GHCVer(..) )
+import           GHCup.HLS             hiding ( HLSVer(..) )
 import           GHCup.Stack
 import           GHCup.List
 import           GHCup.Download
--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@ -80,6 +80,12 @@ import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP


+data GHCVer v = SourceDist v
+              | GitDist GitBranch
+              | RemoteDist URI
+
+
+
    ---------------------
    --[ Tool fetching ]--
    ---------------------
@ -607,7 +613,7 @@ compileGHC :: ( MonadMask m
              , MonadUnliftIO m
              , MonadFail m
              )
-           => Either GHCTargetVersion GitBranch          -- ^ version to install
+           => GHCVer GHCTargetVersion
           -> Maybe Version            -- ^ overwrite version
           -> Either Version FilePath  -- ^ version to bootstrap with
           -> Maybe Int                -- ^ jobs
@ -650,7 +656,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr

    (workdir, tmpUnpack, tver) <- case targetGhc of
      -- unpack from version tarball
-      Left tver -> do
+      SourceDist tver -> do
        lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap

        -- download source tarball
@ -671,8 +677,31 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr

        pure (workdir, tmpUnpack, tver)

+      RemoteDist uri -> do
+        lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
+
+        -- download source tarball
+        tmpDownload <- lift withGHCupTmpDir
+        tmpUnpack <- lift mkGhcupTmpDir
+        tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
+        (bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do
+          liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar
+          let regex = [s|^(.*/)*boot$|] :: B.ByteString
+          [bootFile] <- liftIO $ findFilesDeep
+            tmpUnpack
+            (makeRegexOpts compExtended
+                           execBlank
+                           regex
+            )
+          tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile))
+          pure (bootFile, tver)
+
+        let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
+
+        pure (workdir, tmpUnpack, mkTVer tver)
+
      -- clone from git
-      Right GitBranch{..} -> do
+      GitDist GitBranch{..} -> do
        tmpUnpack <- lift mkGhcupTmpDir
        let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
@ -715,14 +744,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
          liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)

          -- bootstrap
-          lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
-          lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
-          CapturedProcess {..} <- lift $ makeOut
-            ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
-          tver <- case _exitCode of
-            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
-            ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
-
+          tver <- liftE $ getGHCVer tmpUnpack
          liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
          lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
                           "GHC version (from Makefile): " <> prettyVer tver <>
@ -795,11 +817,29 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
    pure installVer

 where
+  getGHCVer :: ( MonadReader env m
+               , HasSettings env
+               , HasDirs env
+               , HasLog env
+               , MonadIO m
+               , MonadThrow m
+               )
+            => GHCupPath
+            -> Excepts '[ProcessError] m Version
+  getGHCVer tmpUnpack = do
+    lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
+    lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
+    CapturedProcess {..} <- lift $ makeOut
+      ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
+    case _exitCode of
+      ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
+      ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
+
  defaultConf =
    let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
        default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
    in case targetGhc of
-         Left (GHCTargetVersion (Just _) _) -> cross_mk
+         SourceDist (GHCTargetVersion (Just _) _) -> cross_mk
         _ -> default_mk

  compileHadrianBindist :: ( MonadReader env m
@ -976,7 +1016,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr

   -- for cross, we need Stage1Only
    case targetGhc of
-      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
+      SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
        (InvalidBuildConfig
          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
        )
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@ -71,6 +71,12 @@ import qualified Text.Megaparsec               as MP
 import Text.PrettyPrint.HughesPJClass (prettyShow)


+data HLSVer = SourceDist Version
+            | GitDist GitBranch
+            | HackageDist Version
+            | RemoteDist URI
+
+

    --------------------
    --[ Installation ]--
@ -394,8 +400,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
      tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
      (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
        unpackToDir (fromGHCupPath tmpUnpack) tar
-        let regex = [s|haskell-language-server\.cabal$|] :: B.ByteString
-        [cabalFile] <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
+        let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
+        [cabalFile] <- liftIO $ findFilesDeep
          tmpUnpack
          (makeRegexOpts compExtended
                         execBlank
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -654,12 +654,3 @@ isSafeDir (IsolateDirResolved _) = False
 isSafeDir (GHCupDir _)           = True
 isSafeDir (GHCupBinDir _)        = False

-
-
-
-data HLSVer = SourceDist Version
-            | GitDist GitBranch
-            | HackageDist Version
-            | RemoteDist URI
-
-
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -1097,7 +1097,8 @@ runBuildAction bdir action = do

 -- | Clean up the given directory if the action fails,
 -- depending on the Settings.
-cleanUpOnError :: ( MonadReader env m
+cleanUpOnError :: forall e m a env .
+                  ( MonadReader env m
                  , HasDirs env
                  , HasSettings env
                  , MonadIO m