hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Beef up --overwrite-version, fixes #998

Browse Source
This commit is contained in:
Julian Ospald 2024-02-17 23:12:56 +08:00
parent 2fdf896fbd
commit bdd15ad6e7
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
10 changed files with 175 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
app/ghcup/Main.hs
View File

@ -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 }))

25
lib-opt/GHCup/OptParse/Common.hs
View File

@ -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 ]--
------------------

45
lib-opt/GHCup/OptParse/Compile.hs
View File

@ -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

2
lib/GHCup/Download.hs
View File

@ -92,6 +92,8 @@ import qualified Data.Yaml.Aeson as Y
-- $setup
-- >>> :set -XOverloadedStrings

39
lib/GHCup/GHC.hs
View File

@ -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

55
lib/GHCup/HLS.hs
View File

@ -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
-----------------

2
lib/GHCup/Prelude/Internal.hs
View File

@ -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

10
lib/GHCup/Types.hs
View File

@ -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)

35
lib/GHCup/Utils.hs
View File

@ -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

14
test/optparse-test/CompileTest.hs
View File

@ -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"})