Beef up --overwrite-version, fixes #998

2024-02-17 23:12:56 +08:00 · 2024-02-17 23:12:56 +08:00 · bdd15ad6e7
parent 2fdf896fbd
commit bdd15ad6e7
10 changed files with 175 additions and 65 deletions
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -41,6 +41,7 @@ import           Data.Aeson                     ( decodeStrict', Value )
 import           Data.Aeson.Encode.Pretty       ( encodePretty )
 import           Data.Either
 import           Data.Functor
+import           Data.Versions (version)
 import           Data.Maybe
 import           GHC.IO.Encoding
 import           Haskus.Utils.Variant.Excepts
@ -341,12 +342,14 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver)    = cmp' Cabal instVer ver
  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)      = cmp' HLS instVer ver
  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver)    = cmp' Stack instVer ver
-  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
-    (GHC, ver)   = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver
+  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ overwriteVer = Just [S over] })) (GHC, ver)
+    | Right over' <- version (T.pack over) = cmp' GHC (Just $ GHCVersion (mkTVer over')) ver
+    | otherwise = pure False
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion tver) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
-    (HLS, ver)   = cmp' HLS (Just $ ToolVersion over) ver
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ overwriteVer = Just [S over] })) (HLS, ver)
+    | Right over' <- version (T.pack over) = cmp' HLS (Just $ ToolVersion over') ver
+    | otherwise = pure False
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion tver) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))
--- a/lib-opt/GHCup/OptParse/Common.hs
+++ b/lib-opt/GHCup/OptParse/Common.hs
@ -17,7 +17,6 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.URI
 import           GHCup.Prelude
 import           GHCup.Prelude.Process
 import           GHCup.Prelude.Logger
@ -78,7 +77,6 @@ import qualified Cabal.Config            as CC
    --[ Types ]--
    -------------

-
 -- a superset of ToolVersion
 data SetToolVersion = SetGHCVersion GHCTargetVersion
                    | SetToolVersion Version
@ -314,6 +312,29 @@ gpgParser s' | t == T.pack "strict" = Right GPGStrict



+overWriteVersionParser :: String -> Either String [VersionPattern]
+overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack
+ where
+  versionPattern :: MP.Parsec Void Text VersionPattern
+  versionPattern = do
+    str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%')
+    if str' /= mempty
+    then pure (S str')
+    else     fmap (const CabalVer)      v_cabal
+         <|> fmap (const GitBranchName) b_name
+         <|> fmap (const GitHashShort)  s_hash
+         <|> fmap (const GitHashLong)   l_hash
+         <|> fmap (const GitDescribe)   g_desc
+         <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k"
+   where
+    v_cabal = MP.chunk "%v"
+    b_name  = MP.chunk "%b"
+    s_hash  = MP.chunk "%h"
+    l_hash  = MP.chunk "%H"
+    g_desc  = MP.chunk "%g"
+
+
+
    ------------------
    --[ Completers ]--
    ------------------
--- a/lib-opt/GHCup/OptParse/Compile.hs
+++ b/lib-opt/GHCup/OptParse/Compile.hs
@ -36,7 +36,7 @@ import qualified Data.Versions as V
 import           Data.Text                      ( Text )
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
-import           Options.Applicative.Help.Pretty ( text )
+import           Options.Applicative.Help.Pretty ( text, vsep )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit

@ -74,7 +74,7 @@ data GHCCompileOptions = GHCCompileOptions
  , crossTarget  :: Maybe Text
  , addConfArgs  :: [Text]
  , setCompile   :: Bool
-  , ovewrwiteVer :: Maybe Version
+  , overwriteVer :: Maybe [VersionPattern]
  , buildFlavour :: Maybe String
  , buildSystem  :: Maybe BuildSystem
  , isolateDir   :: Maybe FilePath
@ -86,7 +86,7 @@ data HLSCompileOptions = HLSCompileOptions
  , jobs         :: Maybe Int
  , setCompile   :: Bool
  , updateCabal  :: Bool
-  , ovewrwiteVer :: Either Bool Version
+  , overwriteVer :: Maybe [VersionPattern]
  , isolateDir   :: Maybe FilePath
  , cabalProject :: Maybe (Either FilePath URI)
  , cabalProjectLocal :: Maybe URI
@ -155,8 +155,8 @@ Examples:
 Examples:
  # compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build
  ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update
-  # compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state
-  ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
+  # compile from master for ghc 9.2.3, appending the short git commit hash to the version and ignore the pinned index state
+  ghcup compile hls -g master -o '%v-%h' --ghc 9.2.3 -- --index-state=@(date '+%s')
  # compile a specific commit for ghc 9.2.3 and set a specific version for the binary name
  ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]

@ -253,11 +253,16 @@ ghcCompileOpts =
    <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
    <*> optional
          (option
-            (eitherReader
-              (first (const "Not a valid version") . version . T.pack)
+            (eitherReader overWriteVersionParser
            )
-            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
-              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION"
+              <> helpDoc (Just $ vsep [ text "Overwrite the finally installed VERSION with a different one. Allows to specify patterns"
+                                      , text "%v  version"
+                                      , text "%b  branch name"
+                                      , text "%h  short commit hash"
+                                      , text "%H  long commit hash"
+                                      , text "%g  'git describe' output"
+                                      ])
            <> (completer $ versionCompleter [] GHC)
            )
          )
@ -343,19 +348,25 @@ hlsCompileOpts =
    <*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")
    <*>
         (
-          (Right <$> option
-            (eitherReader
-              (first (const "Not a valid version") . version . T.pack)
+          optional (option
+            (eitherReader overWriteVersionParser
            )
-            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
-              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION"
+              <> helpDoc (Just $ vsep [ text "Overwrite the finally installed VERSION with a different one. Allows to specify patterns"
+                                      , text "%v  version from cabal file"
+                                      , text "%b  branch name"
+                                      , text "%h  short commit hash"
+                                      , text "%H  long commit hash"
+                                      , text "%g  'git describe' output"
+                                      ])
            <> (completer $ versionCompleter [] HLS)
            )
          )
          <|>
-          (Left <$> (switch
+          ((\b -> if b then Just [GitDescribe] else Nothing) <$> (switch
                      (long "git-describe-version"
                         <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
+                         <> internal
                      )
                    )
          )
@ -529,7 +540,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                    targetHLS
                    ghcs
                    jobs
-                    ovewrwiteVer
+                    overwriteVer
                    (maybe GHCupInternal IsolateDir isolateDir)
                    cabalProject
                    cabalProjectLocal
@ -576,7 +587,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
        targetVer <- liftE $ compileGHC
                    targetGhc
                    crossTarget
-                    ovewrwiteVer
+                    overwriteVer
                    bootstrapGhc
                    jobs
                    buildConfig
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@ -92,6 +92,8 @@ import qualified Data.Yaml.Aeson               as Y



+-- $setup
+-- >>> :set -XOverloadedStrings



--- 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/Prelude/Internal.hs
+++ b/lib/GHCup/Prelude/Internal.hs
@ -57,12 +57,10 @@ import qualified Data.Text.Lazy.Encoding       as TLE

 -- $setup
 -- >>> import Data.ByteString.Internal (c2w, w2c)
-- >>> import Test.QuickCheck
 -- >>> import Data.Word8
 -- >>> import qualified Data.Text as T
 -- >>> import qualified Data.Char as C
 -- >>> import Data.List
-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary


 fS :: IsString a => String -> a
@ -299,7 +297,7 @@ escapeVerRex = B.pack . go . B.unpack . verToBS


 recover :: (MonadIO m, MonadMask m) => m a -> m a
-recover action = 
+recover action =
  recovering (fullJitterBackoff 25000 <> limitRetries 10)
    [\_ -> Handler (\e -> pure $ isPermissionError e)
    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
--- 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
@ -108,6 +108,7 @@ import Data.Time (Day(..), diffDays, addDays)
 -- >>> import GHCup.Errors
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
+-- >>> import Data.Versions
 -- >>> import Optics
 -- >>> import GHCup.Prelude.Version.QQ
 -- >>> import qualified Data.Text.Encoding as E
@ -120,8 +121,8 @@ import Data.Time (Day(..), diffDays, addDays)
 -- >>> let settings = defaultSettings { cache = True, metaCache = 0, noNetwork = True }
 -- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
 -- >>> cwd <- getCurrentDirectory
-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, ContentLengthError] $ liftE $ getBase ref
+-- >>> (Right ref) <- pure $ GHCup.Utils.parseURI $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
+-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, ContentLengthError] $ liftE (getBase ref) >>= liftE . decodeMetadata @GHCupInfo



@ -1275,3 +1276,33 @@ processBranches str' = let lines'   = lines (T.unpack str')
                           branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
                       in branches

+
+
+    ------------------
+    --[ Versioning ]--
+    ------------------
+
+
+-- | Expand a list of version patterns describing a string such as "%v-%h".
+--
+-- >>> expandVersionPattern (either (const Nothing) Just $ version "3.4.3") "a386748" "a3867484ccc391daad1a42002c3a2ba6a93c5221" "v0.1.20.0-119-ga386748" "issue-998" [CabalVer, S "-", GitHashShort, S "-", GitHashLong, S "-", GitBranchName, S "-", GitDescribe, S "-coco"]
+-- Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 3 :| [Numeric 4,Numeric 3]), _vRel = Just (Release (Alphanum "a386748-a3867484ccc391daad1a42002c3a2ba6a93c5221-issue-998-v0" :| [Numeric 1,Numeric 20,Alphanum "0-119-ga386748-coco"])), _vMeta = Nothing}
+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
+
--- a/test/optparse-test/CompileTest.hs
+++ b/test/optparse-test/CompileTest.hs
@ -47,7 +47,7 @@ mkDefaultHLSCompileOptions target ghcs =
    Nothing
    True
    False
-    (Left False)
+    Nothing
    Nothing
    Nothing
    Nothing
@ -91,8 +91,8 @@ compileGhcCheckList = mapSecond CompileGHC
  , (baseCmd <> "--cross-target armv7-unknown-linux-gnueabihf", baseOptions{GHC.crossTarget = Just "armv7-unknown-linux-gnueabihf"})
  , (baseCmd <> "-- --enable-unregisterised", baseOptions{GHC.addConfArgs = ["--enable-unregisterised"]})
  , (baseCmd <> "--set", baseOptions{GHC.setCompile = True})
-  , (baseCmd <> "-o 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $(versionQ "9.4.5-p1")})
-  , (baseCmd <> "--overwrite-version 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $(versionQ "9.4.5-p1")})
+  , (baseCmd <> "-o 9.4.5-p1", baseOptions{GHC.overwriteVer = Just [S "9.4.5-p1"]})
+  , (baseCmd <> "--overwrite-version 9.4.5-p1", baseOptions{GHC.overwriteVer = Just [S "9.4.5-p1"]})
  , (baseCmd <> "-f make", baseOptions{GHC.buildFlavour = Just "make"})
  , (baseCmd <> "--flavour make", baseOptions{GHC.buildFlavour = Just "make"})
  , (baseCmd <> "--hadrian", baseOptions{GHC.buildSystem = Just Hadrian})
@ -158,9 +158,11 @@ compileHlsCheckList = mapSecond CompileHLS
  , (baseCmd <> "--jobs 10", baseOptions{HLS.jobs = Just 10})
  , (baseCmd <> "--no-set", baseOptions{HLS.setCompile = False})
  , (baseCmd <> "--cabal-update", baseOptions{HLS.updateCabal = True})
-  , (baseCmd <> "-o 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $(versionQ "2.0.0.0-p1")})
-  , (baseCmd <> "--overwrite-version 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $(versionQ "2.0.0.0-p1")})
-  , (baseCmd <> "--git-describe-version", baseOptions{HLS.ovewrwiteVer = Left True})
+  , (baseCmd <> "-o 2.0.0.0-p1", baseOptions{HLS.overwriteVer = Just [S "2.0.0.0-p1"]})
+  , (baseCmd <> "--overwrite-version 2.0.0.0-p1", baseOptions{HLS.overwriteVer = Just [S "2.0.0.0-p1"]})
+  , (baseCmd <> "--overwrite-version %v-%h-%H-%b-%g-coco%l", baseOptions{HLS.overwriteVer
+    = Just [CabalVer, S "-", GitHashShort, S "-", GitHashLong, S "-", GitBranchName, S "-", GitDescribe, S "-coco", S "%", S "l"]})
+  , (baseCmd <> "--git-describe-version", baseOptions{HLS.overwriteVer = Just [GitDescribe]})
 #ifdef IS_WINDOWS
  , (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})
  , (baseCmd <> "--isolate C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})