Improve stack metadata support wrt #892
This commit is contained in:
parent
38cd5ad8ed
commit
c7439d3c89
@ -11,7 +11,7 @@ module BrickMain where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics ( getDirs )
|
||||
import GHCup.Types.Optics ( getDirs, getPlatformReq )
|
||||
import GHCup.Types hiding ( LeanAppState(..) )
|
||||
import GHCup.Utils
|
||||
import GHCup.OptParse.Common (logGHCPostRm)
|
||||
@ -660,8 +660,10 @@ getGHCupInfo = do
|
||||
|
||||
r <-
|
||||
flip runReaderT settings
|
||||
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ liftE getDownloadsF
|
||||
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
|
||||
$ do
|
||||
pfreq <- lift getPlatformReq
|
||||
liftE $ getDownloadsF pfreq
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
|
||||
@ -42,7 +42,6 @@ import Data.Aeson.Encode.Pretty ( encodePretty )
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Versions
|
||||
import GHC.IO.Encoding
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Language.Haskell.TH
|
||||
@ -85,13 +84,11 @@ toSettings options = do
|
||||
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
||||
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
|
||||
urlSource = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource
|
||||
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
|
||||
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
|
||||
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
|
||||
mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
|
||||
stackSetupSource = fromMaybe (Types.stackSetupSource defaultSettings) uStackSetupSource
|
||||
stackSetup = fromMaybe (Types.stackSetup defaultSettings) uStackSetup
|
||||
in (Settings {..}, keyBindings)
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
defaultDownloader = Internal
|
||||
@ -213,10 +210,9 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
ghcupInfo <-
|
||||
( flip runReaderT leanAppstate
|
||||
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE getDownloadsF
|
||||
)
|
||||
( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do
|
||||
liftE $ getDownloadsF pfreq
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
@ -341,8 +337,8 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m Bool
|
||||
alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver
|
||||
alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
|
||||
alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver
|
||||
alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
|
||||
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
|
||||
@ -380,3 +376,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
|
||||
cmp' tool instVer ver = do
|
||||
(v, _) <- liftE $ fromVersion instVer tool
|
||||
pure (v == ver)
|
||||
|
||||
|
||||
@ -51,53 +51,45 @@ meta-cache: 300 # in seconds
|
||||
# 2. Strict: fail hard
|
||||
meta-mode: Lax # Strict | Lax
|
||||
|
||||
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
|
||||
# check the 'URLSource' type in the code.
|
||||
# Where to get GHC/cabal/hls download info/versions from. This is a list that performs
|
||||
# union over tool versions, preferring the later entries.
|
||||
url-source:
|
||||
## Use the internal download uri, this is the default
|
||||
GHCupURL: []
|
||||
- GHCupURL
|
||||
|
||||
## Example 1: Read download info from this location instead
|
||||
## Accepts file/http/https scheme
|
||||
## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
|
||||
## which case they are merged right-biased (overwriting duplicate versions).
|
||||
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
|
||||
## Prefer stack supplied metadata (will still use GHCup metadata for versions not existing in stack metadata)
|
||||
# - StackSetupURL
|
||||
|
||||
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
|
||||
## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
|
||||
# AddSource:
|
||||
# Left:
|
||||
# globalTools: {}
|
||||
# toolRequirements: {}
|
||||
# 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
|
||||
## Add pre-release channel
|
||||
# - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
|
||||
## Add nightly channel
|
||||
# - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
|
||||
## Add cross compiler channel
|
||||
# - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml
|
||||
|
||||
## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
|
||||
## versions).
|
||||
# AddSource:
|
||||
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
|
||||
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
|
||||
|
||||
# For stack's setup-info, this works similar, e.g.:
|
||||
# stack-setup-source:
|
||||
# AddSource:
|
||||
# - Left:
|
||||
# ghc:
|
||||
# linux64-tinfo6:
|
||||
# 9.4.7:
|
||||
# url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz"
|
||||
# content-length: 179117892
|
||||
# sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
|
||||
## Use dwarf bindist for 9.4.7 for ghcup metadata
|
||||
# - ghcup-info:
|
||||
# ghcupDownloads:
|
||||
# GHC:
|
||||
# 9.4.7:
|
||||
# viTags: []
|
||||
# viArch:
|
||||
# A_64:
|
||||
# Linux_UnknownLinux:
|
||||
# unknown_versioning:
|
||||
# dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz
|
||||
# dlSubdir:
|
||||
# RegexDir: "ghc-.*"
|
||||
# dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4
|
||||
|
||||
## for stack metadata and the linux64-tinfo6 bindists, use static alpine for 9.8.1
|
||||
# - setup-info:
|
||||
# ghc:
|
||||
# linux64-tinfo6:
|
||||
# 9.8.1:
|
||||
# url: "https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-alpine3_12-linux-static.tar.xz"
|
||||
# content-length: 229037440
|
||||
# sha256: b48f3d3a508d0c140d1c801e04afc65e80c0d25e7e939a8a41edb387b26b81b3
|
||||
|
||||
# This is a way to override platform detection, e.g. when you're running
|
||||
# a Ubuntu derivate based on 18.04, you could do:
|
||||
|
||||
@ -153,8 +153,7 @@ To use a mirror, set the following option in `~/.ghcup/config.yaml`:
|
||||
|
||||
```yml
|
||||
url-source:
|
||||
# Accepts file/http/https scheme
|
||||
OwnSource: "https://some-url/ghcup-0.0.6.yaml"
|
||||
- https://some-url/ghcup-0.0.6.yaml
|
||||
```
|
||||
|
||||
See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
|
||||
@ -184,8 +183,8 @@ This will result in `~/.ghcup/config.yaml` to contain this record:
|
||||
|
||||
```yml
|
||||
url-source:
|
||||
AddSource:
|
||||
- Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
|
||||
- GHCupURL
|
||||
- https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
|
||||
```
|
||||
|
||||
You can add as many channels as you like. They are combined under *Last*, so versions from the prerelease channel
|
||||
@ -195,14 +194,13 @@ To remove the channel, delete the entire `url-source` section or set it back to
|
||||
|
||||
```yml
|
||||
url-source:
|
||||
GHCupURL: []
|
||||
- GHCupURL
|
||||
```
|
||||
|
||||
If you want to combine your release channel with a mirror, you'd do it like so:
|
||||
|
||||
```yml
|
||||
url-source:
|
||||
OwnSource:
|
||||
# base metadata
|
||||
- "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
|
||||
# prerelease channel
|
||||
@ -249,24 +247,32 @@ stack config set system-ghc true --global
|
||||
### Using stack's setup-info metadata to install GHC
|
||||
|
||||
You can now use stack's [setup-info metadata](https://github.com/commercialhaskell/stackage-content/blob/master/stack/stack-setup-2.yaml)
|
||||
to install GHC. For that, you can invoke ghcup like so:
|
||||
to install GHC. For that, you can invoke ghcup like so as a shorthand:
|
||||
|
||||
```sh
|
||||
ghcup install ghc --stack-setup 9.4.7
|
||||
# ghcup will only see GHC now
|
||||
ghcup -s StackSetupURL install ghc 9.4.7
|
||||
# this combines both ghcup and stack metadata
|
||||
ghcup -s '["GHCupURL", "StackSetupURL"]' install ghc 9.4.7
|
||||
```
|
||||
|
||||
To make this permanent, you can add the following to you `~/.ghcup/config.yaml`:
|
||||
To make this permanent and combine it with the GHCup metadata, you can add the following to your `~/.ghcup/config.yaml`:
|
||||
|
||||
```yaml
|
||||
stack-setup: true
|
||||
url-source:
|
||||
- GHCupURL
|
||||
# stack versions take precedence
|
||||
# you'll still have access to GHCup provided versions and tools in case they don't exist in stack metadata
|
||||
- StackSetupURL
|
||||
```
|
||||
|
||||
You can customize or add sections to the setup-info similar to how the [stack documentation](https://docs.haskellstack.org/en/stable/yaml_configuration/#setup-info) explains it. E.g. to change the 9.4.7 bindist, you might do:
|
||||
|
||||
```yaml
|
||||
stack-setup-source:
|
||||
AddSource:
|
||||
- Left:
|
||||
url-source:
|
||||
- GHCupURL
|
||||
- StackSetupURL
|
||||
- setup-info:
|
||||
ghc:
|
||||
linux64-tinfo6:
|
||||
9.4.7:
|
||||
|
||||
@ -57,16 +57,13 @@ import GHCup.Types
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
|
||||
|
||||
data Options = Options
|
||||
@ -77,18 +74,19 @@ data Options = Options
|
||||
, optMetaCache :: Maybe Integer
|
||||
, optMetaMode :: Maybe MetaMode
|
||||
, optPlatform :: Maybe PlatformRequest
|
||||
, optUrlSource :: Maybe URI
|
||||
, optUrlSource :: Maybe URLSource
|
||||
, optNoVerify :: Maybe Bool
|
||||
, optKeepDirs :: Maybe KeepDirs
|
||||
, optsDownloader :: Maybe Downloader
|
||||
, optNoNetwork :: Maybe Bool
|
||||
, optGpg :: Maybe GPGSetting
|
||||
, optStackSetup :: Maybe Bool
|
||||
-- commands
|
||||
, optCommand :: Command
|
||||
}
|
||||
|
||||
data Command
|
||||
= Install (Either InstallCommand InstallGHCOptions)
|
||||
= Install (Either InstallCommand InstallOptions)
|
||||
| Test TestCommand
|
||||
| InstallCabalLegacy InstallOptions
|
||||
| Set (Either SetCommand SetOptions)
|
||||
@ -134,13 +132,13 @@ opts =
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
(eitherReader parseUrlSource)
|
||||
( short 's'
|
||||
<> long "url-source"
|
||||
<> metavar "URL"
|
||||
<> help "Alternative ghcup download info url"
|
||||
<> metavar "URL_SOURCE"
|
||||
<> help "Alternative ghcup download info"
|
||||
<> internal
|
||||
<> completer fileUri
|
||||
<> completer urlSourceCompleter
|
||||
)
|
||||
)
|
||||
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
|
||||
@ -178,10 +176,9 @@ opts =
|
||||
"GPG verification (default: none)"
|
||||
<> completer (listCompleter ["strict", "lax", "none"])
|
||||
))
|
||||
<*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions")
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
|
||||
|
||||
|
||||
com :: Parser Command
|
||||
|
||||
@ -64,6 +64,8 @@ import URI.ByteString
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Encoding as LE
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified System.FilePath.Posix as FP
|
||||
import GHCup.Version
|
||||
@ -322,6 +324,15 @@ toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
|
||||
gitFileUri :: [String] -> Completer
|
||||
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
|
||||
|
||||
urlSourceCompleter :: Completer
|
||||
urlSourceCompleter = mkCompleter $ urlSourceCompleter' []
|
||||
|
||||
urlSourceCompleter' :: [String] -> String -> IO [String]
|
||||
urlSourceCompleter' add str' = do
|
||||
let static = ["GHCupURL", "StackSetupURL"]
|
||||
file <- fileUri' add str'
|
||||
pure $ static ++ file
|
||||
|
||||
fileUri :: Completer
|
||||
fileUri = mkCompleter $ fileUri' []
|
||||
|
||||
@ -450,13 +461,15 @@ tagCompleter tool add = listIOCompleter $ do
|
||||
defaultKeyBindings
|
||||
loggerConfig
|
||||
|
||||
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (/= Old)
|
||||
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
|
||||
pure $ nub $ (add ++) $ fmap tagToString allTags
|
||||
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
|
||||
mpFreq <- flip runReaderT appState . runE $ platformRequest
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (/= Old)
|
||||
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
|
||||
pure $ nub $ (add ++) $ fmap tagToString allTags
|
||||
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
|
||||
|
||||
versionCompleter :: [ListCriteria] -> Tool -> Completer
|
||||
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
|
||||
@ -477,8 +490,8 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
|
||||
defaultKeyBindings
|
||||
loggerConfig
|
||||
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
|
||||
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
|
||||
forFold mGhcUpInfo $ \ghcupInfo -> do
|
||||
let appState = AppState
|
||||
settings
|
||||
@ -817,3 +830,15 @@ logGHCPostRm ghcVer = do
|
||||
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
|
||||
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir
|
||||
|
||||
parseUrlSource :: String -> Either String URLSource
|
||||
parseUrlSource "GHCupURL" = pure GHCupURL
|
||||
parseUrlSource "StackSetupURL" = pure StackSetupURL
|
||||
parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
|
||||
<|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
|
||||
|
||||
parseNewUrlSource :: String -> Either String NewURLSource
|
||||
parseNewUrlSource "GHCupURL" = pure NewGHCupURL
|
||||
parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL
|
||||
parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
|
||||
<|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
|
||||
|
||||
|
||||
@ -32,7 +32,6 @@ import Options.Applicative hiding ( style, ParseError )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
@ -51,7 +50,7 @@ data ConfigCommand
|
||||
= ShowConfig
|
||||
| SetConfig String (Maybe String)
|
||||
| InitConfig
|
||||
| AddReleaseChannel Bool URI
|
||||
| AddReleaseChannel Bool NewURLSource
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
@ -75,8 +74,8 @@ configP = subparser
|
||||
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
|
||||
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
|
||||
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
|
||||
addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
|
||||
(progDesc "Add a release channel from a URI")
|
||||
addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "URL_SOURCE" <> completer urlSourceCompleter))
|
||||
(progDesc "Add a release channel, e.g. from a URI")
|
||||
|
||||
|
||||
|
||||
@ -135,9 +134,7 @@ updateSettings usl usr =
|
||||
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
|
||||
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
|
||||
mirrors' = uMirrors usl <|> uMirrors usr
|
||||
stackSetupSource' = uStackSetupSource usl <|> uStackSetupSource usr
|
||||
stackSetup' = uStackSetup usl <|> uStackSetup usr
|
||||
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' stackSetupSource' stackSetup'
|
||||
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
|
||||
where
|
||||
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
|
||||
updateKeyBindings Nothing Nothing = Nothing
|
||||
@ -209,27 +206,15 @@ config configCommand settings userConf keybindings runLogger = case configComman
|
||||
pure $ ExitFailure 65
|
||||
VLeft _ -> pure $ ExitFailure 65
|
||||
|
||||
AddReleaseChannel force uri -> do
|
||||
AddReleaseChannel force new -> do
|
||||
r <- runE @'[DuplicateReleaseChannel] $ do
|
||||
case urlSource settings of
|
||||
AddSource xs -> do
|
||||
case checkDuplicate xs (Right uri) of
|
||||
Duplicate
|
||||
| not force -> throwE (DuplicateReleaseChannel uri)
|
||||
DuplicateLast -> pure ()
|
||||
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
|
||||
GHCupURL -> do
|
||||
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
|
||||
pure ()
|
||||
OwnSource xs -> do
|
||||
case checkDuplicate xs (Right uri) of
|
||||
Duplicate
|
||||
| not force -> throwE (DuplicateReleaseChannel uri)
|
||||
DuplicateLast -> pure ()
|
||||
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
|
||||
OwnSpec spec -> do
|
||||
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
|
||||
pure ()
|
||||
let oldSources = fromURLSource (urlSource settings)
|
||||
let merged = oldSources ++ [new]
|
||||
case checkDuplicate oldSources new of
|
||||
Duplicate
|
||||
| not force -> throwE (DuplicateReleaseChannel new)
|
||||
DuplicateLast -> pure ()
|
||||
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ SimpleList merged })
|
||||
case r of
|
||||
VRight _ -> do
|
||||
pure ExitSuccess
|
||||
@ -244,15 +229,6 @@ config configCommand settings userConf keybindings runLogger = case configComman
|
||||
| a `elem` xs = Duplicate
|
||||
| otherwise = NoDuplicate
|
||||
|
||||
-- appends the element to the end of the list, but also removes it from the existing list
|
||||
appendUnique :: Eq a => [a] -> a -> [a]
|
||||
appendUnique xs' e = go xs'
|
||||
where
|
||||
go [] = [e]
|
||||
go (x:xs)
|
||||
| x == e = go xs -- skip
|
||||
| otherwise = x : go xs
|
||||
|
||||
doConfig :: MonadIO m => UserSettings -> m ()
|
||||
doConfig usersettings = do
|
||||
let settings' = updateSettings usersettings userConf
|
||||
|
||||
@ -50,7 +50,7 @@ import qualified Data.Text as T
|
||||
----------------
|
||||
|
||||
|
||||
data InstallCommand = InstallGHC InstallGHCOptions
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
| InstallHLS InstallOptions
|
||||
| InstallStack InstallOptions
|
||||
@ -63,16 +63,6 @@ data InstallCommand = InstallGHC InstallGHCOptions
|
||||
--[ Options ]--
|
||||
---------------
|
||||
|
||||
data InstallGHCOptions = InstallGHCOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instBindist :: Maybe URI
|
||||
, instSet :: Bool
|
||||
, isolateDir :: Maybe FilePath
|
||||
, forceInstall :: Bool
|
||||
, addConfArgs :: [T.Text]
|
||||
, useStackSetup :: Maybe Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instBindist :: Maybe URI
|
||||
@ -102,14 +92,14 @@ installCabalFooter = [s|Discussion:
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
installParser :: Parser (Either InstallCommand InstallGHCOptions)
|
||||
installParser :: Parser (Either InstallCommand InstallOptions)
|
||||
installParser =
|
||||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
( InstallGHC
|
||||
<$> info
|
||||
(installGHCOpts <**> helper)
|
||||
(installOpts (Just GHC) <**> helper)
|
||||
( progDesc "Install GHC"
|
||||
<> footerDoc (Just $ text installGHCFooter)
|
||||
)
|
||||
@ -143,7 +133,7 @@ installParser =
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> installGHCOpts)
|
||||
<|> (Right <$> installOpts (Just GHC))
|
||||
where
|
||||
installHLSFooter :: String
|
||||
installHLSFooter = [s|Discussion:
|
||||
@ -219,12 +209,6 @@ installOpts tool =
|
||||
Just GHC -> False
|
||||
Just _ -> True
|
||||
|
||||
installGHCOpts :: Parser InstallGHCOptions
|
||||
installGHCOpts =
|
||||
(\InstallOptions{..} b -> let useStackSetup = b in InstallGHCOptions{..})
|
||||
<$> installOpts (Just GHC)
|
||||
<*> invertableSwitch "stack-setup" (Just 's') False (help "Set as active version after install")
|
||||
|
||||
|
||||
|
||||
|
||||
@ -328,7 +312,7 @@ runInstGHC appstate' =
|
||||
-------------------
|
||||
|
||||
|
||||
install :: Either InstallCommand InstallGHCOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(Right iGHCopts) -> do
|
||||
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
|
||||
@ -338,11 +322,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(Left (InstallHLS iopts)) -> installHLS iopts
|
||||
(Left (InstallStack iopts)) -> installStack iopts
|
||||
where
|
||||
installGHC :: InstallGHCOptions -> IO ExitCode
|
||||
installGHC InstallGHCOptions{..} = do
|
||||
installGHC :: InstallOptions -> IO ExitCode
|
||||
installGHC InstallOptions{..} = do
|
||||
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
|
||||
(case instBindist of
|
||||
Nothing -> runInstGHC s'{ settings = maybe settings (\b -> settings {stackSetup = b}) useStackSetup } $ do
|
||||
Nothing -> runInstGHC s' $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ runBothE' (installGHCBin
|
||||
v
|
||||
|
||||
@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
@ -157,7 +158,9 @@ type PrefetchEffects = '[ TagNotFound
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, JSONError
|
||||
, FileDoesNotExistError ]
|
||||
, FileDoesNotExistError
|
||||
, StackPlatformDetectError
|
||||
]
|
||||
|
||||
|
||||
runPrefetch :: MonadUnliftIO m
|
||||
@ -210,7 +213,8 @@ prefetch prefetchCommand runAppState runLogger =
|
||||
(v, _) <- liftE $ fromVersion mt Stack
|
||||
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
|
||||
PrefetchMetadata -> do
|
||||
_ <- liftE getDownloadsF
|
||||
pfreq <- lift getPlatformReq
|
||||
_ <- liftE $ getDownloadsF pfreq
|
||||
pure ""
|
||||
) >>= \case
|
||||
VRight _ -> do
|
||||
|
||||
@ -31,10 +31,10 @@ import GHCup.Download.Utils
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import qualified GHCup.Types.Stack as Stack
|
||||
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
@ -56,6 +56,7 @@ import Data.ByteString ( ByteString )
|
||||
import Data.CaseInsensitive ( mk )
|
||||
#endif
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
@ -113,24 +114,71 @@ getDownloadsF :: ( FromJSONKey Tool
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> Excepts
|
||||
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
=> PlatformRequest
|
||||
-> Excepts
|
||||
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
|
||||
m
|
||||
GHCupInfo
|
||||
getDownloadsF = do
|
||||
getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
||||
Settings { urlSource } <- lift getSettings
|
||||
case urlSource of
|
||||
GHCupURL -> liftE $ getBase ghcupURL
|
||||
(OwnSource exts) -> do
|
||||
ext <- liftE $ mapM (either pure getBase) exts
|
||||
mergeGhcupInfo ext
|
||||
(OwnSpec av) -> pure av
|
||||
(AddSource exts) -> do
|
||||
base <- liftE $ getBase ghcupURL
|
||||
ext <- liftE $ mapM (either pure getBase) exts
|
||||
mergeGhcupInfo (base:ext)
|
||||
|
||||
let newUrlSources = fromURLSource urlSource
|
||||
infos <- liftE $ mapM dl' newUrlSources
|
||||
keys <- if any isRight infos
|
||||
then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
|
||||
else pure []
|
||||
ghcupInfos <- fmap catMaybes $ forM infos $ \case
|
||||
Left gi -> pure (Just gi)
|
||||
Right si -> pure $ fromStackSetupInfo si keys
|
||||
mergeGhcupInfo ghcupInfos
|
||||
where
|
||||
|
||||
dl' :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> NewURLSource
|
||||
-> Excepts
|
||||
'[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
|
||||
m (Either GHCupInfo Stack.SetupInfo)
|
||||
dl' NewGHCupURL = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
|
||||
dl' NewStackSetupURL = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
|
||||
dl' (NewGHCupInfo gi) = pure (Left gi)
|
||||
dl' (NewSetupInfo si) = pure (Right si)
|
||||
dl' (NewURI uri) = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
|
||||
$ fmap Left $ getBase @GHCupInfo uri
|
||||
|
||||
fromStackSetupInfo :: MonadThrow m
|
||||
=> Stack.SetupInfo
|
||||
-> [String]
|
||||
-> m GHCupInfo
|
||||
fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
|
||||
let ghcVersionsPerKey = (`M.lookup` ghcDli) <$> (T.pack <$> keys)
|
||||
ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
|
||||
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
|
||||
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
|
||||
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
|
||||
pure (GHCupInfo mempty ghcupDownloads' mempty)
|
||||
where
|
||||
fromDownloadInfo :: DownloadInfo -> VersionInfo
|
||||
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
|
||||
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
|
||||
|
||||
fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
|
||||
fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
|
||||
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
|
||||
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
|
||||
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
|
||||
|
||||
|
||||
mergeGhcupInfo :: MonadFail m
|
||||
=> [GHCupInfo]
|
||||
-> m GHCupInfo
|
||||
@ -142,6 +190,7 @@ getDownloadsF = do
|
||||
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
|
||||
|
||||
|
||||
|
||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||
yamlFromCache uri = do
|
||||
Dirs{..} <- getDirs
|
||||
@ -152,7 +201,7 @@ etagsFile :: FilePath -> FilePath
|
||||
etagsFile = (<.> "etags")
|
||||
|
||||
|
||||
getBase :: ( MonadReader env m
|
||||
getBase :: forall j m env . ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
@ -327,106 +376,6 @@ getDownloadInfo' t v = do
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
getStackDownloadInfo :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasGHCupInfo env
|
||||
, HasLog env
|
||||
, HasPlatformReq env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
)
|
||||
=> StackSetupURLSource
|
||||
-> [String]
|
||||
-> Tool
|
||||
-> GHCTargetVersion
|
||||
-- ^ tool version
|
||||
-> Excepts
|
||||
'[NoDownload, DownloadFailed]
|
||||
m
|
||||
DownloadInfo
|
||||
getStackDownloadInfo stackSetupSource keys@(_:_) GHC tv@(GHCTargetVersion Nothing v) =
|
||||
case stackSetupSource of
|
||||
StackSetupURL -> do
|
||||
(dli :: Stack.SetupInfo) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSource exts) -> do
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo dlis
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSpec si) -> do
|
||||
sDli <- liftE $ stackDownloadInfo si
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SAddSource exts) -> do
|
||||
base :: Stack.SetupInfo <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo (base:dlis)
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
|
||||
where
|
||||
stackDownloadInfo :: MonadIO m => Stack.SetupInfo -> Excepts '[NoDownload] m Stack.DownloadInfo
|
||||
stackDownloadInfo dli@Stack.SetupInfo{} = do
|
||||
let siGHCs = Stack.siGHCs dli
|
||||
ghcVersionsPerKey = (`M.lookup` siGHCs) <$> (T.pack <$> keys)
|
||||
ghcVersions <- (listToMaybe . catMaybes $ ghcVersionsPerKey) ?? NoDownload tv GHC Nothing
|
||||
(Stack.gdiDownloadInfo <$> M.lookup v ghcVersions) ?? NoDownload tv GHC Nothing
|
||||
|
||||
mergeSetupInfo :: MonadFail m
|
||||
=> [Stack.SetupInfo]
|
||||
-> m Stack.SetupInfo
|
||||
mergeSetupInfo [] = fail "mergeSetupInfo: internal error: need at least one SetupInfo"
|
||||
mergeSetupInfo xs@(Stack.SetupInfo{}: _) =
|
||||
let newSevenzExe = Stack.siSevenzExe $ last xs
|
||||
newSevenzDll = Stack.siSevenzDll $ last xs
|
||||
newMsys2 = M.unionsWith (\_ a2 -> a2 ) (Stack.siMsys2 <$> xs)
|
||||
newGHCs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siGHCs <$> xs)
|
||||
newStack = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siStack <$> xs)
|
||||
in pure $ Stack.SetupInfo newSevenzExe newSevenzDll newMsys2 newGHCs newStack
|
||||
|
||||
fromStackDownloadInfo :: MonadThrow m => Stack.DownloadInfo -> m DownloadInfo
|
||||
fromStackDownloadInfo Stack.DownloadInfo{..} = do
|
||||
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
|
||||
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
|
||||
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
|
||||
getStackDownloadInfo _ _ t v = throwE $ NoDownload v t Nothing
|
||||
|
||||
{--
|
||||
data SetupInfo = SetupInfo
|
||||
{ siSevenzExe :: Maybe DownloadInfo
|
||||
, siSevenzDll :: Maybe DownloadInfo
|
||||
, siMsys2 :: Map Text VersionedDownloadInfo
|
||||
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
|
||||
, siStack :: Map Text (Map Version DownloadInfo)
|
||||
|
||||
data VersionedDownloadInfo = VersionedDownloadInfo
|
||||
{ vdiVersion :: Version
|
||||
, vdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
}
|
||||
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ downloadInfoUrl :: Text
|
||||
-- ^ URL or absolute file path
|
||||
, downloadInfoContentLength :: Maybe Int
|
||||
, downloadInfoSha1 :: Maybe ByteString
|
||||
, downloadInfoSha256 :: Maybe ByteString
|
||||
}
|
||||
|
||||
data GHCDownloadInfo = GHCDownloadInfo
|
||||
{ gdiConfigureOpts :: [Text]
|
||||
, gdiConfigureEnv :: Map Text Text
|
||||
, gdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
|
||||
|
||||
--}
|
||||
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
|
||||
@ -676,18 +676,18 @@ instance HFErrorProject ContentLengthError where
|
||||
eBase _ = 340
|
||||
eDesc _ = "File content length verification failed"
|
||||
|
||||
data DuplicateReleaseChannel = DuplicateReleaseChannel URI
|
||||
data DuplicateReleaseChannel = DuplicateReleaseChannel NewURLSource
|
||||
deriving Show
|
||||
|
||||
instance HFErrorProject DuplicateReleaseChannel where
|
||||
eBase _ = 350
|
||||
eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
|
||||
eDesc _ = "Duplicate release channel detected when adding new source.\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
|
||||
|
||||
instance Pretty DuplicateReleaseChannel where
|
||||
pPrint (DuplicateReleaseChannel uri) =
|
||||
pPrint (DuplicateReleaseChannel source) =
|
||||
text $ "Duplicate release channel detected when adding: \n "
|
||||
<> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
|
||||
<> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
|
||||
<> show source
|
||||
<> "\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
|
||||
|
||||
data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
|
||||
deriving Show
|
||||
@ -787,6 +787,22 @@ instance HFErrorProject GHCupSetError where
|
||||
eNum (GHCupSetError xs) = 9000 + eNum xs
|
||||
eDesc _ = "Setting the current version failed."
|
||||
|
||||
-- | Executing stacks platform detection failed.
|
||||
data StackPlatformDetectError = forall es . (ToVariantMaybe StackPlatformDetectError es, PopVariant StackPlatformDetectError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => StackPlatformDetectError (V es)
|
||||
|
||||
instance Pretty StackPlatformDetectError where
|
||||
pPrint (StackPlatformDetectError reason) =
|
||||
case reason of
|
||||
VMaybe (_ :: StackPlatformDetectError) -> pPrint reason
|
||||
_ -> text "Running stack platform detection logic failed:" <+> pPrint reason
|
||||
|
||||
deriving instance Show StackPlatformDetectError
|
||||
|
||||
instance HFErrorProject StackPlatformDetectError where
|
||||
eBase _ = 6000
|
||||
eNum (StackPlatformDetectError xs) = 6000 + eNum xs
|
||||
eDesc _ = "Running stack platform detection logic failed."
|
||||
|
||||
|
||||
---------------------------------------------
|
||||
--[ True Exceptions (e.g. for MonadThrow) ]--
|
||||
|
||||
@ -26,7 +26,6 @@ import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
@ -547,14 +546,7 @@ installGHCBin :: ( MonadFail m
|
||||
m
|
||||
()
|
||||
installGHCBin tver installDir forceInstall addConfArgs = do
|
||||
Settings{ stackSetupSource, stackSetup } <- lift getSettings
|
||||
dlinfo <- if stackSetup
|
||||
then do
|
||||
lift $ logInfo "Using stack's setup-info to install GHC"
|
||||
pfreq <- lift getPlatformReq
|
||||
keys <- liftE $ getStackPlatformKey pfreq
|
||||
liftE $ getStackDownloadInfo stackSetupSource keys GHC tver
|
||||
else liftE $ getDownloadInfo' GHC tver
|
||||
dlinfo <- liftE $ getDownloadInfo' GHC tver
|
||||
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
|
||||
|
||||
|
||||
|
||||
@ -23,7 +23,7 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
@ -348,7 +348,7 @@ getStackOSKey PlatformRequest { .. } =
|
||||
(A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
|
||||
(arch', os') -> throwE $ UnsupportedSetupCombo arch' os'
|
||||
|
||||
getStackPlatformKey :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||
getStackPlatformKey :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||
=> PlatformRequest
|
||||
-> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
|
||||
getStackPlatformKey pfreq@PlatformRequest{..} = do
|
||||
|
||||
@ -43,6 +43,10 @@ import Control.Monad.Reader
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( Pretty )
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (getEnvironment)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import System.FilePath
|
||||
import Data.List (intercalate)
|
||||
|
||||
|
||||
|
||||
@ -88,3 +92,25 @@ throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excep
|
||||
{-# INLINABLE throwSomeE #-}
|
||||
throwSomeE = Excepts . pure . VLeft . liftVariant
|
||||
#endif
|
||||
|
||||
addToPath :: [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> IO [(String, String)]
|
||||
addToPath paths append = do
|
||||
cEnv <- getEnvironment
|
||||
return $ addToPath' cEnv paths append
|
||||
|
||||
addToPath' :: [(String, String)]
|
||||
-> [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> [(String, String)]
|
||||
addToPath' cEnv' newPaths append =
|
||||
let cEnv = Map.fromList cEnv'
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
in envWithNewPath
|
||||
|
||||
@ -201,7 +201,7 @@ instance Pretty Tag where
|
||||
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
|
||||
pPrint (UnknownTag t ) = text t
|
||||
pPrint LatestPrerelease = text "latest-prerelease"
|
||||
pPrint LatestNightly = text "latest-prerelease"
|
||||
pPrint LatestNightly = text "latest-prerelease"
|
||||
pPrint Old = mempty
|
||||
|
||||
data Architecture = A_64
|
||||
@ -342,18 +342,35 @@ instance Pretty TarDir where
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource [Either GHCupInfo URI] -- ^ complete source list
|
||||
| OwnSpec GHCupInfo
|
||||
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
| StackSetupURL
|
||||
| OwnSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ complete source list
|
||||
| OwnSpec (Either GHCupInfo SetupInfo)
|
||||
| AddSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ merge with GHCupURL
|
||||
| SimpleList [NewURLSource]
|
||||
deriving (Eq, GHC.Generic, Show)
|
||||
|
||||
data StackSetupURLSource = StackSetupURL
|
||||
| SOwnSource [Either SetupInfo URI] -- ^ complete source list
|
||||
| SOwnSpec SetupInfo
|
||||
| SAddSource [Either SetupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
data NewURLSource = NewGHCupURL
|
||||
| NewStackSetupURL
|
||||
| NewGHCupInfo GHCupInfo
|
||||
| NewSetupInfo SetupInfo
|
||||
| NewURI URI
|
||||
deriving (Eq, GHC.Generic, Show)
|
||||
|
||||
instance NFData StackSetupURLSource
|
||||
instance NFData NewURLSource
|
||||
|
||||
fromURLSource :: URLSource -> [NewURLSource]
|
||||
fromURLSource GHCupURL = [NewGHCupURL]
|
||||
fromURLSource StackSetupURL = [NewStackSetupURL]
|
||||
fromURLSource (OwnSource arr) = convert' <$> arr
|
||||
fromURLSource (AddSource arr) = NewGHCupURL:(convert' <$> arr)
|
||||
fromURLSource (SimpleList arr) = arr
|
||||
fromURLSource (OwnSpec (Left gi)) = [NewGHCupInfo gi]
|
||||
fromURLSource (OwnSpec (Right si)) = [NewSetupInfo si]
|
||||
|
||||
convert' :: Either (Either GHCupInfo SetupInfo) URI -> NewURLSource
|
||||
convert' (Left (Left gi)) = NewGHCupInfo gi
|
||||
convert' (Left (Right si)) = NewSetupInfo si
|
||||
convert' (Right uri) = NewURI uri
|
||||
|
||||
instance NFData URLSource
|
||||
instance NFData (URIRef Absolute) where
|
||||
@ -380,13 +397,11 @@ data UserSettings = UserSettings
|
||||
, uGPGSetting :: Maybe GPGSetting
|
||||
, uPlatformOverride :: Maybe PlatformRequest
|
||||
, uMirrors :: Maybe DownloadMirrors
|
||||
, uStackSetupSource :: Maybe StackSetupURLSource
|
||||
, uStackSetup :: Maybe Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
|
||||
fromSettings Settings{..} Nothing =
|
||||
@ -404,8 +419,6 @@ fromSettings Settings{..} Nothing =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
let ukb = UserKeyBindings
|
||||
@ -433,8 +446,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
@ -523,8 +534,6 @@ data Settings = Settings
|
||||
, noColor :: Bool -- this also exists in LoggerConfig
|
||||
, platformOverride :: Maybe PlatformRequest
|
||||
, mirrors :: DownloadMirrors
|
||||
, stackSetupSource :: StackSetupURLSource
|
||||
, stackSetup :: Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
@ -532,7 +541,7 @@ defaultMetaCache :: Integer
|
||||
defaultMetaCache = 300 -- 5 minutes
|
||||
|
||||
defaultSettings :: Settings
|
||||
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) StackSetupURL False
|
||||
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)
|
||||
|
||||
instance NFData Settings
|
||||
|
||||
|
||||
@ -22,6 +22,7 @@ Portability : portable
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Stack (SetupInfo)
|
||||
import GHCup.Types.JSON.Utils
|
||||
import GHCup.Types.JSON.Versions ()
|
||||
import GHCup.Prelude.MegaParsec
|
||||
@ -32,7 +33,9 @@ import Data.Aeson.TH
|
||||
import Data.Aeson.Types hiding (Key)
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Maybe
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Foldable
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import URI.ByteString
|
||||
@ -278,13 +281,29 @@ instance FromJSONKey (Maybe VersionRange) where
|
||||
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
|
||||
|
||||
|
||||
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''StackSetupURLSource
|
||||
|
||||
instance FromJSON GHCupInfo where
|
||||
parseJSON = withObject "GHCupInfo" $ \o -> do
|
||||
toolRequirements' <- o .:? "toolRequirements"
|
||||
globalTools' <- o .:? "globalTools"
|
||||
ghcupDownloads' <- o .: "ghcupDownloads"
|
||||
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools'))
|
||||
|
||||
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
|
||||
instance ToJSON NewURLSource where
|
||||
toJSON NewGHCupURL = String "GHCupURL"
|
||||
toJSON NewStackSetupURL = String "StackSetupURL"
|
||||
toJSON (NewGHCupInfo gi) = object [ "ghcup-info" .= gi ]
|
||||
toJSON (NewSetupInfo si) = object [ "setup-info" .= si ]
|
||||
toJSON (NewURI uri) = toJSON uri
|
||||
|
||||
instance ToJSON URLSource where
|
||||
toJSON = toJSON . fromURLSource
|
||||
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
|
||||
@ -297,13 +316,29 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
|
||||
instance FromJSON URLSource where
|
||||
parseJSON v =
|
||||
parseGHCupURL v
|
||||
<|> parseStackURL v
|
||||
<|> parseOwnSourceLegacy v
|
||||
<|> parseOwnSourceNew1 v
|
||||
<|> parseOwnSourceNew2 v
|
||||
<|> parseOwnSpec v
|
||||
<|> legacyParseAddSource v
|
||||
<|> newParseAddSource v
|
||||
-- new since Stack SetupInfo
|
||||
<|> parseOwnSpecNew v
|
||||
<|> parseOwnSourceNew3 v
|
||||
<|> newParseAddSource2 v
|
||||
-- more lenient versions
|
||||
<|> parseOwnSpecLenient v
|
||||
<|> parseOwnSourceLenient v
|
||||
<|> parseAddSourceLenient v
|
||||
-- simplified list
|
||||
<|> parseNewUrlSource v
|
||||
<|> parseNewUrlSource' v
|
||||
where
|
||||
convert'' :: Either GHCupInfo URI -> Either (Either GHCupInfo SetupInfo) URI
|
||||
convert'' (Left gi) = Left (Left gi)
|
||||
convert'' (Right uri) = Right uri
|
||||
|
||||
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
|
||||
r :: URI <- o .: "OwnSource"
|
||||
pure (OwnSource [Right r])
|
||||
@ -312,20 +347,85 @@ instance FromJSON URLSource where
|
||||
pure (OwnSource (fmap Right r))
|
||||
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
|
||||
pure (OwnSource r)
|
||||
pure (OwnSource (convert'' <$> r))
|
||||
parseOwnSpec = withObject "URLSource" $ \o -> do
|
||||
r :: GHCupInfo <- o .: "OwnSpec"
|
||||
pure (OwnSpec r)
|
||||
pure (OwnSpec $ Left r)
|
||||
parseGHCupURL = withObject "URLSource" $ \o -> do
|
||||
_ :: [Value] <- o .: "GHCupURL"
|
||||
pure GHCupURL
|
||||
parseStackURL = withObject "URLSource" $ \o -> do
|
||||
_ :: [Value] <- o .: "StackSetupURL"
|
||||
pure StackSetupURL
|
||||
legacyParseAddSource = withObject "URLSource" $ \o -> do
|
||||
r :: Either GHCupInfo URI <- o .: "AddSource"
|
||||
pure (AddSource [r])
|
||||
pure (AddSource [convert'' r])
|
||||
newParseAddSource = withObject "URLSource" $ \o -> do
|
||||
r :: [Either GHCupInfo URI] <- o .: "AddSource"
|
||||
pure (AddSource (convert'' <$> r))
|
||||
|
||||
-- new since Stack SetupInfo
|
||||
parseOwnSpecNew = withObject "URLSource" $ \o -> do
|
||||
r :: Either GHCupInfo SetupInfo <- o .: "OwnSpec"
|
||||
pure (OwnSpec r)
|
||||
parseOwnSourceNew3 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "OwnSource"
|
||||
pure (OwnSource r)
|
||||
newParseAddSource2 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "AddSource"
|
||||
pure (AddSource r)
|
||||
|
||||
-- more lenient versions
|
||||
parseOwnSpecLenient = withObject "URLSource" $ \o -> do
|
||||
spec :: Object <- o .: "OwnSpec"
|
||||
OwnSpec <$> lenientInfoParser spec
|
||||
parseOwnSourceLenient = withObject "URLSource" $ \o -> do
|
||||
mown :: Array <- o .: "OwnSource"
|
||||
OwnSource . toList <$> mapM lenientInfoUriParser mown
|
||||
parseAddSourceLenient = withObject "URLSource" $ \o -> do
|
||||
madd :: Array <- o .: "AddSource"
|
||||
AddSource . toList <$> mapM lenientInfoUriParser madd
|
||||
|
||||
-- simplified
|
||||
parseNewUrlSource = withArray "URLSource" $ \a -> do
|
||||
SimpleList . toList <$> mapM parseJSON a
|
||||
parseNewUrlSource' v' = SimpleList .(:[]) <$> parseJSON v'
|
||||
|
||||
|
||||
lenientInfoUriParser :: Value -> Parser (Either (Either GHCupInfo SetupInfo) URI)
|
||||
lenientInfoUriParser (Object o) = Left <$> lenientInfoParser o
|
||||
lenientInfoUriParser v@(String _) = Right <$> parseJSON v
|
||||
lenientInfoUriParser _ = fail "Unexpected json in lenientInfoUriParser"
|
||||
|
||||
|
||||
lenientInfoParser :: Object -> Parser (Either GHCupInfo SetupInfo)
|
||||
lenientInfoParser o = do
|
||||
setup_info :: Maybe Object <- o .:? "setup-info"
|
||||
case setup_info of
|
||||
Nothing -> do
|
||||
r <- parseJSON (Object o)
|
||||
pure $ Left r
|
||||
Just setup_info' -> do
|
||||
r <- parseJSON (Object setup_info')
|
||||
pure $ Right r
|
||||
|
||||
instance FromJSON NewURLSource where
|
||||
parseJSON v = uri v <|> url v <|> gi v <|> si v
|
||||
where
|
||||
uri = withText "NewURLSource" $ \t -> NewURI <$> parseJSON (String t)
|
||||
url = withText "NewURLSource" $ \t -> case T.unpack t of
|
||||
"GHCupURL" -> pure NewGHCupURL
|
||||
"StackSetupURL" -> pure NewStackSetupURL
|
||||
t' -> fail $ "Unexpected text value in NewURLSource: " <> t'
|
||||
gi = withObject "NewURLSource" $ \o -> do
|
||||
ginfo :: GHCupInfo <- o .: "ghcup-info"
|
||||
pure $ NewGHCupInfo ginfo
|
||||
|
||||
si = withObject "NewURLSource" $ \o -> do
|
||||
sinfo :: SetupInfo <- o .: "setup-info"
|
||||
pure $ NewSetupInfo sinfo
|
||||
|
||||
|
||||
instance FromJSON KeyCombination where
|
||||
parseJSON v = proper v <|> simple v
|
||||
where
|
||||
|
||||
@ -89,9 +89,9 @@ import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Streamly.Prelude as S
|
||||
|
||||
import Control.DeepSeq (force)
|
||||
import GHC.IO (evaluate)
|
||||
import System.Environment (getEnvironment)
|
||||
import Data.Time (Day(..), diffDays, addDays)
|
||||
|
||||
|
||||
@ -1320,29 +1320,6 @@ warnAboutHlsCompatibility = do
|
||||
|
||||
|
||||
|
||||
addToPath :: [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> IO [(String, String)]
|
||||
addToPath paths append = do
|
||||
cEnv <- getEnvironment
|
||||
return $ addToPath' cEnv paths append
|
||||
|
||||
addToPath' :: [(String, String)]
|
||||
-> [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> [(String, String)]
|
||||
addToPath' cEnv' newPaths append =
|
||||
let cEnv = Map.fromList cEnv'
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
in envWithNewPath
|
||||
|
||||
|
||||
-----------
|
||||
--[ Git ]--
|
||||
-----------
|
||||
|
||||
@ -5,6 +5,7 @@ module ConfigTest where
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import GHCup.OptParse
|
||||
import GHCup.Types (NewURLSource(..))
|
||||
import Utils
|
||||
import Control.Monad.IO.Class
|
||||
import URI.ByteString.QQ
|
||||
@ -23,7 +24,13 @@ checkList =
|
||||
, ("config init", InitConfig)
|
||||
, ("config show", ShowConfig)
|
||||
, ("config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
|
||||
, AddReleaseChannel False [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|]
|
||||
, AddReleaseChannel False (NewURI [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|])
|
||||
)
|
||||
, ("config add-release-channel GHCupURL"
|
||||
, AddReleaseChannel False NewGHCupURL
|
||||
)
|
||||
, ("config add-release-channel StackSetupURL"
|
||||
, AddReleaseChannel False NewStackSetupURL
|
||||
)
|
||||
, ("config set cache true", SetConfig "cache" (Just "true"))
|
||||
]
|
||||
|
||||
@ -2,9 +2,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module InstallTest where
|
||||
|
||||
@ -16,8 +13,6 @@ import Data.Versions
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import GHCup.OptParse.Install as Install
|
||||
import URI.ByteString.QQ
|
||||
import URI.ByteString
|
||||
import Data.Text (Text)
|
||||
|
||||
-- Some interests:
|
||||
-- install ghc *won't* select `set as activate version` as default
|
||||
@ -31,52 +26,37 @@ installTests = testGroup "install"
|
||||
(buildTestTree installParseWith)
|
||||
[ ("old-style", oldStyleCheckList)
|
||||
, ("ghc", installGhcCheckList)
|
||||
, ("cabal", (fmap . fmap . fmap) toGHCOptions installCabalCheckList)
|
||||
, ("hls", (fmap . fmap . fmap) toGHCOptions installHlsCheckList)
|
||||
, ("stack", (fmap . fmap . fmap) toGHCOptions installStackCheckList)
|
||||
, ("cabal", installCabalCheckList)
|
||||
, ("hls", installHlsCheckList)
|
||||
, ("stack", installStackCheckList)
|
||||
]
|
||||
|
||||
toGHCOptions :: InstallOptions -> InstallGHCOptions
|
||||
toGHCOptions InstallOptions{..}
|
||||
= InstallGHCOptions instVer
|
||||
instBindist
|
||||
instSet
|
||||
isolateDir
|
||||
forceInstall
|
||||
addConfArgs
|
||||
Nothing
|
||||
|
||||
|
||||
|
||||
defaultOptions :: InstallOptions
|
||||
defaultOptions = InstallOptions Nothing Nothing False Nothing False []
|
||||
|
||||
defaultGHCOptions :: InstallGHCOptions
|
||||
defaultGHCOptions = InstallGHCOptions Nothing Nothing False Nothing False [] Nothing
|
||||
|
||||
-- | Don't set as active version
|
||||
mkInstallOptions :: ToolVersion -> InstallGHCOptions
|
||||
mkInstallOptions ver = InstallGHCOptions (Just ver) Nothing False Nothing False [] Nothing
|
||||
mkInstallOptions :: ToolVersion -> InstallOptions
|
||||
mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False []
|
||||
|
||||
-- | Set as active version
|
||||
mkInstallOptions' :: ToolVersion -> InstallOptions
|
||||
mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False []
|
||||
|
||||
oldStyleCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
|
||||
oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)]
|
||||
oldStyleCheckList =
|
||||
("install", Right defaultGHCOptions)
|
||||
: ("install --set", Right (defaultGHCOptions{instSet = True} :: InstallGHCOptions))
|
||||
: ("install --force", Right (defaultGHCOptions{forceInstall = True} :: InstallGHCOptions))
|
||||
("install", Right defaultOptions)
|
||||
: ("install --set", Right defaultOptions{instSet = True})
|
||||
: ("install --force", Right defaultOptions{forceInstall = True})
|
||||
#ifdef IS_WINDOWS
|
||||
: ("install -i C:\\\\", Right (defaultGHCOptions{Install.isolateDir = Just "C:\\\\"} :: InstallGHCOptions))
|
||||
: ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"})
|
||||
#else
|
||||
: ("install -i /", Right (defaultGHCOptions{Install.isolateDir = Just "/"} :: InstallGHCOptions))
|
||||
: ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"})
|
||||
#endif
|
||||
: ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head"
|
||||
, Right (defaultGHCOptions
|
||||
, Right defaultOptions
|
||||
{ instBindist = Just [uri|https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz|]
|
||||
, instVer = Just $ GHCVersion $ GHCTargetVersion Nothing $(versionQ "head")
|
||||
} :: InstallGHCOptions)
|
||||
}
|
||||
)
|
||||
: mapSecond
|
||||
(Right . mkInstallOptions)
|
||||
@ -128,9 +108,9 @@ oldStyleCheckList =
|
||||
)
|
||||
]
|
||||
|
||||
installGhcCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
|
||||
installGhcCheckList :: [(String, Either InstallCommand InstallOptions)]
|
||||
installGhcCheckList =
|
||||
("install ghc", Left $ InstallGHC defaultGHCOptions)
|
||||
("install ghc", Left $ InstallGHC defaultOptions)
|
||||
: mapSecond (Left . InstallGHC . mkInstallOptions)
|
||||
[ ("install ghc 9.2", GHCVersion
|
||||
$ GHCTargetVersion
|
||||
@ -171,7 +151,7 @@ installGhcCheckList =
|
||||
|
||||
installCabalCheckList :: [(String, Either InstallCommand InstallOptions)]
|
||||
installCabalCheckList =
|
||||
("install cabal", Left $ InstallCabal (defaultOptions{instSet = True} :: InstallOptions))
|
||||
("install cabal", Left $ InstallCabal defaultOptions{instSet = True})
|
||||
: mapSecond (Left . InstallCabal . mkInstallOptions')
|
||||
[ ("install cabal 3.10", ToolVersion $(versionQ "3.10"))
|
||||
, ("install cabal next", ToolVersion $(versionQ "next"))
|
||||
@ -217,7 +197,7 @@ installStackCheckList =
|
||||
, ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9"))
|
||||
]
|
||||
|
||||
installParseWith :: [String] -> IO (Either InstallCommand InstallGHCOptions)
|
||||
installParseWith :: [String] -> IO (Either InstallCommand InstallOptions)
|
||||
installParseWith args = do
|
||||
Install a <- parseWith args
|
||||
pure a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user