Compare commits
14 Commits
v0.1.12-rc
...
v0.1.12
| Author | SHA1 | Date | |
|---|---|---|---|
| 82aa6c70ea | |||
| e829bd8235 | |||
| 66f989e691 | |||
| eebb91fbb0 | |||
| 1d3e88bdfe | |||
| fbb03dee7e | |||
|
|
88e5afb70f | ||
| 67eabfd3af | |||
| cd1dd8c29e | |||
| 08ddb591b7 | |||
| 3e841b3c68 | |||
| 53f5a08924 | |||
| d368863c3d | |||
| c76cce5830 |
@@ -60,7 +60,7 @@ variables:
|
||||
script:
|
||||
- ./.gitlab/script/ghcup_version.sh
|
||||
variables:
|
||||
JSON_VERSION: "0.0.3"
|
||||
JSON_VERSION: "0.0.4"
|
||||
artifacts:
|
||||
expire_in: 2 week
|
||||
paths:
|
||||
|
||||
@@ -2,12 +2,18 @@
|
||||
|
||||
## 0.1.12 -- ????-??-??
|
||||
|
||||
* Fix disappearing HLS symlinks wrt #91
|
||||
* improve TUI:
|
||||
- separators between tools sections
|
||||
- reverse list order so latest is on top
|
||||
- expand the blues selected bar
|
||||
- show new latest versions in bright white
|
||||
* allow configuration file and settings TUI hotkeys wrt #41
|
||||
* allow configuration file and setting TUI hotkeys wrt #41
|
||||
- see https://gitlab.haskell.org/haskell/ghcup-hs#configuration for a more in-depth explanation
|
||||
* add a `--set` switch to `ghcup install ghc` to automatically set as default after install
|
||||
* emit warnings when CC/LD is set wrt #82
|
||||
* add support for version ranges in distro specifiers wrt #84
|
||||
- e.g. `"(>= 19 && <= 20) || ==0.2.2"` is a valid version key for distro
|
||||
|
||||
## 0.1.11 -- 2020-09-23
|
||||
|
||||
|
||||
38
README.md
38
README.md
@@ -83,42 +83,8 @@ handles your haskell packages and can demand that [a specific version](https://c
|
||||
|
||||
### Configuration
|
||||
|
||||
A configuration file can be put in `~/.ghcup/config.yaml`. Here is the complete default
|
||||
configuration:
|
||||
|
||||
```yaml
|
||||
# Cache downloads in ~/.ghcup/cache
|
||||
cache: False
|
||||
# Skip tarball checksum verification
|
||||
no-verify: False
|
||||
# enable verbosity
|
||||
verbose: False
|
||||
# When to keep build directories
|
||||
keep-dirs: Errors # Always | Never | Errors
|
||||
# Which downloader to use
|
||||
downloader: Curl # Curl | Wget | Internal
|
||||
|
||||
# TUI key bindings,
|
||||
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
|
||||
# for possible values.
|
||||
key-bindings:
|
||||
up:
|
||||
KUp: []
|
||||
down:
|
||||
KDown: []
|
||||
quit:
|
||||
KChar: 'q'
|
||||
install:
|
||||
KChar: 'i'
|
||||
uninstall:
|
||||
KChar: 'u'
|
||||
set:
|
||||
KChar: 's'
|
||||
changelog:
|
||||
KChar: 'c'
|
||||
show-all:
|
||||
KChar: 'a'
|
||||
```
|
||||
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
|
||||
explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml).
|
||||
|
||||
Partial configuration is fine. Command line options always overwrite the config file settings.
|
||||
|
||||
|
||||
@@ -193,7 +193,7 @@ validateTarballs dls = do
|
||||
where
|
||||
downloadAll dli = do
|
||||
dirs <- liftIO getDirs
|
||||
let settings = AppState (Settings True False Never Curl False) dirs defaultKeyBindings
|
||||
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
|
||||
@@ -48,6 +48,8 @@ import System.Exit
|
||||
import System.IO.Unsafe
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHCup.Types as GT
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Data.Vector as V
|
||||
@@ -480,11 +482,6 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
Left e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
uri' :: IORef (Maybe URI)
|
||||
{-# NOINLINE uri' #-}
|
||||
uri' = unsafePerformIO (newIORef Nothing)
|
||||
|
||||
|
||||
settings' :: IORef AppState
|
||||
{-# NOINLINE settings' #-}
|
||||
settings' = unsafePerformIO $ do
|
||||
@@ -494,6 +491,7 @@ settings' = unsafePerformIO $ do
|
||||
, keepDirs = Never
|
||||
, downloader = Curl
|
||||
, verbose = False
|
||||
, urlSource = GHCupURL
|
||||
, ..
|
||||
})
|
||||
dirs
|
||||
@@ -512,13 +510,11 @@ logger' = unsafePerformIO
|
||||
|
||||
|
||||
brickMain :: AppState
|
||||
-> Maybe URI
|
||||
-> LoggerConfig
|
||||
-> GHCupDownloads
|
||||
-> PlatformRequest
|
||||
-> IO ()
|
||||
brickMain s muri l av pfreq' = do
|
||||
writeIORef uri' muri
|
||||
brickMain s l av pfreq' = do
|
||||
writeIORef settings' s
|
||||
-- logger interpreter
|
||||
writeIORef logger' l
|
||||
@@ -547,7 +543,6 @@ defaultAppSettings = BrickSettings { showAll = False }
|
||||
|
||||
getDownloads' :: IO (Either String GHCupDownloads)
|
||||
getDownloads' = do
|
||||
muri <- readIORef uri'
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
@@ -558,7 +553,7 @@ getDownloads' = do
|
||||
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ fmap _ghcupDownloads
|
||||
$ liftE
|
||||
$ getDownloadsF (maybe GHCupURL OwnSource muri)
|
||||
$ getDownloadsF (urlSource . GT.settings $ settings)
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
|
||||
@@ -122,6 +122,7 @@ data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instPlatform :: Maybe PlatformRequest
|
||||
, instBindist :: Maybe URI
|
||||
, instSet :: Bool
|
||||
}
|
||||
|
||||
data SetCommand = SetGHC SetOptions
|
||||
@@ -158,6 +159,7 @@ data GHCCompileOptions = GHCCompileOptions
|
||||
, patchDir :: Maybe (Path Abs)
|
||||
, crossTarget :: Maybe Text
|
||||
, addConfArgs :: [Text]
|
||||
, setCompile :: Bool
|
||||
}
|
||||
|
||||
data CabalCompileOptions = CabalCompileOptions
|
||||
@@ -372,20 +374,20 @@ com =
|
||||
installToolFooter = [s|Discussion:
|
||||
Installs GHC or cabal. When no command is given, installs GHC
|
||||
with the specified version/tag.
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
|
||||
|
||||
setFooter :: String
|
||||
setFooter = [s|Discussion:
|
||||
Sets the currently active GHC or cabal version. When no command is given,
|
||||
defaults to setting GHC with the specified version/tag (if no tag
|
||||
is given, sets GHC to 'recommended' version).
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
|
||||
|
||||
rmFooter :: String
|
||||
rmFooter = [s|Discussion:
|
||||
Remove the given GHC or cabal version. When no command is given,
|
||||
defaults to removing GHC with the specified version.
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
|
||||
|
||||
changeLogFooter :: String
|
||||
changeLogFooter = [s|Discussion:
|
||||
@@ -470,7 +472,7 @@ Examples:
|
||||
|
||||
installOpts :: Parser InstallOptions
|
||||
installOpts =
|
||||
(\p (u, v) -> InstallOptions v p u)
|
||||
(\p (u, v) b -> InstallOptions v p u b)
|
||||
<$> (optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
@@ -495,6 +497,12 @@ installOpts =
|
||||
)
|
||||
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
|
||||
)
|
||||
<*> flag
|
||||
False
|
||||
True
|
||||
(long "set" <> help
|
||||
"Set as active version after install"
|
||||
)
|
||||
|
||||
|
||||
setParser :: Parser (Either SetCommand SetOptions)
|
||||
@@ -664,7 +672,7 @@ Examples:
|
||||
|
||||
ghcCompileOpts :: Parser GHCCompileOptions
|
||||
ghcCompileOpts =
|
||||
(\CabalCompileOptions {..} crossTarget addConfArgs -> GHCCompileOptions { .. }
|
||||
(\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
|
||||
)
|
||||
<$> cabalCompileOpts
|
||||
<*> (optional
|
||||
@@ -676,6 +684,12 @@ ghcCompileOpts =
|
||||
)
|
||||
)
|
||||
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
|
||||
<*> flag
|
||||
False
|
||||
True
|
||||
(long "set" <> help
|
||||
"Set as active version after install"
|
||||
)
|
||||
|
||||
cabalCompileOpts :: Parser CabalCompileOptions
|
||||
cabalCompileOpts =
|
||||
@@ -738,9 +752,9 @@ cabalCompileOpts =
|
||||
|
||||
|
||||
toolVersionParser :: Parser ToolVersion
|
||||
toolVersionParser = verP <|> toolP
|
||||
toolVersionParser = verP' <|> toolP
|
||||
where
|
||||
verP = ToolVersion <$> versionParser
|
||||
verP' = ToolVersion <$> versionParser
|
||||
toolP =
|
||||
ToolTag
|
||||
<$> (option
|
||||
@@ -868,17 +882,6 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
, MP.chunk "exherbo" $> Exherbo
|
||||
, MP.chunk "unknown" $> UnknownLinux
|
||||
]
|
||||
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
|
||||
verP suffix = do
|
||||
ver <- parseUntil suffix
|
||||
if T.null ver
|
||||
then fail "empty version"
|
||||
else do
|
||||
rest <- MP.getInput
|
||||
MP.setInput ver
|
||||
v <- versioning'
|
||||
MP.setInput rest
|
||||
pure v
|
||||
|
||||
|
||||
bindistParser :: String -> Either String URI
|
||||
@@ -899,12 +902,13 @@ toSettings options = do
|
||||
where
|
||||
mergeConf :: Options -> Dirs -> UserSettings -> AppState
|
||||
mergeConf (Options {..}) dirs (UserSettings {..}) =
|
||||
let cache = fromMaybe (fromMaybe False uCache) optCache
|
||||
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
|
||||
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
|
||||
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
let cache = fromMaybe (fromMaybe False uCache) optCache
|
||||
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
|
||||
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
|
||||
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
||||
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
|
||||
in AppState (Settings {..}) dirs keyBindings
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
defaultDownloader = Internal
|
||||
@@ -990,6 +994,7 @@ main = do
|
||||
ENV variables:
|
||||
* TMPDIR: where ghcup does the work (unpacking, building, ...)
|
||||
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
|
||||
* GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
|
||||
|
||||
Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
@@ -1134,7 +1139,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
. flip runReaderT appstate
|
||||
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF (maybe GHCupURL OwnSource optUrlSource)
|
||||
$ getDownloadsF (urlSource settings)
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
@@ -1158,12 +1163,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Nothing -> runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
(fromMaybe pfreq instPlatform)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
@@ -1331,7 +1338,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
res <- case optCommand of
|
||||
#if defined(BRICK)
|
||||
Interactive -> liftIO $ brickMain appstate optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
|
||||
Interactive -> liftIO $ brickMain appstate loggerConfig dls pfreq >> pure ExitSuccess
|
||||
#endif
|
||||
Install (Right iopts) -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
||||
@@ -1376,14 +1383,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 8
|
||||
|
||||
Compile (CompileGHC GHCCompileOptions {..}) ->
|
||||
(runCompileGHC $ liftE $ compileGHC dls
|
||||
(GHCTargetVersion crossTarget targetVer)
|
||||
bootstrapGhc
|
||||
jobs
|
||||
buildConfig
|
||||
patchDir
|
||||
addConfArgs
|
||||
pfreq
|
||||
(runCompileGHC $ do
|
||||
liftE $ compileGHC dls
|
||||
(GHCTargetVersion crossTarget targetVer)
|
||||
bootstrapGhc
|
||||
jobs
|
||||
buildConfig
|
||||
patchDir
|
||||
addConfArgs
|
||||
pfreq
|
||||
when setCompile $ void $ liftE
|
||||
$ setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
|
||||
61
config.yaml
Normal file
61
config.yaml
Normal file
@@ -0,0 +1,61 @@
|
||||
# Cache downloads in ~/.ghcup/cache
|
||||
cache: False
|
||||
# Skip tarball checksum verification
|
||||
no-verify: False
|
||||
# enable verbosity
|
||||
verbose: False
|
||||
# When to keep build directories
|
||||
keep-dirs: Errors # Always | Never | Errors
|
||||
# Which downloader to use
|
||||
downloader: Curl # Curl | Wget | Internal
|
||||
|
||||
# TUI key bindings,
|
||||
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
|
||||
# for possible values.
|
||||
key-bindings:
|
||||
up:
|
||||
KUp: []
|
||||
down:
|
||||
KDown: []
|
||||
quit:
|
||||
KChar: 'q'
|
||||
install:
|
||||
KChar: 'i'
|
||||
uninstall:
|
||||
KChar: 'u'
|
||||
set:
|
||||
KChar: 's'
|
||||
changelog:
|
||||
KChar: 'c'
|
||||
show-all:
|
||||
KChar: 'a'
|
||||
|
||||
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
|
||||
# check the 'URLSource' type in the code.
|
||||
url-source:
|
||||
## Use the internal download uri, this is the default
|
||||
GHCupURL: []
|
||||
|
||||
## Example 1: Read download info from this location instead
|
||||
## Accepts file/http/https scheme
|
||||
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
|
||||
|
||||
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
|
||||
# AddSource:
|
||||
# Left:
|
||||
# toolRequirements: {} # this is ignored
|
||||
# ghcupDownloads:
|
||||
# GHC:
|
||||
# 9.10.2:
|
||||
# viTags: []
|
||||
# viArch:
|
||||
# A_64:
|
||||
# Linux_UnknownLinux:
|
||||
# unknown_versioning:
|
||||
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
|
||||
# dlSubdir: ghc-7.10.3
|
||||
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
|
||||
|
||||
## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
|
||||
# AddSource:
|
||||
# Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
|
||||
@@ -1430,20 +1430,20 @@ ghcupDownloads:
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *ghcup-32
|
||||
HLS:
|
||||
0.5.1:
|
||||
0.6.0:
|
||||
viTags:
|
||||
- Recommended
|
||||
- Latest
|
||||
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#051
|
||||
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#060
|
||||
viArch:
|
||||
A_64:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning: &hls-64
|
||||
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.5.1/haskell-language-server-Linux-0.5.1.tar.gz
|
||||
dlHash: 8f80a663823033b1d9322de6f86b329e6f7b3f93ba2faea4677989767cb844eb
|
||||
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.6.0/haskell-language-server-Linux-0.6.0.tar.gz
|
||||
dlHash: 5a3ed953f3cc4dac2c5712b0c1a4fc6848a91a301c2f692081fdb37985c23f61
|
||||
Darwin:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.5.1/haskell-language-server-macOS-0.5.1.tar.gz
|
||||
dlHash: a4e557a754df6d2e668714909554a15fea9803f3ff5883268bcf92bf009b45b2
|
||||
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.6.0/haskell-language-server-macOS-0.6.0.tar.gz
|
||||
dlHash: e5288935f5d8a38b56cfff1d0862d38b2749619b69b23923a814dc136ab7d307
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *hls-64
|
||||
|
||||
1461
ghcup-0.0.4.yaml
Normal file
1461
ghcup-0.0.4.yaml
Normal file
File diff suppressed because it is too large
Load Diff
@@ -15,7 +15,7 @@ maintainer: hasufell@posteo.de
|
||||
copyright: Julian Ospald 2020
|
||||
category: System
|
||||
build-type: Simple
|
||||
extra-source-files: CHANGELOG.md
|
||||
extra-doc-files: CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
23326
golden/GHCupInfo.json
23326
golden/GHCupInfo.json
File diff suppressed because it is too large
Load Diff
30
lib/GHCup.hs
30
lib/GHCup.hs
@@ -74,7 +74,7 @@ import Prelude hiding ( abs
|
||||
)
|
||||
import Safe hiding ( at )
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
import System.Posix.Env.ByteString ( getEnvironment, getEnv )
|
||||
import System.Posix.FilePath ( getSearchPath, takeExtension )
|
||||
import System.Posix.Files.ByteString
|
||||
import Text.Regex.Posix
|
||||
@@ -134,10 +134,23 @@ installGHCBindist dlinfo ver pfreq = do
|
||||
-- prepare paths
|
||||
ghcdir <- lift $ ghcupGHCDir tver
|
||||
|
||||
toolchainSanityChecks
|
||||
|
||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq
|
||||
|
||||
liftE $ postGHCInstall tver
|
||||
|
||||
where
|
||||
toolchainSanityChecks = do
|
||||
r <- forM ["CC", "LD"] (liftIO . getEnv)
|
||||
case catMaybes r of
|
||||
[] -> pure ()
|
||||
_ -> do
|
||||
lift $ $(logWarn) "CC/LD environment variable is set. This will change the compiler/linker"
|
||||
lift $ $(logWarn) "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
|
||||
lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall."
|
||||
|
||||
|
||||
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
|
||||
-- build system and nothing else.
|
||||
installPackedGHC :: ( MonadMask m
|
||||
@@ -522,8 +535,8 @@ setGHC ver sghc = do
|
||||
-- with old ghcup)
|
||||
case sghc of
|
||||
SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
|
||||
SetGHC_XY -> lift $ rmMajorSymlinks ver
|
||||
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
|
||||
SetGHC_XY -> liftE $ rmMajorSymlinks ver
|
||||
SetGHC_XYZ -> liftE $ rmMinorSymlinks ver
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
@@ -924,16 +937,17 @@ rmGHCVer ver = do
|
||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
||||
liftE $ rmPlain (_tvTarget ver)
|
||||
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
||||
lift $ rmMinorSymlinks ver
|
||||
liftE $ rmMinorSymlinks ver
|
||||
|
||||
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
|
||||
-- first remove
|
||||
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
|
||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
v' <-
|
||||
handle
|
||||
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
||||
|
||||
@@ -57,6 +57,7 @@ import Data.ByteString ( ByteString )
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.CaseInsensitive ( CI )
|
||||
#endif
|
||||
import Data.List ( find )
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Time.Clock
|
||||
@@ -83,9 +84,9 @@ import qualified Crypto.Hash.SHA256 as SHA256
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map.Strict as M
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
import qualified Data.Text.Encoding as E
|
||||
@@ -104,8 +105,8 @@ import qualified System.Posix.RawFilePath.Directory
|
||||
------------------
|
||||
|
||||
|
||||
-- | Like 'getDownloads', but tries to fall back to
|
||||
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
|
||||
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
getDownloadsF :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
@@ -123,15 +124,22 @@ getDownloadsF :: ( FromJSONKey Tool
|
||||
GHCupInfo
|
||||
getDownloadsF urlSource = do
|
||||
case urlSource of
|
||||
GHCupURL ->
|
||||
liftE
|
||||
$ handleIO (\_ -> readFromCache)
|
||||
$ catchE @_ @'[JSONError , FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache)
|
||||
$ getDownloads urlSource
|
||||
(OwnSource _) -> liftE $ getDownloads urlSource
|
||||
(OwnSpec _) -> liftE $ getDownloads urlSource
|
||||
GHCupURL -> liftE getBase
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
(OwnSpec av) -> pure av
|
||||
(AddSource (Left ext)) -> do
|
||||
base <- liftE getBase
|
||||
pure (mergeGhcupInfo base ext)
|
||||
(AddSource (Right uri)) -> do
|
||||
base <- liftE getBase
|
||||
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
|
||||
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
|
||||
pure (mergeGhcupInfo base ext)
|
||||
where
|
||||
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
readFromCache = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logWarn)
|
||||
@@ -145,32 +153,25 @@ getDownloadsF urlSource = do
|
||||
$ readFile yaml_file
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
|
||||
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
getBase =
|
||||
handleIO (\_ -> readFromCache)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache)
|
||||
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
|
||||
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> URLSource
|
||||
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
|
||||
getDownloads urlSource = do
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
(OwnSpec av) -> pure $ av
|
||||
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
|
||||
-> GHCupInfo -- ^ extension overwriting the base
|
||||
-> GHCupInfo
|
||||
mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
|
||||
let new = M.mapWithKey (\k a -> case M.lookup k ext of
|
||||
Just a' -> M.union a' a
|
||||
Nothing -> a
|
||||
) base
|
||||
in GHCupInfo tr new
|
||||
|
||||
where
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
@@ -292,7 +293,8 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro)
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
@@ -300,7 +302,18 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
||||
let platformVersionSpec =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(mv' == Nothing)
|
||||
(\range -> maybe False (flip versionRange range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
|
||||
@@ -14,8 +14,10 @@ module GHCup.Requirements where
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List ( find )
|
||||
import Data.Maybe
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
@@ -23,6 +25,7 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
@@ -33,15 +36,25 @@ getCommonRequirements :: PlatformResult
|
||||
-> ToolRequirements
|
||||
-> Maybe Requirements
|
||||
getCommonRequirements pr tr =
|
||||
preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
|
||||
<|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
|
||||
<|> preview
|
||||
( ix GHC
|
||||
% ix Nothing
|
||||
% ix (set _Linux UnknownLinux $ _platform pr)
|
||||
% ix Nothing
|
||||
)
|
||||
tr
|
||||
with_distro <|> without_distro_ver <|> without_distro
|
||||
where
|
||||
with_distro = distro_preview _platform _distroVersion
|
||||
without_distro_ver = distro_preview _platform (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux . _platform) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
preview (ix GHC % ix Nothing % ix (f pr)) tr
|
||||
mv' = g pr
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(mv' == Nothing)
|
||||
(\range -> maybe False (flip versionRange range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
|
||||
|
||||
prettyRequirements :: Requirements -> T.Text
|
||||
|
||||
@@ -14,6 +14,7 @@ Portability : POSIX
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
@@ -46,7 +47,7 @@ data GHCupInfo = GHCupInfo
|
||||
type ToolRequirements = Map Tool ToolReqVersionSpec
|
||||
type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
|
||||
type PlatformReqSpec = Map Platform PlatformReqVersionSpec
|
||||
type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
|
||||
type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements
|
||||
|
||||
|
||||
data Requirements = Requirements
|
||||
@@ -70,7 +71,7 @@ type GHCupDownloads = Map Tool ToolVersionSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
|
||||
|
||||
|
||||
-- | An installable tool.
|
||||
@@ -191,6 +192,7 @@ data TarDir = RealDir (Path Rel)
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupInfo
|
||||
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
|
||||
|
||||
@@ -201,11 +203,12 @@ data UserSettings = UserSettings
|
||||
, uKeepDirs :: Maybe KeepDirs
|
||||
, uDownloader :: Maybe Downloader
|
||||
, uKeyBindings :: Maybe UserKeyBindings
|
||||
, uUrlSource :: Maybe URLSource
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
{ kUp :: Maybe Vty.Key
|
||||
@@ -255,6 +258,7 @@ data Settings = Settings
|
||||
, keepDirs :: KeepDirs
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
, urlSource :: URLSource
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
@@ -304,7 +308,7 @@ data PlatformResult = PlatformResult
|
||||
|
||||
prettyPlatform :: PlatformResult -> String
|
||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
= show plat <> ", " <> show v'
|
||||
= show plat <> ", " <> T.unpack (prettyV v')
|
||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
|
||||
= show plat
|
||||
|
||||
@@ -341,3 +345,19 @@ prettyTVer :: GHCTargetVersion -> Text
|
||||
prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
|
||||
prettyTVer (GHCTargetVersion Nothing v') = prettyVer v'
|
||||
|
||||
|
||||
-- | A comparator and a version.
|
||||
data VersionCmp = VR_gt Versioning
|
||||
| VR_gteq Versioning
|
||||
| VR_lt Versioning
|
||||
| VR_lteq Versioning
|
||||
| VR_eq Versioning
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | A version range. Supports && and ||, but not arbitrary
|
||||
-- combinations. This is a little simplified.
|
||||
data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
|
||||
| OrRange (NonEmpty VersionCmp) VersionRange
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
@@ -22,22 +22,28 @@ Portability : POSIX
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import Data.Word8
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
import Text.Casing
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Text.Megaparsec.Char as MPC
|
||||
|
||||
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
|
||||
@@ -55,6 +61,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
|
||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
|
||||
@@ -110,10 +117,10 @@ instance ToJSONKey (Maybe Versioning) where
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure x
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Platform where
|
||||
@@ -156,10 +163,10 @@ instance ToJSONKey (Maybe Version) where
|
||||
|
||||
instance FromJSONKey (Maybe Version) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
if t == T.pack "unknown_version" then pure Nothing else just t
|
||||
where
|
||||
just t = case version t of
|
||||
Right x -> pure x
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON Version where
|
||||
@@ -219,3 +226,101 @@ instance FromJSON TarDir where
|
||||
regexDir = withObject "TarDir" $ \o -> do
|
||||
r <- o .: "RegexDir"
|
||||
pure $ RegexDir r
|
||||
|
||||
|
||||
instance ToJSON VersionCmp where
|
||||
toJSON = String . versionCmpToText
|
||||
|
||||
instance FromJSON VersionCmp where
|
||||
parseJSON = withText "VersionCmp" $ \t -> do
|
||||
case MP.parse versionCmpP "" t of
|
||||
Right r -> pure r
|
||||
Left e -> fail (MP.errorBundlePretty e)
|
||||
|
||||
versionCmpToText :: VersionCmp -> T.Text
|
||||
versionCmpToText (VR_gt ver') = "> " <> prettyV ver'
|
||||
versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
|
||||
versionCmpToText (VR_lt ver') = "< " <> prettyV ver'
|
||||
versionCmpToText (VR_lteq ver') = "<= " <> prettyV ver'
|
||||
versionCmpToText (VR_eq ver') = "== " <> prettyV ver'
|
||||
|
||||
versionCmpP :: MP.Parsec Void T.Text VersionCmp
|
||||
versionCmpP =
|
||||
fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd)
|
||||
<|> fmap
|
||||
VR_gteq
|
||||
(MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd)
|
||||
<|> fmap
|
||||
VR_lt
|
||||
(MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd)
|
||||
<|> fmap
|
||||
VR_lteq
|
||||
(MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd)
|
||||
<|> fmap
|
||||
VR_eq
|
||||
(MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd)
|
||||
<|> fmap
|
||||
VR_eq
|
||||
(MP.try $ MPC.space *> versioningEnd)
|
||||
|
||||
instance ToJSON VersionRange where
|
||||
toJSON = String . verRangeToText
|
||||
|
||||
verRangeToText :: VersionRange -> T.Text
|
||||
verRangeToText (SimpleRange cmps) =
|
||||
let inner = foldr1 (\x y -> x <> " && " <> y)
|
||||
(versionCmpToText <$> NE.toList cmps)
|
||||
in "( " <> inner <> " )"
|
||||
verRangeToText (OrRange cmps range) =
|
||||
let left = verRangeToText $ (SimpleRange cmps)
|
||||
right = verRangeToText range
|
||||
in left <> " || " <> right
|
||||
|
||||
instance FromJSON VersionRange where
|
||||
parseJSON = withText "VersionRange" $ \t -> do
|
||||
case MP.parse versionRangeP "" t of
|
||||
Right r -> pure r
|
||||
Left e -> fail (MP.errorBundlePretty e)
|
||||
|
||||
versionRangeP :: MP.Parsec Void T.Text VersionRange
|
||||
versionRangeP = go <* MP.eof
|
||||
where
|
||||
go =
|
||||
MP.try orParse
|
||||
<|> MP.try (fmap SimpleRange andParse)
|
||||
<|> (fmap (SimpleRange . pure) versionCmpP)
|
||||
|
||||
orParse :: MP.Parsec Void T.Text VersionRange
|
||||
orParse =
|
||||
(\a o -> OrRange a o)
|
||||
<$> (MP.try andParse <|> fmap pure versionCmpP)
|
||||
<*> (MPC.space *> MP.chunk "||" *> MPC.space *> go)
|
||||
|
||||
andParse :: MP.Parsec Void T.Text (NonEmpty VersionCmp)
|
||||
andParse =
|
||||
fmap (\h t -> h :| t)
|
||||
(MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
|
||||
<*> ( MP.try
|
||||
$ MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP)
|
||||
)
|
||||
<* MPC.space
|
||||
<* MP.chunk ")"
|
||||
<* MPC.space
|
||||
|
||||
versioningEnd :: MP.Parsec Void T.Text Versioning
|
||||
versioningEnd =
|
||||
MP.try (verP (MP.chunk " " <|> MP.chunk ")" <|> MP.chunk "&&") <* MPC.space)
|
||||
<|> versioning'
|
||||
|
||||
instance ToJSONKey (Maybe VersionRange) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> verRangeToText x
|
||||
Nothing -> "unknown_versioning"
|
||||
|
||||
instance FromJSONKey (Maybe VersionRange) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else just t
|
||||
where
|
||||
just t = case MP.parse versionRangeP "" t of
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
|
||||
|
||||
@@ -112,33 +112,40 @@ ghcLinkDestination tool ver = do
|
||||
|
||||
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
rmMinorSymlinks :: (MonadReader AppState m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
|
||||
rmMinorSymlinks GHCTargetVersion {..} = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
|
||||
*> (MP.chunk $ prettyVer _tvVersion)
|
||||
*> MP.eof
|
||||
)
|
||||
rmMinorSymlinks :: ( MonadReader AppState m
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMinorSymlinks tv@(GHCTargetVersion {..}) = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
|
||||
let fullF = (binDir </> f_xyz)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
rmPlain :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Maybe Text -- ^ target
|
||||
rmPlain :: ( MonadReader AppState m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Maybe Text -- ^ target
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain target = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
mtv <- lift $ ghcSet target
|
||||
mtv <- lift $ ghcSet target
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (binDir </> f)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
@@ -150,25 +157,25 @@ rmPlain target = do
|
||||
|
||||
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
rmMajorSymlinks :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
rmMajorSymlinks :: ( MonadReader AppState m
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> m ()
|
||||
rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk v')
|
||||
*> MP.chunk v'
|
||||
*> MP.eof
|
||||
)
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
|
||||
let fullF = (binDir </> f_xyz)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
|
||||
@@ -74,13 +74,13 @@ ghcTargetBinP t =
|
||||
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
|
||||
ghcTargetVerP =
|
||||
(\x y -> GHCTargetVersion x y)
|
||||
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP)) <* MP.chunk "-")
|
||||
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP')) <* MP.chunk "-")
|
||||
<|> (flip const Nothing <$> mempty)
|
||||
)
|
||||
<*> (version' <* MP.eof)
|
||||
where
|
||||
verP :: MP.Parsec Void Text Text
|
||||
verP = do
|
||||
verP' :: MP.Parsec Void Text Text
|
||||
verP' = do
|
||||
v <- version'
|
||||
let startsWithDigists =
|
||||
and
|
||||
@@ -97,3 +97,16 @@ ghcTargetVerP =
|
||||
if startsWithDigists && not (isJust (_vEpoch v))
|
||||
then pure $ prettyVer v
|
||||
else fail "Oh"
|
||||
|
||||
|
||||
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
|
||||
verP suffix = do
|
||||
ver <- parseUntil suffix
|
||||
if T.null ver
|
||||
then fail "empty version"
|
||||
else do
|
||||
rest <- MP.getInput
|
||||
MP.setInput ver
|
||||
v <- versioning'
|
||||
MP.setInput rest
|
||||
pure v
|
||||
|
||||
@@ -3,7 +3,7 @@
|
||||
|
||||
{-|
|
||||
Module : GHCup.Version
|
||||
Description : Static version information
|
||||
Description : Version information and version handling.
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
@@ -13,6 +13,7 @@ Portability : POSIX
|
||||
module GHCup.Version where
|
||||
|
||||
import GHCup.Utils.Version.QQ
|
||||
import GHCup.Types
|
||||
|
||||
import Data.Versions
|
||||
import URI.ByteString
|
||||
@@ -22,7 +23,7 @@ import qualified Data.Text as T
|
||||
|
||||
-- | This reflects the API version of the YAML.
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.3.yaml|]
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.4.yaml|]
|
||||
|
||||
-- | The current ghcup version.
|
||||
ghcUpVer :: PVP
|
||||
@@ -31,3 +32,16 @@ ghcUpVer = [pver|0.1.12|]
|
||||
-- | ghcup version as numeric string.
|
||||
numericVer :: String
|
||||
numericVer = T.unpack . prettyPVP $ ghcUpVer
|
||||
|
||||
versionCmp :: Versioning -> VersionCmp -> Bool
|
||||
versionCmp ver1 (VR_gt ver2) = ver1 > ver2
|
||||
versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
|
||||
versionCmp ver1 (VR_lt ver2) = ver1 < ver2
|
||||
versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
|
||||
versionCmp ver1 (VR_eq ver2) = ver1 == ver2
|
||||
|
||||
versionRange :: Versioning -> VersionRange -> Bool
|
||||
versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
|
||||
versionRange ver' (OrRange cmps range) =
|
||||
versionRange ver' (SimpleRange cmps) || versionRange ver' range
|
||||
|
||||
|
||||
@@ -159,6 +159,18 @@ instance Arbitrary VersionInfo where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary VersionRange where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (NonEmpty VersionCmp) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary VersionCmp where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Path Rel) where
|
||||
arbitrary =
|
||||
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack)
|
||||
|
||||
Reference in New Issue
Block a user