Compare commits

..

76 Commits

Author SHA1 Message Date
d46bdbf959 Fix misinterpretation of '+' in URI paths, fixes #408 2024-01-03 00:42:01 +08:00
55030d83da Merge branch 'issue-958' 2024-01-01 21:40:36 +08:00
c680a9f33b Support cygwin in bootstrap-haskell too
Fixes #958
2023-12-29 19:56:38 +08:00
df192ee18e Merge remote-tracking branch 'origin/pr/956' 2023-12-26 21:41:40 +08:00
Rune K. Svendsen
008def2ff4 Add comment about why we ignore this error 2023-12-20 10:26:42 +01:00
Rune K. Svendsen
3976daddb7 bootstrap-haskell.ps1: don't exit if tmp file removal fails 2023-12-20 10:21:22 +01:00
524cdbbeb1 Merge remote-tracking branch 'origin/pr/953' 2023-12-15 23:53:59 +08:00
a01c5acfe2 Update submodules 2023-12-15 23:53:41 +08:00
Rune K. Svendsen
6689312ac5 docs: remove "TUI not supported on Windows"
TUI works on Windows since v0.1.20.0 (cf. https://github.com/haskell/ghcup-hs/pull/912)
2023-12-15 16:49:55 +01:00
e214695a3e Merge remote-tracking branch 'origin/pr/850' 2023-12-02 18:42:22 +08:00
3cea6ef97c Merge remote-tracking branch 'origin/pr/937' 2023-11-28 21:25:12 +08:00
3b0f131a65 Merge remote-tracking branch 'origin/pr/940' 2023-11-28 21:08:49 +08:00
konsumlamm
e0a3020e34 Update WASM install instructions 2023-11-28 13:55:52 +01:00
Luis Morillo
0e46b9509a complete tutorial. remove show all tools from widgets. resolve some conflicts. 2023-11-23 16:05:12 +01:00
Luis Morillo
d3474d0cd9 add KeyInfo handler and widget. Improve tutorial 2023-11-23 15:32:23 +01:00
Luis Morillo
5c3dad1bb9 reorganize code by sections 2023-11-23 15:31:33 +01:00
Luis Morillo
987cdaf313 factor out attr names. Add windows symbols to tutotial widget. Improve tutorial aesthetics and text 2023-11-23 15:28:21 +01:00
Luis Morillo
835352428a simplify rendering for better ux 2023-11-23 15:28:19 +01:00
Luis Morillo
8f4246e716 Use proper Name type and Modal type. Create tutorial Widget 2023-11-23 15:27:33 +01:00
Luis Morillo
1353a2fd20 use map-like data structure 2023-11-23 15:26:49 +01:00
Luis Morillo
aa9fbdbfc2 Use MonadState Instance to simplify install', del', set' and changelog'. Lensify the app 2023-11-23 15:24:24 +01:00
3a8cdf9967 Fix opening changelog on windows 2023-11-20 22:36:17 +08:00
2caf491e9d Remove the "show all tool" config
We show all tools at the moment anyway.
2023-11-18 18:55:06 +08:00
d277e56121 Improve logging by dropping trailing newline 2023-11-18 13:09:19 +08:00
335099ad19 Add rocky/void detection 2023-11-17 17:03:10 +08:00
b1106985ec Merge branch 'monday-improvements' 2023-11-14 23:16:42 +08:00
cd8ce9aaa9 Update test artifact upload 2023-11-14 22:11:28 +08:00
18f0cb086b Fix tests 2023-11-14 09:37:07 +08:00
dee54445bf Merge remote-tracking branch 'origin/pr/928' 2023-11-13 17:50:37 +08:00
Bryan Richter
2df59fd1b3 Emphasize experimental nature of wasm and js 2023-11-13 11:28:14 +02:00
2e5dee8e1a Add mechanism to warn on new metadata versions, fixes #860 2023-11-13 16:53:24 +08:00
c6aa5c3ed7 Don't remove share dir link prematurely 2023-11-13 16:00:48 +08:00
47ef380ebd Add update-shell-completions.sh 2023-11-13 16:00:31 +08:00
d6601b0353 Remove globalTools from metadata 2023-11-13 15:39:58 +08:00
0eba225723 Update modgraph 2023-11-13 15:21:54 +08:00
e7d91d138b Improve metadata documentation 2023-11-13 15:19:58 +08:00
0103e2771e Merge branch 'sunday-improvements' 2023-11-12 22:50:09 +08:00
b6246734e4 Givee cross bindists it's own doc section 2023-11-12 18:47:54 +08:00
6146c3494f Improve documentation for cross bindists 2023-11-12 18:39:06 +08:00
e5a7a2da70 Fix prefetch for cross bindists 2023-11-12 18:21:49 +08:00
6047614a16 Be less confusing when user tries to 'set' ghcup in TUI
Fixes #923
2023-11-12 17:36:00 +08:00
6a86e9e77e Fix failure mode when metadata is garbage, fixes #921 2023-11-12 17:11:33 +08:00
4132447e04 Require user to explicitly choose subcommand for 'ghcup config'
This should further reduce confusion wrt #922
2023-11-12 16:49:39 +08:00
9d223730de Error out on empty UserSettings wrt #922 2023-11-12 16:49:06 +08:00
ad9199568b Don't download twice when trying stack decoding 2023-11-12 16:24:39 +08:00
0d91c2ac14 Make install error more visible 2023-11-12 15:59:15 +08:00
8644ca41e1 Merge remote-tracking branch 'origin/pr/924' 2023-11-12 12:19:56 +08:00
Cheng Shao
6051c0cfbc Bump minimum windows version to 8.1 2023-11-11 06:18:13 +01:00
67d977ce39 Update metadata submodule 2023-11-10 21:42:31 +08:00
8b6b3d2fbe Update bootstrap script ghver 2023-11-10 21:41:19 +08:00
a5d228ba89 Bump to 0.1.20.0 2023-11-10 19:53:04 +08:00
a7be1e7068 Merge branch 'brick-windows' 2023-11-10 19:32:20 +08:00
30a10d871a Update bootstrap script 2023-11-09 23:42:31 +08:00
90b0281c1c Merge remote-tracking branch 'origin/pr/918' 2023-11-09 23:30:05 +08:00
Tom Smeding
bba92baeb1 Fix typo in ToolShadowed error for stack 2023-11-09 13:41:21 +01:00
e06a1c03d4 Merge remote-tracking branch 'origin/pr/911' 2023-11-09 18:00:06 +08:00
0171f2e870 Merge branch 'issue-914' 2023-11-09 17:53:42 +08:00
da078c7362 Use prompt for desktop shortcuts, fixes #914 2023-11-09 17:24:41 +08:00
94b4b7c455 Merge branch 'issue-913' 2023-11-06 22:12:46 +08:00
6aa486594a Redo ghc-install.sh, fixes #913 2023-11-06 18:23:02 +08:00
2c3148abcc Update supported tools table, fixes #915 2023-11-06 18:20:36 +08:00
dde32fa72e Ensure patched version of vty-windows is used 2023-11-06 17:35:20 +08:00
675ab17fff Improve signs on windows (no unicode) 2023-11-05 22:29:55 +08:00
9fcacbd96b Fix CPP defines for windows+brick 2023-11-05 22:22:53 +08:00
ba4c6e5b99 Relax vector upper bound 2023-11-05 17:33:54 +08:00
f2b139b58b Drop temp source-repository stanza for 'versions' 2023-11-05 17:32:25 +08:00
a44bf5884d Enable tui for windows in release builds 2023-11-05 17:32:25 +08:00
64c1d63d33 Allow tui flag for windows as well 2023-11-05 17:32:25 +08:00
0300d8f2cc Bump for brick windows 2023-11-05 17:20:29 +08:00
citrusmunch
bb395b652d Fix typo in guide.md
xdg section is below (not above)
2023-11-01 12:04:43 -04:00
59bfdd9a30 Stack docs improvement 2023-10-25 15:01:18 +08:00
d85accb08e Merge branch 'improve-stack-setup-use' 2023-10-25 15:01:04 +08:00
c7439d3c89 Improve stack metadata support wrt #892 2023-10-25 14:00:01 +08:00
38cd5ad8ed Merge branch 'improved-key-brick' 2023-10-24 15:00:31 +08:00
5fd0fa8d8e Merge branch 'issue-892' 2023-10-24 15:00:10 +08:00
452ca8cca2 Improve key handling in TUI, fixes #875 2023-10-23 22:47:17 +08:00
43 changed files with 17616 additions and 16537 deletions

View File

@@ -322,7 +322,7 @@ jobs:
with: with:
name: testfiles name: testfiles
path: | path: |
./test/golden/unix/GHCupInfo*json ./test/ghcup-test/golden/unix/GHCupInfo*json
test-arm: test-arm:
name: Test ARM name: Test ARM
@@ -389,7 +389,7 @@ jobs:
with: with:
name: testfiles name: testfiles
path: | path: |
./test/golden/unix/GHCupInfo*json ./test/ghcup-test/golden/unix/GHCupInfo*json
test-macwin: test-macwin:
name: Test Mac/Win name: Test Mac/Win
@@ -458,7 +458,7 @@ jobs:
with: with:
name: testfiles name: testfiles
path: | path: |
./test/golden/windows/GHCupInfo*json ./test/ghcup-test/golden/windows/GHCupInfo*json
- if: failure() && runner.os != 'Windows' - if: failure() && runner.os != 'Windows'
name: Upload artifact name: Upload artifact
@@ -466,7 +466,7 @@ jobs:
with: with:
name: testfiles name: testfiles
path: | path: |
./test/golden/unix/GHCupInfo*json ./test/ghcup-test/golden/unix/GHCupInfo*json
hls: hls:
name: hls name: hls
needs: build-linux needs: build-linux

View File

@@ -1,8 +1,20 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.19.5 -- ????-?-?? ## 0.1.20.0 -- 2023-11-10
* support JS cross compilers wrt [#838](https://github.com/haskell/ghcup-hs/issues/838) ### New features
* support TUI on windows thanks to the work from vty and brick maintainers (Chris Hackett, Timofey Zakrevskiy, Jonathan Daugherty, ...), wrt [#912](https://github.com/haskell/ghcup-hs/pull/912)
* support JS and wasm cross compilers wrt [#838](https://github.com/haskell/ghcup-hs/issues/838), thanks to Sylvain Henry and IOG
* Support stacks installation strategy and metadata wrt [#892](https://github.com/haskell/ghcup-hs/issues/892)
- you can now enable stacks installation method via `ghcup config set url-source '["GHCupURL", "StackSetupURL"]'`... for more information, check the [documentation](https://www.haskell.org/ghcup/guide/#using-stacks-setup-info-metadata-to-install-ghc)
### Improvements and bug fixes
* fix segfault in TUI when hitting enter early wrt [#887](https://github.com/haskell/ghcup-hs/issues/887)
* Improve key handling in TUI, fixes [#875](https://github.com/haskell/ghcup-hs/issues/875)
* add explicit support for Void Linux and Rocky Linux (this requires a metadata version bump to `ghcup-0.0.8.yaml`)
* optparse cli interface now has a test suite thanks to Lei Zhu, wrt [#862](https://github.com/haskell/ghcup-hs/pull/862)
## 0.1.19.4 -- 2023-7-02 ## 0.1.19.4 -- 2023-7-02

File diff suppressed because it is too large Load Diff

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
@@ -110,7 +107,6 @@ toSettings options = do
, bSet = fromMaybe bSet kSet , bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog , bChangelog = fromMaybe bChangelog kChangelog
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll , bShowAllVersions = fromMaybe bShowAllVersions kShowAll
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
} }
@@ -213,10 +209,9 @@ 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
VLeft e -> do VLeft e -> do
@@ -265,7 +260,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
Just _ -> pure () Just _ -> pure ()
-- TODO: always run for windows -- TODO: always run for windows
siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case siletRunLogger (flip runReaderT s' $ runE ensureShimGen) >>= \case
VRight _ -> pure () VRight _ -> pure ()
VLeft e -> do VLeft e -> do
runLogger runLogger
@@ -341,8 +336,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 +375,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)

View File

@@ -13,6 +13,11 @@ source-repository-package
location: https://github.com/fosskers/versions.git location: https://github.com/fosskers/versions.git
tag: 7bc3355348aac3510771d4622aff09ac38c9924d tag: 7bc3355348aac3510771d4622aff09ac38c9924d
source-repository-package
type: git
location: https://github.com/hasufell/uri-bytestring.git
tag: 4fb5ed14b500c192e6e7a97f6b2b1eb478806001
package libarchive package libarchive
flags: -system-libarchive flags: -system-libarchive

View File

@@ -4,35 +4,26 @@ optional-packages: ./vendored/*/*.cabal
optimization: 2 optimization: 2
source-repository-package package ghcup
type: git flags: +tui
location: https://github.com/fosskers/versions.git
tag: 7bc3355348aac3510771d4622aff09ac38c9924d
if os(linux) if os(linux)
package ghcup
flags: +tui
if arch(x86_64) || arch(i386) if arch(x86_64) || arch(i386)
package * package *
ghc-options: -split-sections -optl-static ghc-options: -split-sections -optl-static
elif os(darwin) elif os(darwin)
constraints: zlib +bundled-c-zlib, constraints: zlib +bundled-c-zlib,
lzma +static lzma +static
package ghcup
flags: +tui
elif os(mingw32) elif os(mingw32)
constraints: zlib +bundled-c-zlib, constraints: zlib +bundled-c-zlib,
lzma +static, lzma +static,
text -simdutf text -simdutf,
package ghcup vty-windows >=0.1.0.3
flags: -tui
elif os(freebsd) elif os(freebsd)
constraints: zlib +bundled-c-zlib, constraints: zlib +bundled-c-zlib,
zip +disable-zstd zip +disable-zstd
package * package *
ghc-options: -split-sections -pgmc clang++14 ghc-options: -split-sections -pgmc clang++14
package ghcup
flags: +tui
constraints: http-io-streams -brotli, constraints: http-io-streams -brotli,
any.aeson >= 2.0.1.0, any.aeson >= 2.0.1.0,

View File

@@ -16,6 +16,11 @@ gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
# TUI key bindings, # TUI key bindings,
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
# for possible values. # for possible values.
# It's also possible to define key+modifier, e.g.:
# quit:
# Key:
# KChar: c
# Mods: [MCtrl]
key-bindings: key-bindings:
up: up:
KUp: [] KUp: []
@@ -46,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
# ghcupDownloads:
# GHC:
# 9.10.2:
# viTags: []
# viArch:
# A_64:
# Linux_UnknownLinux:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
# dlSubdir: ghc-7.10.3
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate ## Use dwarf bindist for 9.4.7 for ghcup metadata
## versions). # - ghcup-info:
# AddSource: # ghcupDownloads:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml" # GHC:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" # 9.4.7:
# viTags: []
# For stack's setup-info, this works similar, e.g.: # viArch:
# stack-setup-source: # A_64:
# AddSource: # Linux_UnknownLinux:
# - Left: # unknown_versioning:
# ghc: # dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz
# linux64-tinfo6: # dlSubdir:
# 9.4.7: # RegexDir: "ghc-.*"
# url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz" # dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4
# content-length: 179117892
# sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
## 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 # 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:

View File

@@ -4,7 +4,7 @@ This is a more in-depth guide specific to GHCup. `ghcup --help` is your friend.
## Basic usage ## Basic usage
For the simple, interactive, text-based user interface (TUI) (not available on windows), run: For the simple, interactive, text-based user interface (TUI), run:
```sh ```sh
ghcup tui ghcup tui
@@ -67,8 +67,7 @@ and make sure your bashrc sources the startup script
`ghcup` is very portable. There are a few exceptions though: `ghcup` is very portable. There are a few exceptions though:
1. `ghcup tui` is only available on non-windows platforms 1. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
# Configuration # Configuration
@@ -95,7 +94,7 @@ platform-override:
This is the complete list of env variables that change GHCup behavior: This is the complete list of env variables that change GHCup behavior:
* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above * `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) below
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`) * `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl * `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget * `GHCUP_WGET_OPTS`: additional options that can be passed to wget
@@ -142,50 +141,29 @@ If you experience problems, consider clearing the cache via `ghcup gc --cache`.
## Metadata ## Metadata
The metadata are the files that describe tool versions, where to download them etc. and Metadata files are also called release or distribution channels. They describe tool versions, where to download them etc. and
can be viewed here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) can be viewed here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata).
### Mirrors See the [description](https://github.com/haskell/ghcup-metadata#metadata-variants-distribution-channels)
of metadata files to understand their purpose. These can be combined.
GHCup allows to use custom mirrors/download-info hosted by yourself or 3rd parties. For example, if you want access to both prerelease and cross bindists, you'd do:
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"
```
See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
for more options.
Alternatively you can do it via a cli switch:
```sh
ghcup --url-source=https://some-url/ghcup-0.0.6.yaml list
```
#### Known mirrors
1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
2. [https://mirrors.ustc.edu.cn/help/ghcup.html](https://mirrors.ustc.edu.cn/help/ghcup.html)
### (Pre-)Release channels
A release channel is basically just a metadata file location. You can add additional release
channels that complement the default one, such as the **prerelease channel** like so:
```sh ```sh
ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml
``` ```
This will result in `~/.ghcup/config.yaml` to contain this record: This results in the following configuration in `~/.ghcup/config.yaml`:
```yml ```yaml
url-source: url-source:
AddSource: # the base url that contains all the release bindists
- Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml - GHCupURL
# prereleases
- https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml
# cross bindists
- https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.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,18 +173,68 @@ 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: Also see [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
for more options.
You can also use an alternative metadata via one-shot cli option:
```sh
ghcup --url-source=https://some-url/ghcup-0.0.8.yaml tui
```
One main caveat of using URLs is that you might need to check whether there are new versions
of the file (e.g. `ghcup-0.0.7.yaml` vs `ghcup-0.0.8.yaml`). Although old metadata files
are supported for some time, they are not so indefinitely.
### Mirrors
Metadata files can also be used to operate 3rd party mirrors, in which case you want to use
a URL instead of the `GHCupURL` alias. E.g. in `~/.ghcup/config.yaml`, you'd do:
```yml ```yml
url-source: url-source:
OwnSource: - https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml
# base metadata ```
- "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
# prerelease channel Note that later versions of GHCup allow more sophisticated mirror support, see [here](./#mirrors-proper).
- "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
#### Known mirrors
1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
2. [https://mirrors.ustc.edu.cn/help/ghcup.html](https://mirrors.ustc.edu.cn/help/ghcup.html)
### Git based metadata config
If you don't like the way ghcup updates its metadata with caching and fetching via curl, you can also do as follows:
Clone the metadata git repo:
```sh
mkdir -p /home/user/git/
cd /home/user/git/
git clone -b master https://github.com/haskell/ghcup-metadata.git
```
Then tell ghcup to use file locations in `~/.ghcup/config.yaml`, e.g.:
```yaml
url-source:
- file:///home/user/git/ghcup-metadata/ghcup-0.0.8.yaml
- file:///home/user/git/ghcup-metadata/ghcup-cross-0.0.8.yaml
- file:///home/user/git/ghcup-metadata/ghcup-prereleases-0.0.8.yaml
```
Now, if you invoke `ghcup tui`, it will open instantly without any download, since it just
reads the metadata from local disk.
You'll have to update the metadata manually though, like so:
```sh
cd /home/user/git/
git pull --ff-only origin master
``` ```
## Stack integration ## Stack integration
@@ -249,24 +277,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:
@@ -275,9 +311,14 @@ stack-setup-source:
sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
``` ```
#### Caveats
The main caveat with using this method is that there's no guarantee that GHCup will pick a compatible HLS bindist The main caveat with using this method is that there's no guarantee that GHCup will pick a compatible HLS bindist
when you try to install HLS. when you try to install HLS.
Another potential usability issue is that the `latest` and `recommended` shorthands won't work anymore, since
Stack metadata doesn't have a concept of those and we don't try to be smart when combining the metadatas.
### Windows ### Windows
On windows, you may find the following config options useful too: On windows, you may find the following config options useful too:
@@ -285,6 +326,39 @@ On windows, you may find the following config options useful too:
Also check out: [https://docs.haskellstack.org/en/stable/yaml_configuration](https://docs.haskellstack.org/en/stable/yaml_configuration) Also check out: [https://docs.haskellstack.org/en/stable/yaml_configuration](https://docs.haskellstack.org/en/stable/yaml_configuration)
## Mirrors (proper)
Mirrors are now supported via configuration, instead of specifying alternative metadata files.
As an example, this would be a complete mirror configuration in `~/.ghcup/config.yaml`:
```yaml
mirrors:
# yaml download location, would result in:
# https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-0.0.8.yaml
# -> https://mirror.sjtu.edu.cn/ghcup/yaml/haskell/ghcup-metadata/master/ghcup-0.0.8.yaml
"raw.githubusercontent.com":
authority:
host: "mirror.sjtu.edu.cn"
pathPrefix: "ghcup/yaml"
# for stack and some older HLS versions, would result in e.g.
# https://github.com/haskell/haskell-language-server/releases/download/1.2.0/haskell-language-server-Windows-1.2.0.tar.gz
# -> https://mirror.sjtu.edu.cn/ghcup/github/haskell/haskell-language-server/releases/download/1.2.0/haskell-language-server-Windows-1.2.0.tar.gz
"github.com":
authority:
host: "mirror.sjtu.edu.cn"
pathPrefix: "ghcup/github"
# for all haskell.org hosted bindists, would result in e.g.
# https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-deb10-linux.tar.xz
# -> https://mirror.sjtu.edu.cn/ghcup/haskell-downloads/~ghc/9.8.1/ghc-9.8.1-x86_64-deb10-linux.tar.xz
"downloads.haskell.org":
authority:
host: "mirror.sjtu.edu.cn"
pathPrefix: "downloads.haskell.org"
```
The configuration depends on the host of the mirror and they have to provide the correct configuration.
# More on installation # More on installation
## Customisation of the installation scripts ## Customisation of the installation scripts
@@ -421,9 +495,9 @@ ghcup compile hls --git-ref master --git-describe-version --ghc 8.10.7 --ghc 9.2
This however will create a new HLS version in ghcup, e.g. `1.7.0.0-105-gdc682ba1`, for both 8.10.7 and 9.2.4. If you want to switch back to the official bindists, run `ghcup set hls 1.7.0.0`. This however will create a new HLS version in ghcup, e.g. `1.7.0.0-105-gdc682ba1`, for both 8.10.7 and 9.2.4. If you want to switch back to the official bindists, run `ghcup set hls 1.7.0.0`.
### Cross support ## Cross support
ghcup can compile and install a cross GHC for any target. However, this ghcup can compile a cross GHC for any target. However, this
requires that the build host has a complete cross toolchain and various requires that the build host has a complete cross toolchain and various
libraries installed for the target platform. libraries installed for the target platform.
@@ -432,6 +506,76 @@ For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args. libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information. See `ghcup compile ghc --help` for further information.
Since ghcup version 0.1.20.0, we provide cross bindists for GHC JS and WASM. These can be installed conveniently.
However, these are intended as a developer preview only. By using these GHC variants, you are implicitly signing up to participate in GHC development!
If you run into bugs or missing behavior, join the dev chat at https://matrix.to/#/#GHC:matrix.org.
First, add the cross release channel:
```sh
ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-cross-0.0.8.yaml
```
The next sections explain how to install each cross bindist.
### GHC JS cross bindists (experimental)
You need the required emscripten JS toolchain:
```sh
git clone https://github.com/emscripten-core/emsdk.git
cd emsdk
./emsdk install latest
./emsdk activate latest
source ./emsdk_env.sh
```
Instructions are also here: [Download and install — Emscripten 3.1.43-git (dev) documentation](https://emscripten.org/docs/getting_started/downloads.html).
To install we need to invoke ghcup like so:
```sh
emconfigure ghcup install ghc --set javascript-unknown-ghcjs-9.6.2
```
You'll now have the compiler `javascript-unknown-ghcjs-ghc`. To build a hello world, do e.g.:
```sh
echo 'main = putStrLn "hello world"' > hello.hs
javascript-unknown-ghcjs-ghc -fforce-recomp hello.hs
./hello
```
You can follow the instructions [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend/building#compiling-hello-world).
### GHC WASM cross bindists (experimental)
You need the required wasm toolchain:
```sh
git clone https://gitlab.haskell.org/ghc/ghc-wasm-meta.git
cd ghc-wasm-meta/
export SKIP_GHC=yes
./setup.sh
source ~/.ghc-wasm/env
```
To install, we need to invoke ghcup like so also passing the `--host=<host>` flag (adjust as needed):
```sh
ghcup install ghc --set wasm32-wasi-9.6.3.20230927 -- --host=x86_64-linux --with-intree-gmp --with-system-libffi
```
Also check the documentation here: [Glasgow Haskell Compiler / ghc-wasm-meta](https://gitlab.haskell.org/ghc/ghc-wasm-meta).
You'll now have the compiler `wasm32-wasi-ghc`. To build a hello world, do e.g.:
```sh
echo 'main = putStrLn "hello world"' > hello.hs
wasm32-wasi-ghc hello.hs -o hello.wasm
wasmtime ./hello.wasm
```
## Isolated installs ## Isolated installs
**Before using isolated installs, make sure to have at least GHCup version 0.1.17.8!** **Before using isolated installs, make sure to have at least GHCup version 0.1.17.8!**

View File

@@ -140,16 +140,18 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead> <thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>9.6.2</td><td><span style="color:blue">latest</span>, base-4.18.0.0</td></tr> <tr><td>9.8.1</td><td><span style="color:blue">latest</span>, base-4.19.0.0</td></tr>
<tr><td>9.6.3</td><td>base-4.18.1.0</td></tr>
<tr><td>9.6.2</td><td>base-4.18.0.0</td></tr>
<tr><td>9.6.1</td><td>base-4.18.0.0</td></tr> <tr><td>9.6.1</td><td>base-4.18.0.0</td></tr>
<tr><td>9.4.7</td><td>base-4.17.2.0</td></tr> <tr><td>9.4.7</td><td><span style="color:green">recommended</span>, base-4.17.2.0</td></tr>
<tr><td>9.4.6</td><td>base-4.17.2.0</td></tr> <tr><td>9.4.6</td><td>base-4.17.2.0</td></tr>
<tr><td>9.4.5</td><td>base-4.17.1.0</td></tr> <tr><td>9.4.5</td><td>base-4.17.1.0</td></tr>
<tr><td>9.4.4</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.4</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.3</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.3</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.2</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.2</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.1</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.1</td><td>base-4.17.0.0</td></tr>
<tr><td>9.2.8</td><td><span style="color:green">recommended</span>, base-4.16.4.0</td></tr> <tr><td>9.2.8</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.7</td><td>base-4.16.4.0</td></tr> <tr><td>9.2.7</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.6</td><td>base-4.16.4.0</td></tr> <tr><td>9.2.6</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.5</td><td>base-4.16.4.0</td></tr> <tr><td>9.2.5</td><td>base-4.16.4.0</td></tr>
@@ -190,7 +192,8 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead> <thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>3.10.1.0</td><td><span style="color:blue">latest</span></td></tr> <tr><td>3.10.2.0</td><td><span style="color:blue">latest</span></td></tr>
<tr><td>3.10.1.0</td><td></td></tr>
<tr><td>3.8.1.0</td><td></td></tr> <tr><td>3.8.1.0</td><td></td></tr>
<tr><td>3.6.2.0</td><td><span style="color:green">recommended</span></td></tr> <tr><td>3.6.2.0</td><td><span style="color:green">recommended</span></td></tr>
<tr><td>3.6.0.0</td><td></td></tr> <tr><td>3.6.0.0</td><td></td></tr>
@@ -234,8 +237,9 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead> <thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>2.11.1</td><td><span style="color:blue">latest</span></td></tr> <tr><td>2.13.1</td><td><span style="color:blue">latest</span></td></tr>
<tr><td>2.9.3</td><td><span style="color:green">recommended</span></td></tr> <tr><td>2.11.1</td><td><span style="color:green">recommended</span></td></tr>
<tr><td>2.9.3</td><td></td></tr>
<tr><td>2.9.1</td><td></td></tr> <tr><td>2.9.1</td><td></td></tr>
<tr><td>2.7.5</td><td></td></tr> <tr><td>2.7.5</td><td></td></tr>
<tr><td>2.7.3</td><td></td></tr> <tr><td>2.7.3</td><td></td></tr>
@@ -251,7 +255,7 @@ This list may not be exhaustive and specifies support for bindists only.
| Platform | Architecture | ghcup | GHC | cabal | HLS | stack | | Platform | Architecture | ghcup | GHC | cabal | HLS | stack |
| ------ | ------ | ------ | ------ | ------ | ------ | ------ | | ------ | ------ | ------ | ------ | ------ | ------ | ------ |
| Windows 7 | amd64 | | ✅ | ✅ | ✅ | ✅ | | Windows 8.1 | amd64 | | ✅ | ✅ | ✅ | ✅ |
| Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ | | Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows Server 2016 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ | | Windows Server 2016 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows Server 2019 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ | | Windows Server 2019 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
@@ -267,12 +271,11 @@ This list may not be exhaustive and specifies support for bindists only.
| Linux generic | aarch64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ | | Linux generic | aarch64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
| Linux generic | armv7 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ | | Linux generic | armv7 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
### Windows 7 ### Windows <8.1
May or may not work, several issues: No longer supported for recent GHCs, according to manual testing of GHC 9.8.1 on Windows 7.
According to [msys2 documentation](https://www.msys2.org/docs/windows_support), the minimum Windows
* [https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140) version is now 8.1.
* [https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197)
### WSL1 ### WSL1

File diff suppressed because it is too large Load Diff

Before

Width:  |  Height:  |  Size: 40 KiB

After

Width:  |  Height:  |  Size: 27 KiB

File diff suppressed because it is too large Load Diff

Before

Width:  |  Height:  |  Size: 40 KiB

After

Width:  |  Height:  |  Size: 28 KiB

View File

@@ -1,6 +1,6 @@
cabal-version: 2.4 cabal-version: 2.4
name: ghcup name: ghcup
version: 0.1.19.5 version: 0.1.20.0
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
@@ -36,7 +36,7 @@ source-repository head
flag tui flag tui
description: description:
Build the brick powered tui (ghcup tui). This is disabled on windows. Build the brick powered tui (ghcup tui).
default: False default: False
manual: True manual: True
@@ -86,7 +86,7 @@ common app-common-depends
, unordered-containers ^>=0.2 , unordered-containers ^>=0.2
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0 , utf8-string ^>=1.0
, vector ^>=0.12 , vector >=0.12 && <0.14
, versions >=6.0.3 && <6.1 , versions >=6.0.3 && <6.1
, yaml-streamly ^>=0.12.0 , yaml-streamly ^>=0.12.0
@@ -190,7 +190,7 @@ library
, unliftio-core ^>=0.2.0.1 , unliftio-core ^>=0.2.0.1
, unordered-containers ^>=0.2.10.0 , unordered-containers ^>=0.2.10.0
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
, vector ^>=0.12 , vector >=0.12 && <0.14
, versions >=6.0.3 && <6.1 , versions >=6.0.3 && <6.1
, word8 ^>=0.1.3 , word8 ^>=0.1.3
, yaml-streamly ^>=0.12.0 , yaml-streamly ^>=0.12.0
@@ -236,9 +236,9 @@ library
, unix ^>=2.7 , unix ^>=2.7
, unix-bytestring ^>=0.3.7.3 , unix-bytestring ^>=0.3.7.3
if (flag(tui) && !os(windows)) if flag(tui)
cpp-options: -DBRICK cpp-options: -DBRICK
build-depends: vty ^>=5.39 build-depends: vty ^>=6.0
library ghcup-optparse library ghcup-optparse
import: app-common-depends import: app-common-depends
@@ -284,7 +284,7 @@ library ghcup-optparse
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
if (flag(tui) && !os(windows)) if flag(tui)
cpp-options: -DBRICK cpp-options: -DBRICK
if os(windows) if os(windows)
@@ -320,14 +320,15 @@ executable ghcup
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
if (flag(tui) && !os(windows)) if flag(tui)
cpp-options: -DBRICK cpp-options: -DBRICK
other-modules: BrickMain other-modules: BrickMain
build-depends: build-depends:
, brick ^>=1.5 , brick ^>=2.1
, transformers ^>=0.5 , transformers ^>=0.5
, vty ^>=6.0
, unix ^>=2.7 , unix ^>=2.7
, vty ^>=5.39 , optics ^>=0.4
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS

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

View File

@@ -29,6 +29,7 @@ import Data.Maybe
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import System.Process ( system )
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T import qualified Data.Text as T
@@ -128,21 +129,22 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
Just uri -> do Just uri -> do
pfreq <- runAppState getPlatformReq pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
if clOpen if clOpen
then do then do
runAppState $ runAppState $
exec cmd case _rPlatform pfreq of
[T.unpack $ decUTF8Safe $ serializeURIRef' uri] Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Nothing Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Nothing FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Windows -> do
let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri)
c <- liftIO $ system $ args
case c of
(ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args]
ExitSuccess -> pure $ Right ()
>>= \case >>= \case
Right _ -> pure ExitSuccess Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyHFError e) Left e -> logError (T.pack $ prettyHFError e)
>> pure (ExitFailure 13) >> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess else liftIO $ putStrLn uri' >> pure ExitSuccess

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,13 +461,15 @@ tagCompleter tool add = listIOCompleter $ do
defaultKeyBindings defaultKeyBindings
loggerConfig loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF mpFreq <- flip runReaderT appState . runE $ platformRequest
case mGhcUpInfo of forFold mpFreq $ \pfreq -> do
VRight ghcupInfo -> do mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
let allTags = filter (/= Old) case mGhcUpInfo of
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool) VRight ghcupInfo -> do
pure $ nub $ (add ++) $ fmap tagToString allTags let allTags = filter (/= Old)
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add) $ _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 :: [ListCriteria] -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True) versionCompleter criteria tool = versionCompleter' criteria tool (const True)
@@ -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')

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)
@@ -68,15 +67,14 @@ configP = subparser
<> command "show" showP <> command "show" showP
<> command "add-release-channel" addP <> command "add-release-channel" addP
) )
<|> argsP -- add show for a single option
<|> pure ShowConfig <|> pure ShowConfig
where where
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml") initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
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 +133,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
@@ -153,7 +149,6 @@ updateSettings usl usr =
, kSet = kSet kbl <|> kSet kbr , kSet = kSet kbl <|> kSet kbr
, kChangelog = kChangelog kbl <|> kChangelog kbr , kChangelog = kChangelog kbl <|> kChangelog kbr
, kShowAll = kShowAll kbl <|> kShowAll kbr , kShowAll = kShowAll kbl <|> kShowAll kbr
, kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr
} }
@@ -196,10 +191,14 @@ config configCommand settings userConf keybindings runLogger = case configComman
throwE $ ParseError "Empty values are not allowed" throwE $ ParseError "Empty values are not allowed"
Nothing -> do Nothing -> do
usersettings <- decodeSettings k usersettings <- decodeSettings k
when (usersettings == defaultUserSettings)
$ throwE $ ParseError ("Failed to parse setting (maybe typo?): " <> k)
lift $ doConfig usersettings lift $ doConfig usersettings
pure () pure ()
Just v -> do Just v -> do
usersettings <- decodeSettings (k <> ": " <> v <> "\n") usersettings <- decodeSettings (k <> ": " <> v <> "\n")
when (usersettings == defaultUserSettings)
$ throwE $ ParseError ("Failed to parse key '" <> k <> "' with value '" <> v <> "' as user setting. Maybe typo?")
lift $ doConfig usersettings lift $ doConfig usersettings
pure () pure ()
case r of case r of
@@ -207,29 +206,19 @@ config configCommand settings userConf keybindings runLogger = case configComman
VLeft (V (JSONDecodeError e)) -> do VLeft (V (JSONDecodeError e)) -> do
runLogger $ logError $ "Error decoding config: " <> T.pack e runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65 pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65 VLeft e -> do
runLogger (logError $ T.pack $ prettyHFError e)
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 +233,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

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

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
@@ -196,21 +199,22 @@ prefetch prefetchCommand runAppState runLogger =
(v, _) <- liftE $ fromVersion mt GHC (v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc if pfGHCSrc
then liftE $ fetchGHCSrc v pfCacheDir then liftE $ fetchGHCSrc v pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir else liftE $ fetchToolBindist v GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Cabal (v, _) <- liftE $ fromVersion mt Cabal
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir liftE $ fetchToolBindist v Cabal pfCacheDir
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt HLS (v, _) <- liftE $ fromVersion mt HLS
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir liftE $ fetchToolBindist v HLS pfCacheDir
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Stack (v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir liftE $ fetchToolBindist v Stack pfCacheDir
PrefetchMetadata -> do PrefetchMetadata -> do
_ <- liftE getDownloadsF pfreq <- lift getPlatformReq
_ <- liftE $ getDownloadsF pfreq
pure "" pure ""
) >>= \case ) >>= \case
VRight _ -> do VRight _ -> do

View File

@@ -100,7 +100,7 @@ fetchToolBindist :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => GHCTargetVersion
-> Tool -> Tool
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
@@ -113,7 +113,7 @@ fetchToolBindist :: ( MonadFail m
m m
FilePath FilePath
fetchToolBindist v t mfp = do fetchToolBindist v t mfp = do
dlinfo <- liftE $ getDownloadInfo t v dlinfo <- liftE $ getDownloadInfo' t v
liftE $ downloadCached' dlinfo Nothing mfp liftE $ downloadCached' dlinfo Nothing mfp

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,33 +114,84 @@ 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 ghcupURL) >>= liftE . decodeMetadata @GHCupInfo
dl' NewStackSetupURL = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo
dl' (NewGHCupInfo gi) = pure (Left gi)
dl' (NewSetupInfo si) = pure (Right si)
dl' (NewURI uri) = do
base <- liftE $ getBase uri
catchE @JSONError (\(JSONDecodeError _) -> do
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
Right <$> decodeMetadata @Stack.SetupInfo base)
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
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' Nothing)
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
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo" mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo xs@(GHCupInfo{}: _) = mergeGhcupInfo xs@(GHCupInfo{}: _) =
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs) let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs) newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools in pure $ GHCupInfo newToolReqs newDownloads Nothing
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
@@ -152,7 +204,7 @@ etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags") etagsFile = (<.> "etags")
getBase :: ( MonadReader env m getBase :: forall m env . ( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadFail m , MonadFail m
@@ -160,10 +212,9 @@ getBase :: ( MonadReader env m
, MonadCatch m , MonadCatch m
, HasLog env , HasLog env
, MonadMask m , MonadMask m
, FromJSON j
) )
=> URI => URI
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError] m FilePath
getBase uri = do getBase uri = do
Settings { noNetwork, downloader, metaMode } <- lift getSettings Settings { noNetwork, downloader, metaMode } <- lift getSettings
@@ -183,25 +234,8 @@ getBase uri = do
$ uri $ uri
-- if we didn't get a filepath from the download, use the cached yaml -- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml maybe (lift $ yamlFromCache uri) pure mYaml
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
. liftIO
. Y.decodeFileEither
$ actualYaml
where where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m () warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
warnCache s downloader' = do warnCache s downloader' = do
let tryDownloder = case downloader' of let tryDownloder = case downloader' of
@@ -273,6 +307,69 @@ getBase uri = do
pure f pure f
warnOnMetadataUpdate ::
( MonadReader env m
, MonadIO m
, HasLog env
, HasDirs env
)
=> URI
-> GHCupInfo
-> m ()
warnOnMetadataUpdate uri (GHCupInfo { _metadataUpdate = Just newUri })
| scheme' uri == "file"
, urlBase' uri /= urlBase' newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
| scheme' uri /= "file"
, uri /= newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
where
scheme' = view (uriSchemeL' % schemeBSL')
urlBase' = T.unpack . decUTF8Safe . urlBaseName . view pathL'
warnOnMetadataUpdate _ _ = pure ()
decodeMetadata :: forall j m env .
( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, HasLog env
, MonadMask m
, FromJSON j
)
=> FilePath
-> Excepts '[JSONError, FileDoesNotExistError] m j
decodeMetadata actualYaml = do
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
. liftIO
. Y.decodeFileEither
$ actualYaml
where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
getDownloadInfo :: ( MonadReader env m getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
@@ -327,106 +424,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
@@ -858,7 +855,7 @@ getGpgOpts =
-- "baz" -- "baz"
urlBaseName :: ByteString -- ^ the url path (without scheme and host) urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString -> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False urlBaseName = snd . B.breakEnd (== _slash)
-- | Curl saves all intermediate connect headers as well, not just the last one, so we make an effort to take the -- | Curl saves all intermediate connect headers as well, not just the last one, so we make an effort to take the

View File

@@ -209,7 +209,6 @@ instance HFErrorProject NoCompatiblePlatform where
-- | Unable to find a download for the requested version/distro. -- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest) data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest)
| NoDownload' GlobalTool
deriving Show deriving Show
instance Pretty NoDownload where instance Pretty NoDownload where
@@ -227,7 +226,6 @@ instance Pretty NoDownload where
<> T.unpack (prettyVer vv) <> T.unpack (prettyVer vv)
<> "'" <> "'"
| otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver) | otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver)
pPrint (NoDownload' globalTool) = text $ "Unable to find a download for " <> prettyShow globalTool
instance HFErrorProject NoDownload where instance HFErrorProject NoDownload where
eBase _ = 10 eBase _ = 10
@@ -676,18 +674,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
@@ -724,7 +722,7 @@ data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorPr
instance Pretty InstallSetError where instance Pretty InstallSetError where
pPrint (InstallSetError reason1 reason2) = pPrint (InstallSetError reason1 reason2) =
text "Both installation and setting the tool failed. Install error was:" text "Both installation and setting the tool failed.\nInstall error was:"
<+> pPrint reason1 <+> pPrint reason1
<+> text "\nSet error was:" <+> text "\nSet error was:"
<+> pPrint reason2 <+> pPrint reason2
@@ -787,6 +785,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) ]--

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
@@ -771,7 +763,8 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share") when isSetGHC $ do
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")

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
@@ -152,6 +152,9 @@ getLinuxDistro = do
| hasWord name ["exherbo"] -> Exherbo | hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo | hasWord name ["gentoo"] -> Gentoo
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux | hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
| hasWord name ["rocky", "Rocky Linux"] -> Rocky
-- https://github.com/void-linux/void-packages/blob/master/srcpkgs/base-files/files/os-release
| hasWord name ["void", "Void Linux"] -> Void
| otherwise -> UnknownLinux | otherwise -> UnknownLinux
pure (distro, parsedVer) pure (distro, parsedVer)
where where
@@ -348,7 +351,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

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

View File

@@ -387,7 +387,7 @@ rmLink fp
-- --
-- This overwrites previously existing files. -- This overwrites previously existing files.
-- --
-- On windows, this requires that 'ensureGlobalTools' was run beforehand. -- On windows, this requires that 'ensureShimGen' was run beforehand.
createLink :: ( MonadMask m createLink :: ( MonadMask m
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env

View File

@@ -80,7 +80,7 @@ logInternal logLevel msg = do
Info -> style' "[ Info ]" Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]" Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]" Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg let strs = T.split (== '\n') . T.dropWhileEnd (`elem` ("\n\r" :: String)) $ msg
let out = case strs of let out = case strs of
[] -> T.empty [] -> T.empty
(x:xs) -> (x:xs) ->

View File

@@ -234,7 +234,7 @@ setStack ver = do
liftIO (isShadowed stackbin) >>= \case liftIO (isShadowed stackbin) >>= \case
Nothing -> pure () Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver) Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Stack pa stackbin ver)
pure () pure ()

View File

@@ -22,6 +22,7 @@ module GHCup.Types
( module GHCup.Types ( module GHCup.Types
#if defined(BRICK) #if defined(BRICK)
, Key(..) , Key(..)
, Modifier(..)
#endif #endif
) )
where where
@@ -40,7 +41,7 @@ import Optics ( makeLenses )
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString import URI.ByteString
#if defined(BRICK) #if defined(BRICK)
import Graphics.Vty ( Key(..) ) import Graphics.Vty ( Key(..), Modifier(..) )
#endif #endif
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@@ -55,8 +56,14 @@ data Key = KEsc | KChar Char | KBS | KEnter
| KFun Int | KBackTab | KPrtScr | KPause | KIns | KFun Int | KBackTab | KPrtScr | KPause | KIns
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
deriving (Eq,Show,Read,Ord,GHC.Generic) deriving (Eq,Show,Read,Ord,GHC.Generic)
data Modifier = MShift | MCtrl | MMeta | MAlt
deriving (Eq,Show,Read,Ord,GHC.Generic)
#endif #endif
data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
deriving (Eq,Show,Read,Ord,GHC.Generic)
-------------------- --------------------
@@ -67,7 +74,7 @@ data Key = KEsc | KChar Char | KBS | KEnter
data GHCupInfo = GHCupInfo data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements { _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads , _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo , _metadataUpdate :: Maybe URI
} }
deriving (Show, GHC.Generic, Eq) deriving (Show, GHC.Generic, Eq)
@@ -129,14 +136,6 @@ instance Pretty Tool where
instance NFData Tool instance NFData Tool
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance NFData GlobalTool
instance Pretty GlobalTool where
pPrint ShimGen = text "shimgen"
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
-- source download and per-architecture downloads. -- source download and per-architecture downloads.
@@ -194,7 +193,7 @@ instance Pretty Tag where
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp'')) pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t pPrint (UnknownTag t ) = text t
pPrint LatestPrerelease = text "latest-prerelease" pPrint LatestPrerelease = text "latest-prerelease"
pPrint LatestNightly = text "latest-prerelease" pPrint LatestNightly = text "latest-prerelease"
pPrint Old = mempty pPrint Old = mempty
data Architecture = A_64 data Architecture = A_64
@@ -335,18 +334,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
@@ -373,13 +389,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, Eq)
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 =
@@ -397,8 +411,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
@@ -410,7 +422,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, kSet = Just bSet , kSet = Just bSet
, kChangelog = Just bChangelog , kChangelog = Just bChangelog
, kShowAll = Just bShowAllVersions , kShowAll = Just bShowAllVersions
, kShowAllTools = Just bShowAllTools
} }
in UserSettings { in UserSettings {
uCache = Just cache uCache = Just cache
@@ -426,52 +437,51 @@ 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
{ kUp :: Maybe Key { kUp :: Maybe KeyCombination
, kDown :: Maybe Key , kDown :: Maybe KeyCombination
, kQuit :: Maybe Key , kQuit :: Maybe KeyCombination
, kInstall :: Maybe Key , kInstall :: Maybe KeyCombination
, kUninstall :: Maybe Key , kUninstall :: Maybe KeyCombination
, kSet :: Maybe Key , kSet :: Maybe KeyCombination
, kChangelog :: Maybe Key , kChangelog :: Maybe KeyCombination
, kShowAll :: Maybe Key , kShowAll :: Maybe KeyCombination
, kShowAllTools :: Maybe Key
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic, Eq)
data KeyBindings = KeyBindings data KeyBindings = KeyBindings
{ bUp :: Key { bUp :: KeyCombination
, bDown :: Key , bDown :: KeyCombination
, bQuit :: Key , bQuit :: KeyCombination
, bInstall :: Key , bInstall :: KeyCombination
, bUninstall :: Key , bUninstall :: KeyCombination
, bSet :: Key , bSet :: KeyCombination
, bChangelog :: Key , bChangelog :: KeyCombination
, bShowAllVersions :: Key , bShowAllVersions :: KeyCombination
, bShowAllTools :: Key
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
instance NFData KeyBindings instance NFData KeyBindings
#if defined(IS_WINDOWS) || !defined(BRICK) #if !defined(BRICK)
instance NFData Key instance NFData Key
instance NFData Modifier
#endif #endif
instance NFData KeyCombination
defaultKeyBindings :: KeyBindings defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings defaultKeyBindings = KeyBindings
{ bUp = KUp { bUp = KeyCombination { key = KUp , mods = [] }
, bDown = KDown , bDown = KeyCombination { key = KDown , mods = [] }
, bQuit = KChar 'q' , bQuit = KeyCombination { key = KChar 'q', mods = [] }
, bInstall = KChar 'i' , bInstall = KeyCombination { key = KChar 'i', mods = [] }
, bUninstall = KChar 'u' , bUninstall = KeyCombination { key = KChar 'u', mods = [] }
, bSet = KChar 's' , bSet = KeyCombination { key = KChar 's', mods = [] }
, bChangelog = KChar 'c' , bChangelog = KeyCombination { key = KChar 'c', mods = [] }
, bShowAllVersions = KChar 'a' , bShowAllVersions = KeyCombination { key = KChar 'a', mods = [] }
, bShowAllTools = KChar 't'
} }
data AppState = AppState data AppState = AppState
@@ -512,8 +522,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)
@@ -521,7 +529,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

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
@@ -56,7 +59,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Chunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Release deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Release
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
@@ -155,12 +157,6 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey GlobalTool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p toJSON (RealDir p) = toJSON p
toJSON (RegexDir r) = object ["RegexDir" .= r] toJSON (RegexDir r) = object ["RegexDir" .= r]
@@ -278,34 +274,64 @@ 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"
metadataUpdate <- o .:? "metadataUpdate"
ghcupDownloads' <- o .: "ghcupDownloads"
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' metadataUpdate)
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 { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
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])
@@ -314,18 +340,100 @@ 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
parseJSON v = proper v <|> simple v
where
simple = withObject "KeyCombination" $ \o -> do
k <- parseJSON (Object o)
pure (KeyCombination k [])
proper = withObject "KeyCombination" $ \o -> do
k <- o .: "Key"
m <- o .: "Mods"
pure $ KeyCombination k m
instance ToJSON KeyCombination where
toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m]
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings

View File

@@ -50,7 +50,7 @@ instance FromJSON SetupInfo where
siSevenzExe <- o .:? "sevenzexe-info" siSevenzExe <- o .:? "sevenzexe-info"
siSevenzDll <- o .:? "sevenzdll-info" siSevenzDll <- o .:? "sevenzdll-info"
siMsys2 <- o .:? "msys2" .!= mempty siMsys2 <- o .:? "msys2" .!= mempty
siGHCs <- o .:? "ghc" .!= mempty siGHCs <- o .: "ghc"
siStack <- o .:? "stack" .!= mempty siStack <- o .:? "stack" .!= mempty
pure SetupInfo {..} pure SetupInfo {..}

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)
@@ -1199,24 +1199,22 @@ getVersionInfo v' tool =
) )
ensureGlobalTools :: ( MonadMask m ensureShimGen :: ( MonadMask m
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, HasGHCupInfo env , HasGHCupInfo env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m () => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools ensureShimGen
| isWindows = do | isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] let shimDownload = DownloadInfo shimGenURL Nothing shimGenSHA Nothing Nothing
$ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
@@ -1320,29 +1318,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 ]--
----------- -----------

View File

@@ -29,6 +29,7 @@ module GHCup.Utils.Dirs
, relativeSymlink , relativeSymlink
, withGHCupTmpDir , withGHCupTmpDir
, getConfigFilePath , getConfigFilePath
, getConfigFilePath'
, useXDG , useXDG
, cleanupTrash , cleanupTrash
@@ -360,6 +361,12 @@ getConfigFilePath = do
confDir <- liftIO ghcupConfigDir confDir <- liftIO ghcupConfigDir
pure $ fromGHCupPath confDir </> "config.yaml" pure $ fromGHCupPath confDir </> "config.yaml"
getConfigFilePath' :: (MonadReader env m, HasDirs env) => m FilePath
getConfigFilePath' = do
Dirs {..} <- getDirs
pure $ fromGHCupPath confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m) ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings => Excepts '[JSONError] m UserSettings
ghcupConfigFile = do ghcupConfigFile = do

View File

@@ -39,6 +39,12 @@ ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/
stackSetupURL :: URI stackSetupURL :: URI
stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|] stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|]
shimGenURL :: URI
shimGenURL = [uri|https://downloads.haskell.org/~ghcup/shimgen/shim-2.exe|]
shimGenSHA :: T.Text
shimGenSHA = T.pack "7c55e201f71860c5babea886007c8fa44b861abf50d1c07e5677eb0bda387a70"
-- | The current ghcup version. -- | The current ghcup version.
ghcUpVer :: V.PVP ghcUpVer :: V.PVP
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version

View File

@@ -28,14 +28,14 @@
plat="$(uname -s)" plat="$(uname -s)"
arch=$(uname -m) arch=$(uname -m)
ghver="0.1.19.4" ghver="0.1.20.0"
: "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}" : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}"
export GHCUP_SKIP_UPDATE_CHECK=yes export GHCUP_SKIP_UPDATE_CHECK=yes
: "${BOOTSTRAP_HASKELL_DOWNLOADER:=curl}" : "${BOOTSTRAP_HASKELL_DOWNLOADER:=curl}"
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
: "${GHCUP_INSTALL_BASE_PREFIX:=/c}" : "${GHCUP_INSTALL_BASE_PREFIX:=/c}"
GHCUP_DIR=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup") GHCUP_DIR=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup")
GHCUP_BIN=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin") GHCUP_BIN=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin")
@@ -72,7 +72,7 @@ warn() {
printf "%s\\n" "$1" printf "%s\\n" "$1"
else else
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
# shellcheck disable=SC3037 # shellcheck disable=SC3037
echo -e "\\033[0;35m$1\\033[0m" echo -e "\\033[0;35m$1\\033[0m"
;; ;;
@@ -88,7 +88,7 @@ yellow() {
printf "%s\\n" "$1" printf "%s\\n" "$1"
else else
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
# shellcheck disable=SC3037 # shellcheck disable=SC3037
echo -e "\\033[0;33m$1\\033[0m" echo -e "\\033[0;33m$1\\033[0m"
;; ;;
@@ -104,7 +104,7 @@ green() {
printf "%s\\n" "$1" printf "%s\\n" "$1"
else else
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
# shellcheck disable=SC3037 # shellcheck disable=SC3037
echo -e "\\033[0;32m$1\\033[0m" echo -e "\\033[0;32m$1\\033[0m"
;; ;;
@@ -160,7 +160,7 @@ _done() {
echo echo
echo "===============================================================================" echo "==============================================================================="
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
green green
green "All done!" green "All done!"
green green
@@ -172,9 +172,8 @@ _done() {
green "Start a new haskell project in the current directory via:" green "Start a new haskell project in the current directory via:"
green " cabal init --interactive" green " cabal init --interactive"
green green
green "Install other GHC versions and tools via:" green "To install other GHC versions and tools, run:"
green " ghcup list" green " ghcup tui"
green " ghcup install <tool> <version>"
green green
green "To install system libraries and update msys2/mingw64," green "To install system libraries and update msys2/mingw64,"
green "open the \"Mingw haskell shell\"" green "open the \"Mingw haskell shell\""
@@ -314,7 +313,7 @@ download_ghcup() {
;; ;;
esac esac
;; ;;
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
case "${arch}" in case "${arch}" in
x86_64|amd64) x86_64|amd64)
_url=${GHCUP_BASE_URL}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe _url=${GHCUP_BASE_URL}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe
@@ -327,7 +326,7 @@ download_ghcup() {
;; ;;
esac esac
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
"curl") "curl")
# shellcheck disable=SC2086 # shellcheck disable=SC2086
@@ -546,7 +545,7 @@ adjust_bashrc() {
printf "\n%s" "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile" printf "\n%s" "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi fi
;; ;;
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
if [ ! -e "${HOME}/.bash_profile" ] ; then if [ ! -e "${HOME}/.bash_profile" ] ; then
echo '# generated by ghcup' > "${HOME}/.bash_profile" echo '# generated by ghcup' > "${HOME}/.bash_profile"
echo 'test -f ~/.profile && . ~/.profile' >> "${HOME}/.bash_profile" echo 'test -f ~/.profile && . ~/.profile' >> "${HOME}/.bash_profile"
@@ -596,7 +595,7 @@ adjust_cabal_config() {
ask_cabal_config_init() { ask_cabal_config_init() {
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
if [ -n "${BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG}" ] ; then if [ -n "${BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG}" ] ; then
return 1 return 1
fi fi
@@ -637,7 +636,7 @@ ask_cabal_config_init() {
do_cabal_config_init() { do_cabal_config_init() {
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
case $1 in case $1 in
1) 1)
adjust_cabal_config adjust_cabal_config
@@ -757,7 +756,7 @@ if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo "ghcup installs only into the following directory," echo "ghcup installs only into the following directory,"
echo "which can be removed anytime:" echo "which can be removed anytime:"
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
echo " $(cygpath -w "$GHCUP_DIR")" echo " $(cygpath -w "$GHCUP_DIR")"
;; ;;
*) *)
@@ -824,7 +823,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
edo cabal update --ignore-project edo cabal update --ignore-project
else # don't install ghc and cabal else # don't install ghc and cabal
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*|CYGWIN*)
# need to bootstrap cabal to initialize config on windows # need to bootstrap cabal to initialize config on windows
# we'll remove it afterwards # we'll remove it afterwards
tmp_dir="$(mktemp -d)" tmp_dir="$(mktemp -d)"

View File

@@ -42,7 +42,9 @@ param (
# The Msys2 version to download (e.g. 20221216) # The Msys2 version to download (e.g. 20221216)
[string]$Msys2Version, [string]$Msys2Version,
# The Msys2 sha256sum hash # The Msys2 sha256sum hash
[string]$Msys2Hash [string]$Msys2Hash,
# Whether to disable creation of several desktop shortcuts
[switch]$DontWriteDesktopShortcuts
) )
$DefaultMsys2Version = "20221216" $DefaultMsys2Version = "20221216"
@@ -410,6 +412,26 @@ if (!($InstallStack)) {
} }
} }
if ($Interactive) {
$DesktopDecision = $Host.UI.PromptForChoice('Create Desktop shortcuts'
, 'Do you want to create convenience desktop shortcuts (e.g. for uninstallation and msys2 shell)?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'
'&Abort'), 0)
if ($DesktopDecision -eq 0) {
$InstallDesktopShortcuts = $true
} elseif ($DesktopDecision -eq 2) {
Exit 0
}
} else {
if ($Minimal) {
$InstallDesktopShortcuts = $false
} elseif ($DontWriteDesktopShortcuts) {
$InstallDesktopShortcuts = $false
} else {
$InstallDesktopShortcuts = $true
}
}
# mingw foo # mingw foo
Print-Msg -msg 'First checking for Msys2...' Print-Msg -msg 'First checking for Msys2...'
@@ -454,7 +476,9 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -msg 'Extracting Msys2 archive...' Print-Msg -msg 'Extracting Msys2 archive...'
$null = & "$archivePath" '-y' ('-o{0}' -f $GhcupDir) # Extract $null = & "$archivePath" '-y' ('-o{0}' -f $GhcupDir) # Extract
Remove-Item -Path "$archivePath" # We ignore errors because we don't want the installation script to fail just because a temporary file can't be removed.
# Relevant issue: https://github.com/haskell/ghcup-hs/issues/952
Remove-Item -Path "$archivePath" -ErrorAction Continue
Print-Msg -msg 'Processing MSYS2 bash for first time use...' Print-Msg -msg 'Processing MSYS2 bash for first time use...'
Exec "$Bash" '-lc' 'exit' Exec "$Bash" '-lc' 'exit'
@@ -510,8 +534,11 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Start-Sleep -s 5 Start-Sleep -s 5
} }
Print-Msg -msg 'Creating shortcuts...'
$uninstallShortCut = @' if ($InstallDesktopShortcuts) {
Print-Msg -msg 'Creating shortcuts...'
$uninstallShortCut = @'
$decision = $Host.UI.PromptForChoice('Uninstall Haskell' $decision = $Host.UI.PromptForChoice('Uninstall Haskell'
, 'Do you want to uninstall all of the haskell toolchain, including GHC, Cabal, Stack and GHCup itself?' , 'Do you want to uninstall all of the haskell toolchain, including GHC, Cabal, Stack and GHCup itself?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Uninstall' , [System.Management.Automation.Host.ChoiceDescription[]] @('&Uninstall'
@@ -573,12 +600,13 @@ if ($Host.Name -eq "ConsoleHost")
} }
'@ '@
$GhcInstArgs = '-mingw64 -mintty -c "pacman --noconfirm -S --needed base-devel gettext autoconf make libtool automake python p7zip patch unzip"' $GhcInstArgs = '-mingw64 -mintty -c "pacman --noconfirm -S --needed base-devel gettext autoconf make libtool automake python p7zip patch unzip"'
Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe $GhcInstArgs -DestinationPath 'Install GHC dev dependencies.lnk' -TempPath $GhcupDir Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe $GhcInstArgs -DestinationPath 'Install GHC dev dependencies.lnk' -TempPath $GhcupDir
Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath 'Mingw haskell shell.lnk' -TempPath $GhcupDir Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath 'Mingw haskell shell.lnk' -TempPath $GhcupDir
Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath 'Mingw package management docs.url' -TempPath $GhcupDir Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath 'Mingw package management docs.url' -TempPath $GhcupDir
$DesktopDir = [Environment]::GetFolderPath("Desktop") $DesktopDir = [Environment]::GetFolderPath("Desktop")
$null = New-Item -Path $DesktopDir -Name "Uninstall Haskell.ps1" -ItemType "file" -Force -Value $uninstallShortCut $null = New-Item -Path $DesktopDir -Name "Uninstall Haskell.ps1" -ItemType "file" -Force -Value $uninstallShortCut
}
Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir) Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir)
Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User' Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User'

View File

@@ -0,0 +1,8 @@
#!/bin/sh
set -xue
cabal --verbose=0 run ghcup:exe:ghcup -- --bash-completion-script ghcup > scripts/shell-completions/bash
cabal --verbose=0 run ghcup:exe:ghcup -- --zsh-completion-script ghcup > scripts/shell-completions/zsh
cabal --verbose=0 run ghcup:exe:ghcup -- --fish-completion-script ghcup > scripts/shell-completions/fish

View File

@@ -9,8 +9,8 @@ set -eu
case $HOOK_GHC_TYPE in case $HOOK_GHC_TYPE in
bindist) bindist)
ghcdir=$(ghcup whereis --directory ghc "$HOOK_GHC_VERSION" || ghcup run --ghc "$HOOK_GHC_VERSION" --install) || exit 3 ghc_path=$(ghcup whereis ghc "$HOOK_GHC_VERSION" || { ghcup install ghc "$HOOK_GHC_VERSION" >/dev/null && ghcup whereis ghc "$HOOK_GHC_VERSION" ; }) || { >&2 echo "Installing $HOOK_GHC_VERSION via ghcup failed" exit 3 ;}
printf "%s/ghc" "${ghcdir}" printf "%s" "${ghc_path}"
;; ;;
git) git)
# TODO: should be somewhat possible # TODO: should be somewhat possible

View File

@@ -175,10 +175,6 @@ instance Arbitrary Tool where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Arbitrary GlobalTool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink

File diff suppressed because it is too large Load Diff

View File

@@ -4116,17 +4116,7 @@
} }
} }
}, },
"globalTools": { "metadataUpdate": "https:ixnnceymgu",
"ShimGen": {
"dlCSize": -1,
"dlHash": "xrocmtsmjzgmemxrenf",
"dlOutput": null,
"dlSubdir": {
"RegexDir": "\u0013tt\u0013m-"
},
"dlUri": "https:wjmqkzflmlzetqdcxed"
}
},
"toolRequirements": { "toolRequirements": {
"GHCup": { "GHCup": {
"3.8.8": { "3.8.8": {
@@ -9309,17 +9299,7 @@
} }
} }
}, },
"globalTools": { "metadataUpdate": "https:cxnnfovqllcccybmllaikuvluhp",
"ShimGen": {
"dlCSize": -18,
"dlHash": "wbpx",
"dlOutput": null,
"dlSubdir": {
"RegexDir": "[u3"
},
"dlUri": "https:"
}
},
"toolRequirements": { "toolRequirements": {
"HLS": { "HLS": {
"2.6.9": { "2.6.9": {
@@ -11308,15 +11288,7 @@
} }
} }
}, },
"globalTools": { "metadataUpdate": "http:fbptvnonarkxeszcsn",
"ShimGen": {
"dlCSize": null,
"dlHash": "yfwka",
"dlOutput": "c5q",
"dlSubdir": "􊆁M󿅃/|",
"dlUri": "https:yolsdtmmo"
}
},
"toolRequirements": { "toolRequirements": {
"Cabal": { "Cabal": {
"7.7.4": { "7.7.4": {
@@ -13648,15 +13620,7 @@
"GHCup": {}, "GHCup": {},
"Stack": {} "Stack": {}
}, },
"globalTools": { "metadataUpdate": null,
"ShimGen": {
"dlCSize": null,
"dlHash": "hoegok",
"dlOutput": null,
"dlSubdir": "􁃽\u0005]?9\u0001Q:𭲎8ᙣ𑐛'oD\u001a󱧼(𛆎􃥧\u0004\\𢨓[\u001e",
"dlUri": "https:nimu"
}
},
"toolRequirements": { "toolRequirements": {
"Cabal": { "Cabal": {
"3.5.4": { "3.5.4": {
@@ -18153,17 +18117,7 @@
} }
} }
}, },
"globalTools": { "metadataUpdate": "http:ntkddscbgdrjmwymnvpqpmgr",
"ShimGen": {
"dlCSize": null,
"dlHash": "mpljxguikoebuynzv",
"dlOutput": "Q􆹿@i\"%\u0014gb0/PPYE\u001f\u0014KC`-wL",
"dlSubdir": {
"RegexDir": ".`_\u0005󹦸&󲥠\u0014^1Fml\u001e􄋔>o􅟘G"
},
"dlUri": "http:tmcnu"
}
},
"toolRequirements": { "toolRequirements": {
"GHC": { "GHC": {
"6.3.1": { "6.3.1": {

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"))
] ]

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