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

Merge branch 'improve-stack-setup-use'

Browse Source
This commit is contained in:
Julian Ospald 2023-10-25 15:01:04 +08:00
commit d85accb08e
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
19 changed files with 410 additions and 371 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
app/ghcup/BrickMain.hs
View File

@ -11,7 +11,7 @@ module BrickMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics ( getDirs ) import GHCup.Types.Optics ( getDirs, getPlatformReq )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.OptParse.Common (logGHCPostRm) import GHCup.OptParse.Common (logGHCPostRm)
@ -660,8 +660,10 @@ getGHCupInfo = do
r <- r <-
flip runReaderT settings flip runReaderT settings
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
$ liftE getDownloadsF $ do
pfreq <- lift getPlatformReq
liftE $ getDownloadsF pfreq
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a

15
app/ghcup/Main.hs
View File

@ -42,7 +42,6 @@ import Data.Aeson.Encode.Pretty ( encodePretty )
import Data.Either import Data.Either
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Data.Versions
import GHC.IO.Encoding import GHC.IO.Encoding
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH import Language.Haskell.TH
@ -85,13 +84,11 @@ toSettings options = do
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings 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 noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings) platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
stackSetupSource = fromMaybe (Types.stackSetupSource defaultSettings) uStackSetupSource
stackSetup = fromMaybe (Types.stackSetup defaultSettings) uStackSetup
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@ -213,9 +210,8 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
ghcupInfo <- ghcupInfo <-
( flip runReaderT leanAppstate ( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError] liftE $ getDownloadsF pfreq
$ liftE getDownloadsF
) )
>>= \case >>= \case
VRight r -> pure r VRight r -> pure r
@ -341,8 +337,8 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m Bool ] m Bool
alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (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 (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (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 cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool (v, _) <- liftE $ fromVersion instVer tool
pure (v == ver) pure (v == ver)

58
data/config.yaml
View File

@ -51,53 +51,45 @@ meta-cache: 300 # in seconds
# 2. Strict: fail hard # 2. Strict: fail hard
meta-mode: Lax # Strict | Lax meta-mode: Lax # Strict | Lax
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation # Where to get GHC/cabal/hls download info/versions from. This is a list that performs
# check the 'URLSource' type in the code. # union over tool versions, preferring the later entries.
url-source: url-source:
## Use the internal download uri, this is the default ## Use the internal download uri, this is the default
GHCupURL: [] - GHCupURL
## Example 1: Read download info from this location instead ## Prefer stack supplied metadata (will still use GHCup metadata for versions not existing in stack metadata)
## Accepts file/http/https scheme # - StackSetupURL
## 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"
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions. ## Add pre-release channel
## Can also be an array of 'Either GHCupInfo URL', also see Example 3. # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
# AddSource: ## Add nightly channel
# Left: # - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
# globalTools: {} ## Add cross compiler channel
# toolRequirements: {} # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml
## Use dwarf bindist for 9.4.7 for ghcup metadata
# - ghcup-info:
# ghcupDownloads: # ghcupDownloads:
# GHC: # GHC:
# 9.10.2: # 9.4.7:
# viTags: [] # viTags: []
# viArch: # viArch:
# A_64: # A_64:
# Linux_UnknownLinux: # Linux_UnknownLinux:
# unknown_versioning: # unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2 # dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz
# dlSubdir: ghc-7.10.3 # dlSubdir:
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5 # RegexDir: "ghc-.*"
# dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4
## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate ## for stack metadata and the linux64-tinfo6 bindists, use static alpine for 9.8.1
## versions). # - setup-info:
# 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: # ghc:
# linux64-tinfo6: # linux64-tinfo6:
# 9.4.7: # 9.8.1:
# url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz" # url: "https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-alpine3_12-linux-static.tar.xz"
# content-length: 179117892 # content-length: 229037440
# sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a # sha256: b48f3d3a508d0c140d1c801e04afc65e80c0d25e7e939a8a41edb387b26b81b3
# This is a way to override platform detection, e.g. when you're running # This is a way to override platform detection, e.g. when you're running
# a Ubuntu derivate based on 18.04, you could do: # a Ubuntu derivate based on 18.04, you could do:

32
docs/guide.md
View File

@ -153,8 +153,7 @@ To use a mirror, set the following option in `~/.ghcup/config.yaml`:
```yml ```yml
url-source: url-source:
# Accepts file/http/https scheme - https://some-url/ghcup-0.0.6.yaml
OwnSource: "https://some-url/ghcup-0.0.6.yaml"
``` ```
See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.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 ```yml
url-source: url-source:
AddSource: - GHCupURL
- Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml - 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 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 ```yml
url-source: url-source:
GHCupURL: [] - GHCupURL
``` ```
If you want to combine your release channel with a mirror, you'd do it like so: If you want to combine your release channel with a mirror, you'd do it like so:
```yml ```yml
url-source: url-source:
OwnSource:
# base metadata # base metadata
- "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml" - "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
# prerelease channel # prerelease channel
@ -249,24 +247,32 @@ stack config set system-ghc true --global
### Using stack's setup-info metadata to install GHC ### 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) 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 ```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 ```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: 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 ```yaml
stack-setup-source: url-source:
AddSource: - GHCupURL
- Left: - StackSetupURL
- setup-info:
ghc: ghc:
linux64-tinfo6: linux64-tinfo6:
9.4.7: 9.4.7:

21
lib-opt/GHCup/OptParse.hs
View File

@ -57,16 +57,13 @@ import GHCup.Types
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Reader import Control.Monad.Reader
import Data.Bifunctor
import Data.Either import Data.Either
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
data Options = Options data Options = Options
@ -77,18 +74,19 @@ data Options = Options
, optMetaCache :: Maybe Integer , optMetaCache :: Maybe Integer
, optMetaMode :: Maybe MetaMode , optMetaMode :: Maybe MetaMode
, optPlatform :: Maybe PlatformRequest , optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URLSource
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader , optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool , optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting , optGpg :: Maybe GPGSetting
, optStackSetup :: Maybe Bool
-- commands -- commands
, optCommand :: Command , optCommand :: Command
} }
data Command data Command
= Install (Either InstallCommand InstallGHCOptions) = Install (Either InstallCommand InstallOptions)
| Test TestCommand | Test TestCommand
| InstallCabalLegacy InstallOptions | InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions) | Set (Either SetCommand SetOptions)
@ -134,13 +132,13 @@ opts =
) )
<*> optional <*> optional
(option (option
(eitherReader parseUri) (eitherReader parseUrlSource)
( short 's' ( short 's'
<> long "url-source" <> long "url-source"
<> metavar "URL" <> metavar "URL_SOURCE"
<> help "Alternative ghcup download info url" <> help "Alternative ghcup download info"
<> internal <> internal
<> completer fileUri <> completer urlSourceCompleter
) )
) )
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)")) <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
@ -178,10 +176,9 @@ opts =
"GPG verification (default: none)" "GPG verification (default: none)"
<> completer (listCompleter ["strict", "lax", "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 <*> com
where
parseUri s' =
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command com :: Parser Command

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

@ -64,6 +64,8 @@ import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T 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 Text.Megaparsec as MP
import qualified System.FilePath.Posix as FP import qualified System.FilePath.Posix as FP
import GHCup.Version import GHCup.Version
@ -322,6 +324,15 @@ toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
gitFileUri :: [String] -> Completer gitFileUri :: [String] -> Completer
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add) 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 :: Completer
fileUri = mkCompleter $ fileUri' [] fileUri = mkCompleter $ fileUri' []
@ -450,7 +461,9 @@ tagCompleter tool add = listIOCompleter $ do
defaultKeyBindings defaultKeyBindings
loggerConfig loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF mpFreq <- flip runReaderT appState . runE $ platformRequest
forFold mpFreq $ \pfreq -> do
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
case mGhcUpInfo of case mGhcUpInfo of
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (/= Old) let allTags = filter (/= Old)
@ -477,8 +490,8 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
defaultKeyBindings defaultKeyBindings
loggerConfig loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do forFold mpFreq $ \pfreq -> do
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
forFold mGhcUpInfo $ \ghcupInfo -> do forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState let appState = AppState
settings settings
@ -817,3 +830,15 @@ logGHCPostRm ghcVer = do
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) 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 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')

44
lib-opt/GHCup/OptParse/Config.hs
View File

@ -32,7 +32,6 @@ import Options.Applicative hiding ( style, ParseError )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
@ -51,7 +50,7 @@ data ConfigCommand
= ShowConfig = ShowConfig
| SetConfig String (Maybe String) | SetConfig String (Maybe String)
| InitConfig | InitConfig
| AddReleaseChannel Bool URI | AddReleaseChannel Bool NewURLSource
deriving (Eq, Show) deriving (Eq, Show)
@ -75,8 +74,8 @@ configP = subparser
showP = info (pure ShowConfig) (progDesc "Show current config (default)") 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)) 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")) 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)) 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 from a URI") (progDesc "Add a release channel, e.g. from a URI")
@ -135,9 +134,7 @@ updateSettings usl usr =
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
mirrors' = uMirrors usl <|> uMirrors usr mirrors' = uMirrors usl <|> uMirrors usr
stackSetupSource' = uStackSetupSource usl <|> uStackSetupSource usr in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
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'
where where
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
updateKeyBindings Nothing Nothing = Nothing updateKeyBindings Nothing Nothing = Nothing
@ -209,27 +206,15 @@ config configCommand settings userConf keybindings runLogger = case configComman
pure $ ExitFailure 65 pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65 VLeft _ -> pure $ ExitFailure 65
AddReleaseChannel force uri -> do AddReleaseChannel force new -> do
r <- runE @'[DuplicateReleaseChannel] $ do r <- runE @'[DuplicateReleaseChannel] $ do
case urlSource settings of let oldSources = fromURLSource (urlSource settings)
AddSource xs -> do let merged = oldSources ++ [new]
case checkDuplicate xs (Right uri) of case checkDuplicate oldSources new of
Duplicate Duplicate
| not force -> throwE (DuplicateReleaseChannel uri) | not force -> throwE (DuplicateReleaseChannel new)
DuplicateLast -> pure () DuplicateLast -> pure ()
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) }) _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ SimpleList merged })
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 ()
case r of case r of
VRight _ -> do VRight _ -> do
pure ExitSuccess pure ExitSuccess
@ -244,15 +229,6 @@ config configCommand settings userConf keybindings runLogger = case configComman
| a `elem` xs = Duplicate | a `elem` xs = Duplicate
| otherwise = NoDuplicate | 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 :: MonadIO m => UserSettings -> m ()
doConfig usersettings = do doConfig usersettings = do
let settings' = updateSettings usersettings userConf let settings' = updateSettings usersettings userConf

32
lib-opt/GHCup/OptParse/Install.hs
View File

@ -50,7 +50,7 @@ import qualified Data.Text as T
---------------- ----------------
data InstallCommand = InstallGHC InstallGHCOptions data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions | InstallCabal InstallOptions
| InstallHLS InstallOptions | InstallHLS InstallOptions
| InstallStack InstallOptions | InstallStack InstallOptions
@ -63,16 +63,6 @@ data InstallCommand = InstallGHC InstallGHCOptions
--[ Options ]-- --[ 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 data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instBindist :: Maybe URI , instBindist :: Maybe URI
@ -102,14 +92,14 @@ installCabalFooter = [s|Discussion:
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
installParser :: Parser (Either InstallCommand InstallGHCOptions) installParser :: Parser (Either InstallCommand InstallOptions)
installParser = installParser =
(Left <$> subparser (Left <$> subparser
( command ( command
"ghc" "ghc"
( InstallGHC ( InstallGHC
<$> info <$> info
(installGHCOpts <**> helper) (installOpts (Just GHC) <**> helper)
( progDesc "Install GHC" ( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter) <> footerDoc (Just $ text installGHCFooter)
) )
@ -143,7 +133,7 @@ installParser =
) )
) )
) )
<|> (Right <$> installGHCOpts) <|> (Right <$> installOpts (Just GHC))
where where
installHLSFooter :: String installHLSFooter :: String
installHLSFooter = [s|Discussion: installHLSFooter = [s|Discussion:
@ -219,12 +209,6 @@ installOpts tool =
Just GHC -> False Just GHC -> False
Just _ -> True 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 install installCommand settings getAppState' runLogger = case installCommand of
(Right iGHCopts) -> do (Right iGHCopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.") 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 (InstallHLS iopts)) -> installHLS iopts
(Left (InstallStack iopts)) -> installStack iopts (Left (InstallStack iopts)) -> installStack iopts
where where
installGHC :: InstallGHCOptions -> IO ExitCode installGHC :: InstallOptions -> IO ExitCode
installGHC InstallGHCOptions{..} = do installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (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 (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
v v

8
lib-opt/GHCup/OptParse/Prefetch.hs
View File

@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Prelude.File import GHCup.Prelude.File
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
@ -157,7 +158,9 @@ type PrefetchEffects = '[ TagNotFound
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, JSONError , JSONError
, FileDoesNotExistError ] , FileDoesNotExistError
, StackPlatformDetectError
]
runPrefetch :: MonadUnliftIO m runPrefetch :: MonadUnliftIO m
@ -210,7 +213,8 @@ prefetch prefetchCommand runAppState runLogger =
(v, _) <- liftE $ fromVersion mt Stack (v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
PrefetchMetadata -> do PrefetchMetadata -> do
_ <- liftE getDownloadsF pfreq <- lift getPlatformReq
_ <- liftE $ getDownloadsF pfreq
pure "" pure ""
) >>= \case ) >>= \case
VRight _ -> do VRight _ -> do

181
lib/GHCup/Download.hs
View File

@ -31,10 +31,10 @@ import GHCup.Download.Utils
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import qualified GHCup.Types.Stack as Stack import qualified GHCup.Types.Stack as Stack
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Platform
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.File import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal import GHCup.Prelude.Logger.Internal
@ -56,6 +56,7 @@ import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( mk ) import Data.CaseInsensitive ( mk )
#endif #endif
import Data.Maybe import Data.Maybe
import Data.Either
import Data.List import Data.List
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
@ -113,24 +114,71 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
) )
=> Excepts => PlatformRequest
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] -> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
m m
GHCupInfo GHCupInfo
getDownloadsF = do getDownloadsF pfreq@(PlatformRequest arch plat _) = do
Settings { urlSource } <- lift getSettings Settings { urlSource } <- lift getSettings
case urlSource of let newUrlSources = fromURLSource urlSource
GHCupURL -> liftE $ getBase ghcupURL infos <- liftE $ mapM dl' newUrlSources
(OwnSource exts) -> do keys <- if any isRight infos
ext <- liftE $ mapM (either pure getBase) exts then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
mergeGhcupInfo ext else pure []
(OwnSpec av) -> pure av ghcupInfos <- fmap catMaybes $ forM infos $ \case
(AddSource exts) -> do Left gi -> pure (Just gi)
base <- liftE $ getBase ghcupURL Right si -> pure $ fromStackSetupInfo si keys
ext <- liftE $ mapM (either pure getBase) exts mergeGhcupInfo ghcupInfos
mergeGhcupInfo (base:ext)
where 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 mergeGhcupInfo :: MonadFail m
=> [GHCupInfo] => [GHCupInfo]
-> m GHCupInfo -> m GHCupInfo
@ -142,6 +190,7 @@ getDownloadsF = do
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do yamlFromCache uri = do
Dirs{..} <- getDirs Dirs{..} <- getDirs
@ -152,7 +201,7 @@ etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags") etagsFile = (<.> "etags")
getBase :: ( MonadReader env m getBase :: forall j m env . ( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadFail m , MonadFail m
@ -327,106 +376,6 @@ getDownloadInfo' t v = do
_ -> with_distro <|> without_distro_ver <|> without_distro _ -> 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 -- | Tries to download from the given http or https url

26
lib/GHCup/Errors.hs
View File

@ -676,18 +676,18 @@ instance HFErrorProject ContentLengthError where
eBase _ = 340 eBase _ = 340
eDesc _ = "File content length verification failed" eDesc _ = "File content length verification failed"
data DuplicateReleaseChannel = DuplicateReleaseChannel URI data DuplicateReleaseChannel = DuplicateReleaseChannel NewURLSource
deriving Show deriving Show
instance HFErrorProject DuplicateReleaseChannel where instance HFErrorProject DuplicateReleaseChannel where
eBase _ = 350 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 instance Pretty DuplicateReleaseChannel where
pPrint (DuplicateReleaseChannel uri) = pPrint (DuplicateReleaseChannel source) =
text $ "Duplicate release channel detected when adding: \n " text $ "Duplicate release channel detected when adding: \n "
<> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri <> show source
<> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)." <> "\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
deriving Show deriving Show
@ -787,6 +787,22 @@ instance HFErrorProject GHCupSetError where
eNum (GHCupSetError xs) = 9000 + eNum xs eNum (GHCupSetError xs) = 9000 + eNum xs
eDesc _ = "Setting the current version failed." 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) ]-- --[ True Exceptions (e.g. for MonadThrow) ]--

10
lib/GHCup/GHC.hs
View File

@ -26,7 +26,6 @@ import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Platform
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.File import GHCup.Prelude.File
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
@ -547,14 +546,7 @@ installGHCBin :: ( MonadFail m
m m
() ()
installGHCBin tver installDir forceInstall addConfArgs = do installGHCBin tver installDir forceInstall addConfArgs = do
Settings{ stackSetupSource, stackSetup } <- lift getSettings dlinfo <- liftE $ getDownloadInfo' GHC tver
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
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs

4
lib/GHCup/Platform.hs
View File

@ -23,7 +23,7 @@ import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils import GHCup.Utils.Dirs
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
@ -348,7 +348,7 @@ getStackOSKey PlatformRequest { .. } =
(A_ARM64, FreeBSD) -> pure "freebsd-aarch64" (A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
(arch', os') -> throwE $ UnsupportedSetupCombo arch' os' (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 => PlatformRequest
-> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String] -> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
getStackPlatformKey pfreq@PlatformRequest{..} = do getStackPlatformKey pfreq@PlatformRequest{..} = do

26
lib/GHCup/Prelude.hs
View File

@ -43,6 +43,10 @@ import Control.Monad.Reader
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( Pretty ) import Text.PrettyPrint.HughesPJClass ( Pretty )
import qualified Data.Text as T 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 #-} {-# INLINABLE throwSomeE #-}
throwSomeE = Excepts . pure . VLeft . liftVariant throwSomeE = Excepts . pure . VLeft . liftVariant
#endif #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

49
lib/GHCup/Types.hs
View File

@ -342,18 +342,35 @@ instance Pretty TarDir where
-- | Where to fetch GHCupDownloads from. -- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource [Either GHCupInfo URI] -- ^ complete source list | StackSetupURL
| OwnSpec GHCupInfo | OwnSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ complete source list
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL | OwnSpec (Either GHCupInfo SetupInfo)
deriving (GHC.Generic, Show) | AddSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ merge with GHCupURL
| SimpleList [NewURLSource]
deriving (Eq, GHC.Generic, Show)
data StackSetupURLSource = StackSetupURL data NewURLSource = NewGHCupURL
| SOwnSource [Either SetupInfo URI] -- ^ complete source list | NewStackSetupURL
| SOwnSpec SetupInfo | NewGHCupInfo GHCupInfo
| SAddSource [Either SetupInfo URI] -- ^ merge with GHCupURL | NewSetupInfo SetupInfo
deriving (Show, Eq, GHC.Generic) | 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 URLSource
instance NFData (URIRef Absolute) where instance NFData (URIRef Absolute) where
@ -380,13 +397,11 @@ data UserSettings = UserSettings
, uGPGSetting :: Maybe GPGSetting , uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest , uPlatformOverride :: Maybe PlatformRequest
, uMirrors :: Maybe DownloadMirrors , uMirrors :: Maybe DownloadMirrors
, uStackSetupSource :: Maybe StackSetupURLSource
, uStackSetup :: Maybe Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings 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 -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
@ -404,8 +419,6 @@ fromSettings Settings{..} Nothing =
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors , uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
} }
fromSettings Settings{..} (Just KeyBindings{..}) = fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings let ukb = UserKeyBindings
@ -433,8 +446,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors , uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
} }
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
@ -523,8 +534,6 @@ data Settings = Settings
, noColor :: Bool -- this also exists in LoggerConfig , noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest , platformOverride :: Maybe PlatformRequest
, mirrors :: DownloadMirrors , mirrors :: DownloadMirrors
, stackSetupSource :: StackSetupURLSource
, stackSetup :: Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@ -532,7 +541,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings 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 instance NFData Settings

114
lib/GHCup/Types/JSON.hs
View File

@ -22,6 +22,7 @@ Portability : portable
module GHCup.Types.JSON where module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import GHCup.Types.Stack (SetupInfo)
import GHCup.Types.JSON.Utils import GHCup.Types.JSON.Utils
import GHCup.Types.JSON.Versions () import GHCup.Types.JSON.Versions ()
import GHCup.Prelude.MegaParsec import GHCup.Prelude.MegaParsec
@ -32,7 +33,9 @@ import Data.Aeson.TH
import Data.Aeson.Types hiding (Key) import Data.Aeson.Types hiding (Key)
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.List.NonEmpty ( NonEmpty(..) ) import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe
import Data.Text.Encoding as E import Data.Text.Encoding as E
import Data.Foldable
import Data.Versions import Data.Versions
import Data.Void import Data.Void
import URI.ByteString import URI.ByteString
@ -278,13 +281,29 @@ instance FromJSONKey (Maybe VersionRange) where
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource instance FromJSON GHCupInfo where
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 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 } ''Key
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
@ -297,13 +316,29 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
instance FromJSON URLSource where instance FromJSON URLSource where
parseJSON v = parseJSON v =
parseGHCupURL v parseGHCupURL v
<|> parseStackURL v
<|> parseOwnSourceLegacy v <|> parseOwnSourceLegacy v
<|> parseOwnSourceNew1 v <|> parseOwnSourceNew1 v
<|> parseOwnSourceNew2 v <|> parseOwnSourceNew2 v
<|> parseOwnSpec v <|> parseOwnSpec v
<|> legacyParseAddSource v <|> legacyParseAddSource v
<|> newParseAddSource 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 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 parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
r :: URI <- o .: "OwnSource" r :: URI <- o .: "OwnSource"
pure (OwnSource [Right r]) pure (OwnSource [Right r])
@ -312,20 +347,85 @@ instance FromJSON URLSource where
pure (OwnSource (fmap Right r)) pure (OwnSource (fmap Right r))
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "OwnSource" r :: [Either GHCupInfo URI] <- o .: "OwnSource"
pure (OwnSource r) pure (OwnSource (convert'' <$> r))
parseOwnSpec = withObject "URLSource" $ \o -> do parseOwnSpec = withObject "URLSource" $ \o -> do
r :: GHCupInfo <- o .: "OwnSpec" r :: GHCupInfo <- o .: "OwnSpec"
pure (OwnSpec r) pure (OwnSpec $ Left r)
parseGHCupURL = withObject "URLSource" $ \o -> do parseGHCupURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "GHCupURL" _ :: [Value] <- o .: "GHCupURL"
pure GHCupURL pure GHCupURL
parseStackURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "StackSetupURL"
pure StackSetupURL
legacyParseAddSource = withObject "URLSource" $ \o -> do legacyParseAddSource = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo URI <- o .: "AddSource" r :: Either GHCupInfo URI <- o .: "AddSource"
pure (AddSource [r]) pure (AddSource [convert'' r])
newParseAddSource = withObject "URLSource" $ \o -> do newParseAddSource = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "AddSource" 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) 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 instance FromJSON KeyCombination where
parseJSON v = proper v <|> simple v parseJSON v = proper v <|> simple v
where where

25
lib/GHCup/Utils.hs
View File

@ -89,9 +89,9 @@ import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import Control.DeepSeq (force) import Control.DeepSeq (force)
import GHC.IO (evaluate) import GHC.IO (evaluate)
import System.Environment (getEnvironment)
import Data.Time (Day(..), diffDays, addDays) 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 ]-- --[ Git ]--
----------- -----------

9
test/optparse-test/ConfigTest.hs
View File

@ -5,6 +5,7 @@ module ConfigTest where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import GHCup.OptParse import GHCup.OptParse
import GHCup.Types (NewURLSource(..))
import Utils import Utils
import Control.Monad.IO.Class import Control.Monad.IO.Class
import URI.ByteString.QQ import URI.ByteString.QQ
@ -23,7 +24,13 @@ checkList =
, ("config init", InitConfig) , ("config init", InitConfig)
, ("config show", ShowConfig) , ("config show", ShowConfig)
, ("config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml" , ("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")) , ("config set cache true", SetConfig "cache" (Just "true"))
] ]

54
test/optparse-test/InstallTest.hs
View File

@ -2,9 +2,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module InstallTest where module InstallTest where
@ -16,8 +13,6 @@ import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty (NonEmpty ((:|)))
import GHCup.OptParse.Install as Install import GHCup.OptParse.Install as Install
import URI.ByteString.QQ import URI.ByteString.QQ
import URI.ByteString
import Data.Text (Text)
-- Some interests: -- Some interests:
-- install ghc *won't* select `set as activate version` as default -- install ghc *won't* select `set as activate version` as default
@ -31,52 +26,37 @@ installTests = testGroup "install"
(buildTestTree installParseWith) (buildTestTree installParseWith)
[ ("old-style", oldStyleCheckList) [ ("old-style", oldStyleCheckList)
, ("ghc", installGhcCheckList) , ("ghc", installGhcCheckList)
, ("cabal", (fmap . fmap . fmap) toGHCOptions installCabalCheckList) , ("cabal", installCabalCheckList)
, ("hls", (fmap . fmap . fmap) toGHCOptions installHlsCheckList) , ("hls", installHlsCheckList)
, ("stack", (fmap . fmap . fmap) toGHCOptions installStackCheckList) , ("stack", installStackCheckList)
] ]
toGHCOptions :: InstallOptions -> InstallGHCOptions
toGHCOptions InstallOptions{..}
= InstallGHCOptions instVer
instBindist
instSet
isolateDir
forceInstall
addConfArgs
Nothing
defaultOptions :: InstallOptions defaultOptions :: InstallOptions
defaultOptions = InstallOptions Nothing Nothing False Nothing False [] defaultOptions = InstallOptions Nothing Nothing False Nothing False []
defaultGHCOptions :: InstallGHCOptions
defaultGHCOptions = InstallGHCOptions Nothing Nothing False Nothing False [] Nothing
-- | Don't set as active version -- | Don't set as active version
mkInstallOptions :: ToolVersion -> InstallGHCOptions mkInstallOptions :: ToolVersion -> InstallOptions
mkInstallOptions ver = InstallGHCOptions (Just ver) Nothing False Nothing False [] Nothing mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False []
-- | Set as active version -- | Set as active version
mkInstallOptions' :: ToolVersion -> InstallOptions mkInstallOptions' :: ToolVersion -> InstallOptions
mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False [] mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False []
oldStyleCheckList :: [(String, Either InstallCommand InstallGHCOptions)] oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)]
oldStyleCheckList = oldStyleCheckList =
("install", Right defaultGHCOptions) ("install", Right defaultOptions)
: ("install --set", Right (defaultGHCOptions{instSet = True} :: InstallGHCOptions)) : ("install --set", Right defaultOptions{instSet = True})
: ("install --force", Right (defaultGHCOptions{forceInstall = True} :: InstallGHCOptions)) : ("install --force", Right defaultOptions{forceInstall = True})
#ifdef IS_WINDOWS #ifdef IS_WINDOWS
: ("install -i C:\\\\", Right (defaultGHCOptions{Install.isolateDir = Just "C:\\\\"} :: InstallGHCOptions)) : ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"})
#else #else
: ("install -i /", Right (defaultGHCOptions{Install.isolateDir = Just "/"} :: InstallGHCOptions)) : ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"})
#endif #endif
: ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head" : ("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|] { 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") , instVer = Just $ GHCVersion $ GHCTargetVersion Nothing $(versionQ "head")
} :: InstallGHCOptions) }
) )
: mapSecond : mapSecond
(Right . mkInstallOptions) (Right . mkInstallOptions)
@ -128,9 +108,9 @@ oldStyleCheckList =
) )
] ]
installGhcCheckList :: [(String, Either InstallCommand InstallGHCOptions)] installGhcCheckList :: [(String, Either InstallCommand InstallOptions)]
installGhcCheckList = installGhcCheckList =
("install ghc", Left $ InstallGHC defaultGHCOptions) ("install ghc", Left $ InstallGHC defaultOptions)
: mapSecond (Left . InstallGHC . mkInstallOptions) : mapSecond (Left . InstallGHC . mkInstallOptions)
[ ("install ghc 9.2", GHCVersion [ ("install ghc 9.2", GHCVersion
$ GHCTargetVersion $ GHCTargetVersion
@ -171,7 +151,7 @@ installGhcCheckList =
installCabalCheckList :: [(String, Either InstallCommand InstallOptions)] installCabalCheckList :: [(String, Either InstallCommand InstallOptions)]
installCabalCheckList = installCabalCheckList =
("install cabal", Left $ InstallCabal (defaultOptions{instSet = True} :: InstallOptions)) ("install cabal", Left $ InstallCabal defaultOptions{instSet = True})
: mapSecond (Left . InstallCabal . mkInstallOptions') : mapSecond (Left . InstallCabal . mkInstallOptions')
[ ("install cabal 3.10", ToolVersion $(versionQ "3.10")) [ ("install cabal 3.10", ToolVersion $(versionQ "3.10"))
, ("install cabal next", ToolVersion $(versionQ "next")) , ("install cabal next", ToolVersion $(versionQ "next"))
@ -217,7 +197,7 @@ installStackCheckList =
, ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9")) , ("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 installParseWith args = do
Install a <- parseWith args Install a <- parseWith args
pure a pure a