diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index dd910f7..5180511 100644 --- 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 |] 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 })) diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 4c8fad3..fd1dee3 100644 --- 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 ]-- ------------------ diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs index c83fffe..5bfd6da 100644 --- 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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 3cf3116..b877eb5 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -92,6 +92,8 @@ import qualified Data.Yaml.Aeson as Y +-- $setup +-- >>> :set -XOverloadedStrings diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index e8986c5..9432ab5 100644 --- 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 diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index f40fbc2..a452671 100644 --- 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 ----------------- diff --git a/lib/GHCup/Prelude/Internal.hs b/lib/GHCup/Prelude/Internal.hs index 093f3e1..44ed998 100644 --- 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)) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index fa8a65d..6f00deb 100644 --- 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) + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 551e679..ddc61e4 100644 --- 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 + diff --git a/test/optparse-test/CompileTest.hs b/test/optparse-test/CompileTest.hs index 4fed639..0396563 100644 --- 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"})