Beef up --overwrite-version, fixes #998

2024-02-17 23:12:56 +08:00
parent 2fdf896fbd
commit a3867484cc
8 changed files with 163 additions and 60 deletions
--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@@ -807,7 +807,7 @@ compileGHC :: ( MonadMask m
              )
           => GHCVer
           -> Maybe Text               -- ^ cross target
-           -> Maybe Version            -- ^ overwrite version
+           -> Maybe [VersionPattern]
           -> Either Version FilePath  -- ^ version to bootstrap with
           -> Maybe Int                -- ^ jobs
           -> Maybe FilePath           -- ^ build config
@@ -843,12 +843,12 @@ compileGHC :: ( MonadMask m
                 ]
                m
                GHCTargetVersion
-compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
+compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
  = do
    pfreq@PlatformRequest { .. } <- lift getPlatformReq
    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo

-    (workdir, tmpUnpack, tver) <- case targetGhc of
+    (workdir, tmpUnpack, tver, ov) <- case targetGhc of
      -- unpack from version tarball
      SourceDist ver -> do
        lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap
@@ -870,7 +870,11 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
                         (view dlSubdir dlInfo)
        liftE $ applyAnyPatch patches (fromGHCupPath workdir)

-        pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver))
+        ov <- case vps of
+                Just vps' -> fmap Just $ expandVersionPattern (Just ver) "" "" "" "" vps'
+                Nothing   -> pure Nothing
+
+        pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver), ov)

      RemoteDist uri -> do
        lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
@@ -894,13 +898,17 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build

        let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)

-        pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
+        ov <- case vps of
+                Just vps' -> fmap Just $ expandVersionPattern tver "" "" "" "" vps'
+                Nothing   -> pure Nothing
+
+        pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver, ov)

      -- clone from git
      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, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
+        (tver, ov) <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
          let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
          lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
          lEM $ git [ "init" ]
@@ -932,6 +940,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
                          then pure Nothing
                          else fmap Just $ liftE $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
          chash <- liftE $ gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
+          branch <- liftE $ gitOut ["rev-parse", "--abbrev-ref", "HEAD" ] (fromGHCupPath tmpUnpack)

          -- clone submodules
          lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
@@ -949,9 +958,19 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
                           (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)
          liftIO $ threadDelay 5000000 -- give the user a sec to intervene

-          pure tver
+          ov <- case vps of
+                  Just vps' -> fmap Just $ expandVersionPattern
+                                             tver
+                                             (take 7 $ T.unpack chash)
+                                             (T.unpack chash)
+                                             (maybe "" T.unpack git_describe)
+                                             (T.unpack branch)
+                                             vps'
+                  Nothing -> pure Nothing

-        pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
+          pure (tver, ov)
+
+        pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver, ov)
    -- the version that's installed may differ from the
    -- compiled version, so the user can overwrite it
    installVer <- if | Just ov'   <- ov   -> pure (GHCTargetVersion crossTarget ov')
@@ -1091,7 +1110,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
  compileHadrianBindist tver workdir ghcdir = do
    liftE $ configureBindist tver workdir ghcdir

-    lift $ logInfo "Building (this may take a while)..."
+    lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..."
    hadrian_build <- liftE $ findHadrianFile workdir
    lEM $ execLogged hadrian_build
                          ( maybe [] (\j  -> ["-j" <> show j]         ) jobs
@@ -1163,7 +1182,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build

    liftE $ checkBuildConfig (build_mk workdir)

-    lift $ logInfo "Building (this may take a while)..."
+    lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..."
    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)

    if | isCross tver -> do
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@@ -335,7 +335,7 @@ compileHLS :: ( MonadMask m
           => HLSVer
           -> [Version]
           -> Maybe Int
-           -> Either Bool Version
+           -> Maybe [VersionPattern]
           -> InstallDir
           -> Maybe (Either FilePath URI)
           -> Maybe URI
@@ -353,7 +353,7 @@ compileHLS :: ( MonadMask m
                       , BuildFailed
                       , NotInstalled
                       ] m Version
-compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
+compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
  pfreq@PlatformRequest { .. } <- lift getPlatformReq
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
  Dirs { .. } <- lift getDirs
@@ -362,7 +362,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
    lift $ logInfo "Updating cabal DB"
    lEM $ exec "cabal" ["update"] (Just $ fromGHCupPath tmpDir) Nothing

-  (workdir, tmpUnpack, tver, git_describe) <- case targetHLS of
+  (workdir, tmpUnpack, tver, ov) <- case targetHLS of
    -- unpack from version tarball
    SourceDist tver -> do
      lift $ logDebug $ "Requested to compile: " <> prettyVer tver
@@ -382,7 +382,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
                       (liftE . intoSubdir tmpUnpack)
                       (view dlSubdir dlInfo)

-      pure (workdir, tmpUnpack, tver, Nothing)
+      ov <- case vps of
+              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
+              Nothing   -> pure Nothing
+
+      pure (workdir, tmpUnpack, tver, ov)

    HackageDist tver -> do
      lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver
@@ -396,7 +400,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda

      let workdir = appendGHCupPath tmpUnpack hls

-      pure (workdir, tmpUnpack, tver, Nothing)
+      ov <- case vps of
+              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
+              Nothing   -> pure Nothing
+
+      pure (workdir, tmpUnpack, tver, ov)

    RemoteDist uri -> do
      lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
@@ -419,7 +427,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda

      let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)

-      pure (workdir, tmpUnpack, tver, Nothing)
+      ov <- case vps of
+              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
+              Nothing   -> pure Nothing
+
+      pure (workdir, tmpUnpack, tver, ov)

    -- clone from git
    GitDist GitBranch{..} -> do
@@ -459,28 +471,31 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
                        then pure Nothing
                        else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
        chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
+        branch <- gitOut ["rev-parse", "--abbrev-ref", "HEAD" ] (fromGHCupPath tmpUnpack)
        tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")

        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
+
+        ov <- case vps of
+                Just vps' -> fmap Just $ expandVersionPattern
+                                           (Just tver)
+                                           (take 7 $ T.unpack chash)
+                                           (T.unpack chash)
+                                           (maybe "" T.unpack git_describe)
+                                           (T.unpack branch)
+                                           vps'
+                Nothing -> pure Nothing
+
        lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
                                    "HLS version (from cabal file): " <> prettyVer tver <>
+                                    "\n  branch: " <> branch <>
                                    (if not shallow_clone then "\n  " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
                                    (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)
-
-        pure (tmpUnpack, tmpUnpack, tver, git_describe)
+        pure (tmpUnpack, tmpUnpack, tver, ov)

  -- the version that's installed may differ from the
  -- compiled version, so the user can overwrite it
-  installVer <- case ov of
-                  Left True -> case git_describe of
-                                 -- git describe
-                                 Just h -> either (fail . displayException) pure . version $ h
-                                 -- git describe, but not building from git, lol
-                                 Nothing -> pure tver
-                  -- default: use detected version
-                  Left False -> pure tver
-                  -- overwrite version with users value
-                  Right v -> pure v
+  installVer <- maybe (pure tver) pure ov

  liftE $ runBuildAction
    tmpUnpack
@@ -558,9 +573,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda

  pure installVer
 where
-  gitDescribeRequested = case ov of
-                           Left b -> b
-                           _      -> False
+  gitDescribeRequested = maybe False (GitDescribe `elem`) vps


    -----------------
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -777,3 +777,13 @@ instance Pretty ToolVersion where
 data BuildSystem = Hadrian
                 | Make
  deriving (Show, Eq)
+
+
+data VersionPattern = CabalVer
+                    | GitHashShort
+                    | GitHashLong
+                    | GitDescribe
+                    | GitBranchName
+                    | S String
+  deriving (Eq, Show)
+
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -1275,3 +1275,29 @@ processBranches str' = let lines'   = lines (T.unpack str')
                           branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
                       in branches

+
+
+    ------------------
+    --[ Versioning ]--
+    ------------------
+
+
+expandVersionPattern :: MonadFail m
+                     => Maybe Version  -- ^ cabal ver
+                     -> String         -- ^ git hash (short), if any
+                     -> String         -- ^ git hash (long), if any
+                     -> String         -- ^ git describe output, if any
+                     -> String         -- ^ git branch name, if any
+                     -> [VersionPattern]
+                     -> m Version
+expandVersionPattern cabalVer gitHashS gitHashL gitDescribe gitBranch
+  = either (fail . displayException) pure . version . T.pack . go
+ where
+  go [] = ""
+  go (CabalVer:xs) = T.unpack (maybe "" prettyVer cabalVer) <> go xs
+  go (GitHashShort:xs) = gitHashS <> go xs
+  go (GitHashLong:xs) = gitHashL <> go xs
+  go (GitDescribe:xs) = gitDescribe <> go xs
+  go (GitBranchName:xs) = gitBranch <> go xs
+  go (S str:xs) = str <> go xs
+