Compare commits

...

52 Commits

Author SHA1 Message Date
68bbf31a86 Fix download for armv7 container on arm64 host 2021-09-10 14:59:26 +02:00
b58f380e75 Merge branch 'bootstrap' 2021-09-10 13:55:55 +02:00
48c54bf374 Don't unconditionally adjust .bashrc on windows 2021-09-10 13:34:22 +02:00
51da1578f4 Merge remote-tracking branch 'origin/merge-requests/166' 2021-09-08 22:16:02 +02:00
jneira
488f25aed6 Include stack and minor correction 2021-09-08 14:14:05 +02:00
d355c46250 Merge branch 'issue-228' 2021-09-07 00:05:30 +02:00
787c927de6 Improve logging, fixes #228 2021-09-06 23:01:49 +02:00
d15ff7bc67 Improve README 2021-09-05 22:43:44 +02:00
7c5c35f1b0 Fix typo 2021-09-05 22:23:08 +02:00
001b090bc6 Merge branch 'ghc-compile-patch' 2021-09-05 22:21:42 +02:00
db8207f8b9 Fixup 2021-09-04 16:06:33 +02:00
e5918de7af Update README 2021-09-04 15:59:14 +02:00
d2346a543a Fixup 2021-09-04 15:53:29 +02:00
c057b4ae5c Improve documentation about building 2021-09-04 15:14:32 +02:00
b962bf4af9 Add missing qAddDependentFiles 2021-09-04 15:10:07 +02:00
c54dc05d92 Read build.mk from files at build time 2021-09-04 15:09:14 +02:00
8c72bf697e Move files into nicer subdirectories 2021-09-04 15:08:58 +02:00
cc8cf3d12a Improve --patchdir documentation wrt #226 2021-09-04 14:31:05 +02:00
9bdf6bde17 Only consider .diff/.patch for patch files wrt #226 2021-09-04 14:25:24 +02:00
8363495843 Update known users 2021-09-03 23:58:28 +02:00
bc80b1048f Fix debug logs 2021-09-03 21:00:39 +02:00
d61981bc1b Update doc on ghcupURL 2021-09-02 21:27:31 +02:00
4ccdc5dd6c Update RELEASING.md 2021-09-02 21:23:37 +02:00
3240118226 Simplify CI section 2021-09-02 21:11:13 +02:00
254989d63d Merge branch 'issue-221' 2021-09-02 16:22:38 +02:00
283f2a6e46 Add ghcup whereis bindir and friends, fixes #221 2021-09-02 15:37:03 +02:00
94637dfbab Merge branch 'updates' 2021-09-01 01:00:20 +02:00
3e26d7057c Update ghc file 2021-09-01 00:44:52 +02:00
3f710112f3 Rather do it in bootstrap-haskell 2021-08-31 23:23:59 +02:00
34df41b44a Update debian image 2021-08-31 23:04:57 +02:00
3897434ef0 Create .bash_profile on windows if it doesn't exist 2021-08-31 22:59:32 +02:00
375dba9dd1 Improve hlint job 2021-08-31 22:59:32 +02:00
2edd1fb583 Merge branch 'fix-bootstrap-win' 2021-08-31 19:28:21 +02:00
11326060fb Smaller fixes to windows bootstrap 2021-08-31 18:57:38 +02:00
d343c01737 Add CI section 2021-08-31 02:17:38 +02:00
3925f78721 Merge branch 'drop-monad-logger' 2021-08-30 23:55:31 +02:00
d98e54a743 Drop yaml/libyaml 2021-08-30 23:36:11 +02:00
13143b8e4d Drop monad-logger 2021-08-30 23:36:11 +02:00
3a7895e5ea Reorder 2021-08-30 13:59:30 +02:00
2893b2e2d2 Adjust argumentlist 2021-08-30 13:49:48 +02:00
987436fed2 Adjust switch order 2021-08-30 13:47:08 +02:00
96ac66e909 Merge branch 'issue-222' 2021-08-30 11:42:28 +02:00
e5947f3490 Add BOOTSTRAP_HASKELL_MINIMAL wrt #222 2021-08-30 11:19:43 +02:00
b35fe15703 Merge branch 'remove-zipp' 2021-08-29 23:11:03 +02:00
a269b60282 Remove extra 2021-08-29 22:37:16 +02:00
fc6f7ffd73 Update stack.yaml 2021-08-29 21:21:03 +02:00
430dc2d20b Remove zip dependency 2021-08-29 20:56:17 +02:00
77c464870f Refreeze 2021-08-29 17:46:53 +02:00
dda38ec52b Merge remote-tracking branch 'origin/merge-requests/158' 2021-08-29 17:43:01 +02:00
Jan Hrček
f6b6b36eb7 Apply hlint 3.3.2 suggestions 2021-08-29 17:08:06 +02:00
Jan Hrček
3986677b06 Fix typos and simplify code 2021-08-29 14:50:49 +02:00
1fb048777c Merge branch 'cabal-plan' 2021-08-27 15:19:17 +02:00
58 changed files with 9688 additions and 9432 deletions

View File

@@ -14,7 +14,7 @@ variables:
############################################################
.debian:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV"
tags:
- x86_64-linux
variables:
@@ -103,7 +103,7 @@ variables:
artifacts:
expire_in: 2 week
paths:
- golden
- test/golden
- dist-newstyle/cache/
when: on_failure
@@ -240,7 +240,7 @@ test:linux:bootstrap_script:
test:windows:bootstrap_powershell_script:
stage: test
script:
- ./bootstrap-haskell.ps1 -InstallDir $CI_PROJECT_DIR -BootstrapUrl $CI_PROJECT_DIR/bootstrap-haskell -InBash
- ./scripts/bootstrap/bootstrap-haskell.ps1 -InstallDir $CI_PROJECT_DIR -BootstrapUrl $CI_PROJECT_DIR/bootstrap-haskell -InBash
after_script:
- "[Environment]::SetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', $null, [System.EnvironmentVariableTarget]::User)"
- "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)"
@@ -527,15 +527,9 @@ release:windows:
hlint:
stage: hlint
extends:
- .alpine:64bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
- .debian
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.6"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
- curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s -- -r lib/ test/
allow_failure: true
artifacts:
expire_in: 2 week

File diff suppressed because it is too large Load Diff

View File

@@ -24,7 +24,7 @@ export BOOTSTRAP_HASKELL_NONINTERACTIVE=yes
export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION
export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION
./bootstrap-haskell
./scripts/bootstrap/bootstrap-haskell
[ "$(ghc --numeric-version)" = "${GHC_VERSION}" ]

View File

@@ -13,7 +13,7 @@ ecabal() {
}
eghcup() {
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always

View File

@@ -13,7 +13,7 @@ ecabal() {
}
eghcup() {
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always

View File

@@ -18,9 +18,9 @@ raw_eghcup() {
eghcup() {
if [ "${OS}" = "WINDOWS" ] ; then
ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
ghcup -v -c -s file:/$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
else
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
fi
}
@@ -92,7 +92,7 @@ rm -rf "${GHCUP_DIR}"
### manual cli based testing
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
ghcup-gen check -f data/metadata/ghcup-${JSON_VERSION}.yaml
eghcup --numeric-version
@@ -172,10 +172,10 @@ else
fi
# check that lazy loading works for 'whereis'
cp "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
eghcup whereis ghc $(ghc --numeric-version)
mv -f "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
mv -f "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
eghcup rm $(ghc --numeric-version)

107
README.md
View File

@@ -19,11 +19,12 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Configuration](#configuration)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [Compiling GHC from source](#compiling-ghc-from-source)
* [XDG support](#xdg-support)
* [Env variables](#env-variables)
* [Installing custom bindists](#installing-custom-bindists)
* [Isolated Installs](#isolated-installs)
* [CI](#ci)
* [Tips and tricks](#tips-and-tricks)
* [Design goals](#design-goals)
* [How](#how)
@@ -90,7 +91,7 @@ handles your haskell packages and can demand that [a specific version](https://c
### Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml).
explaining all possible configurations can be found in this repo: [config.yaml](./data/config.yaml).
Partial configuration is fine. Command line options always override the config file settings.
@@ -101,14 +102,26 @@ For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man`
### Shell-completion
Shell completions are in `shell-completions`.
Shell completions are in [scripts/shell-completions](./scripts/shell-completions) directory of this repository.
For bash: install `shell-completions/bash`
as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros).
### Cross support
### Compiling GHC from source
Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`
for a list of all available options.
If you need to overwrite the existing `build.mk`, check the default files
in [data/build_mk](./data/build_mk), copy them somewhere, adjust them and
pass `--config path/to/build.mk` to `ghcup compile ghc`.
Common `build.mk` options are explained [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/using#build-configuration).
Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation).
#### Cross support
ghcup can compile and install a cross GHC for any target. However, this
requires that the build host has a complete cross toolchain and various
@@ -190,6 +203,83 @@ Examples:-
5. you can even compile ghc to an isolated location.
- `ghcup compile ghc -j 4 -v 9.0.1 -b 8.10.5 -i /home/username/my/dir/ghc`
---
### CI
On windows, ghcup can be installed automatically on a CI runner like so:
```ps
Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
```
On linux/darwin/freebsd, run the following on your runner:
```sh
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
```
This will just install `ghcup` and on windows additionally `msys2`.
#### Example github workflow
On github workflows you can use https://github.com/haskell/actions/
If you want to install ghcup manually though, here's an example config:
```yml
name: Haskell CI
on:
push:
branches: [ master ]
pull_request:
branches: [ master ]
jobs:
build-cabal:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest, macOS-latest, windows-latest]
ghc: ['8.10.7', '9.0.1']
cabal: ['3.4.0.0']
steps:
- uses: actions/checkout@v2
- if: matrix.os == 'windows-latest'
name: Install ghcup on windows
run: Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
- if: matrix.os == 'windows-latest'
name: Add ghcup to PATH
run: echo "/c/ghcup/bin" >> $GITHUB_PATH
shell: bash
- if: matrix.os != 'windows-latest'
name: Install ghcup on non-windows
run: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
- name: Install ghc/cabal
run: |
ghcup install ghc ${{ matrix.ghc }}
ghcup install cabal ${{ matrix.cabal }}
shell: bash
- name: Update cabal index
run: cabal update
shell: bash
- name: Build
run: cabal build --enable-tests --enable-benchmarks
shell: bash
- name: Run tests
run: cabal test
shell: bash
```
### Tips and tricks
@@ -266,8 +356,13 @@ In addition this script can also install `cabal-install`.
## Known users
* Github action [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
* [vabal](https://github.com/Franciman/vabal)
* Github actions:
- [actions/virtual-environments](https://github.com/actions/virtual-environments)
- [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
* mirrors:
- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
* tools:
- [vabal](https://github.com/Franciman/vabal)
## Known problems

View File

@@ -1,19 +0,0 @@
# RELEASING
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version.
2. Update version in ghcup.cabal
3. Add ChangeLog entry
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
6. Download release artifacts and upload them `downloads.haskell.org/ghcup`
7. Add release artifacts to yaml file (see point 4.)
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`

View File

@@ -11,22 +11,31 @@
module Main where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import System.IO ( stderr )
import Text.Regex.Posix
import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
data Options = Options
@@ -105,10 +114,27 @@ com = subparser
main :: IO ()
main = do
let loggerConfig = LoggerConfig { lcPrintDebug = True
, colorOutter = T.hPutStr stderr
, rawOutter = \_ -> pure ()
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
pure ()
where
@@ -120,8 +146,8 @@ main = do
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
(GHCupInfo _ av gt) <- case Y.decode1Strict contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
Left (_, e) -> die (color Red $ show e)
f av gt
>>= exitWith

View File

@@ -12,11 +12,9 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
@@ -24,7 +22,6 @@ import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
@@ -39,12 +36,10 @@ import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
@@ -62,7 +57,7 @@ addError = do
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
@@ -89,23 +84,23 @@ validate dls _ = do
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
lift $ logInfo "All good"
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError) $
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn) $
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (notElem Windows pspecs && arch == A_64) $ do
lift $ $(logError) $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
@@ -113,12 +108,12 @@ validate dls _ = do
-- (although it could be static)
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ $(logWarn) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
@@ -138,7 +133,7 @@ validate dls _ = do
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
addError
where
isUniqueTag Latest = True
@@ -154,7 +149,7 @@ validate dls _ = do
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid"
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError
-- a tool must have at least one of each mandatory tags
@@ -162,7 +157,7 @@ validate dls _ = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
True -> pure ()
@@ -171,7 +166,7 @@ validate dls _ = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer ver
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError
True -> pure ()
@@ -184,7 +179,10 @@ data TarballFilter = TarballFilter
}
validateTarballs :: ( Monad m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
@@ -199,45 +197,37 @@ validateTarballs :: ( Monad m
validateTarballs (TarballFilter etool versionRegex) dls gt = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ $(logError) "no tarballs selected by filter" *> addError
forM_ allDls downloadAll
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
forM_ allDls (downloadAll ref)
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
pure ExitSuccess
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
logInfo "All good"
pure ExitSuccess
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = \_ -> pure ()
}
downloadAll dli = do
dirs <- liftIO getAllDirs
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <-
runLogger
. flip runReaderT appstate
. runResourceT
downloadAll :: ( MonadUnliftIO m
, MonadIO m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadMask m
, MonadThrow m
)
=> IORef Int
-> DownloadInfo
-> m ()
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
@@ -263,26 +253,26 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
lift $ $(logInfo)
logInfo
$ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Just (RegexDir regexString) -> do
lift $ $(logInfo) $
logInfo $
"verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
lift $ $(logError) $
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
addError
(flip runReaderT ref addError)

View File

@@ -13,11 +13,11 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
@@ -29,7 +29,6 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
)
import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
@@ -417,12 +416,8 @@ install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, Monad
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. runResourceT
runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
@@ -462,7 +457,7 @@ install' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
@@ -473,12 +468,9 @@ install' _ (_, ListResult {..}) = do
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do
@@ -501,9 +493,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
let run = runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
@@ -517,7 +507,7 @@ del' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
@@ -546,6 +536,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
@@ -559,27 +553,14 @@ settings' = unsafePerformIO $ do
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
loggerConfig
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState
-> LoggerConfig
-> IO ()
brickMain s l = do
brickMain s = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
@@ -596,7 +577,7 @@ brickMain s l = do
)
$> ()
Left e -> do
runLogger ($(logError) $ "Error building app state: " <> T.pack (show e))
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
exitWith $ ExitFailure 2
@@ -607,12 +588,9 @@ defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = Fal
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -625,14 +603,11 @@ getGHCupInfo = do
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
runLogger . flip runReaderT settings $ do
flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)

View File

@@ -40,7 +40,6 @@ import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( decodeStrict', Value )
@@ -58,6 +57,7 @@ import Data.Void
import GHC.IO.Encoding
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
@@ -78,8 +78,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.Yaml.Pretty as YP
import qualified Data.YAML.Aeson as Y
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
@@ -207,6 +206,11 @@ data ChangeLogOptions = ChangeLogOptions
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
| WhereisBaseDir
| WhereisBinDir
| WhereisCacheDir
| WhereisLogsDir
| WhereisConfDir
data WhereisOptions = WhereisOptions {
directory :: Bool
@@ -332,7 +336,7 @@ com =
( Install
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal/HLS"
( progDesc "Install or update GHC/cabal/HLS/stack"
<> footerDoc (Just $ text installToolFooter)
)
)
@@ -348,7 +352,7 @@ com =
"rm"
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal/HLS version"
( progDesc "Remove a GHC/cabal/HLS/stack version"
<> footerDoc (Just $ text rmFooter)
)
)
@@ -448,20 +452,20 @@ com =
installToolFooter = [s|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
setFooter :: String
setFooter = [s|Discussion:
Sets the currently active GHC or cabal version. When no command is given,
defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
rmFooter :: String
rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand (ghc/cabal/hls).|]
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
changeLogFooter :: String
changeLogFooter = [s|Discussion:
@@ -542,7 +546,7 @@ installParser =
( InstallHLS
<$> info
(installOpts (Just HLS) <**> helper)
( progDesc "Install haskell-languge-server"
( progDesc "Install haskell-language-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
@@ -835,7 +839,8 @@ configP = subparser
whereisP :: Parser WhereisCommand
whereisP = subparser
( command
(commandGroup "Tools locations:" <>
command
"ghc"
(WhereisTool GHC <$> info
( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
@@ -870,6 +875,37 @@ whereisP = subparser
command
"ghcup"
(WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
) <|> subparser ( commandGroup "Directory locations:"
<>
command
"basedir"
(info (pure WhereisBaseDir <**> helper)
( progDesc "Get ghcup base directory location" )
)
<>
command
"bindir"
(info (pure WhereisBinDir <**> helper)
( progDesc "Get ghcup binary directory location" )
)
<>
command
"cachedir"
(info (pure WhereisCacheDir <**> helper)
( progDesc "Get ghcup cache directory location" )
)
<>
command
"logsdir"
(info (pure WhereisLogsDir <**> helper)
( progDesc "Get ghcup logs directory location" )
)
<>
command
"confdir"
(info (pure WhereisConfDir <**> helper)
( progDesc "Get ghcup config directory location" )
)
)
where
whereisGHCFooter = [s|Discussion:
@@ -1010,7 +1046,7 @@ ghcCompileOpts =
(option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applied in order, uses -p1)"
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
)
<*> optional
@@ -1099,19 +1135,18 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
loggerConfig
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old)
@@ -1131,14 +1166,14 @@ versionCompleter criteria tool = listIOCompleter $ do
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
settings = Settings True False Never Curl False GHCupURL True
let settings = Settings True False Never Curl False GHCupURL True
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
@@ -1147,8 +1182,9 @@ versionCompleter criteria tool = listIOCompleter $ do
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = runLogger . flip runReaderT appState
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions
@@ -1319,7 +1355,7 @@ toSettings options = do
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
updateSettings config settings = do
settings' <- lE' JSONDecodeError . first show . Y.decodeEither' $ config
settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config
pure $ mergeConf settings' settings
where
mergeConf :: UserSettings -> Settings -> Settings
@@ -1367,20 +1403,18 @@ describe_result = $( LitE . StringL <$>
)
plan_json :: String
plan_json = $( LitE . StringL <$>
runIO (handleIO (\_ -> pure "") $ do
plan_json = $( do
(fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do
fp <- findPlanJson (ProjectRelativeToDir ".")
c <- B.readFile fp
(Just res) <- pure $ decodeStrict' @Value c
pure $ T.unpack $ decUTF8Safe' $ encodePretty res
)
)
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
when (not . null $ fp ) $ qAddDependentFile fp
pure . LitE . StringL $ c)
formatConfig :: UserSettings -> String
formatConfig settings
= UTF8.toString . YP.encodePretty yamlConfig $ settings
where
yamlConfig = YP.setConfCompare compare YP.defConfig
= UTF8.toString . Y.encode1Strict $ settings
main :: IO ()
main = do
@@ -1435,18 +1469,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
logfile <- flip runReaderT dirs $ initGHCupFileLogging
logfile <- flip runReaderT dirs initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, colorOutter = T.hPutStr stderr
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> B.appendFile logfile
_ -> T.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
-------------------------
@@ -1454,7 +1490,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-------------------------
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@@ -1462,12 +1497,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
( runLogger
. flip runReaderT leanAppstate
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -1476,12 +1510,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
(threadDelay 5000000 >> runLogger ($(logWarn) $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
race_ (liftIO $ flip runReaderT s' cleanupTrash)
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of
Nuke -> pure ()
@@ -1493,7 +1527,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure ()
#endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure ()
-- TODO: always run for windows
@@ -1501,7 +1535,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
pure s'
@@ -1526,8 +1560,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1555,8 +1588,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetGHC =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1566,8 +1598,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetGHC =
runLogger
. runAppState
runAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1578,8 +1609,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetCabal =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1588,8 +1618,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetCabal =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1599,8 +1628,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runSetHLS =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1609,8 +1637,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runLeanSetHLS =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1618,23 +1645,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runListGHC = runAppState
let runRm =
runLogger . runAppState . runE @'[NotInstalled]
runAppState . runE @'[NotInstalled]
let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled]
flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. runAppState
runAppState
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1654,10 +1679,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanWhereIs =
runLogger
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
. flip runReaderT leanAppstate
flip runReaderT leanAppstate
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1666,8 +1690,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runWhereIs =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1676,8 +1699,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runUpgrade =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ DigestError
@@ -1689,8 +1711,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runPrefetch =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ TagNotFound
@@ -1728,25 +1749,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful"
runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
@@ -1768,18 +1789,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Cabal installation successful"
runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
@@ -1800,12 +1821,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "HLS installation successful"
runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls "
@@ -1814,8 +1835,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installStack InstallOptions{..} =
@@ -1836,18 +1857,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Stack installation successful"
runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
@@ -1861,11 +1882,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5
let setCabal' SetOptions{ sToolVer } =
@@ -1879,11 +1900,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setHLS' SetOptions{ sToolVer } =
@@ -1897,11 +1918,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{ sToolVer } =
@@ -1915,11 +1936,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
@@ -1932,10 +1953,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7
let rmCabal' tv =
@@ -1948,10 +1969,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmHLS' tv =
@@ -1964,10 +1985,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmStack' tv =
@@ -1980,31 +2001,31 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
res <- case optCommand of
#if defined(BRICK)
Interactive -> do
s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
liftIO $ brickMain s' >> pure ExitSuccess
#endif
Install (Right iopts) -> 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.")
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
runLogger (logWarn "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
installCabal iopts
Set (Right sopts) -> do
runLogger ($(logWarn) "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
@@ -2019,7 +2040,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
Rm (Right rmopts) -> do
runLogger ($(logWarn) "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
@@ -2033,11 +2054,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
Compile (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC (do
@@ -2046,8 +2067,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
@@ -2070,32 +2091,32 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight (vi, tv) -> do
runLogger $ $(logInfo)
runLogger $ logInfo
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
putStr (T.unpack $ tVerToText tv)
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
Config InitConfig -> do
path <- getConfigFilePath
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ $(logDebug) $ "config.yaml initialized at " <> T.pack path
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
Config ShowConfig -> do
@@ -2105,20 +2126,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Config (SetConfig k v) -> do
case v of
"" -> do
runLogger $ $(logError) "Empty values are not allowed"
runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55
_ -> do
r <- runE @'[JSONError] $ do
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
runLogger $ $(logDebug) $ T.pack $ show settings'
runLogger $ logDebug $ T.pack $ show settings'
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ $(logError) $ "Error decoding config: " <> T.pack e
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
@@ -2134,7 +2155,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
@@ -2150,9 +2171,29 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis _ WhereisBaseDir -> do
putStr baseDir
pure ExitSuccess
Whereis _ WhereisBinDir -> do
putStr binDir
pure ExitSuccess
Whereis _ WhereisCacheDir -> do
putStr cacheDir
pure ExitSuccess
Whereis _ WhereisLogsDir -> do
putStr logsDir
pure ExitSuccess
Whereis _ WhereisConfDir -> do
putStr confDir
pure ExitSuccess
Upgrade uOpts force' -> do
target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath
@@ -2167,23 +2208,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) $
runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) "No GHCup update available"
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11
ToolRequirements -> do
s' <- appState
flip runReaderT s'
$ runLogger
(runE
$ (runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
@@ -2194,7 +2234,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do
@@ -2211,7 +2251,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case muri of
Nothing -> do
runLogger
($(logWarn) $
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
@@ -2234,7 +2274,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) (T.pack $ prettyShow e))
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
@@ -2242,12 +2282,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1"
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
@@ -2258,15 +2298,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) >>= \case
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!"
runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
| otherwise -> do
runLogger $ $logError "These Files have survived Nuclear Annihilation, you may remove them manually."
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
Prefetch pfCom ->
runPrefetch (do
@@ -2297,7 +2337,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
@@ -2308,7 +2348,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ()
fromVersion :: ( MonadLogger m
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2326,7 +2366,7 @@ fromVersion :: ( MonadLogger m
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( MonadLogger m
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2572,11 +2612,10 @@ checkForUpdates :: ( MonadReader env m
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadFail m
, MonadLogger m
)
=> m ()
checkForUpdates = do
@@ -2587,35 +2626,35 @@ checkForUpdates = do
forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn) $
$ logWarn $
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
$ $(logWarn) $
$ logWarn $
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
$ $(logWarn) $
$ logWarn $
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

View File

@@ -8,26 +8,27 @@ package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/jtdaugherty/brick.git
tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-8.10.5
with-compiler: ghc-8.10.7

View File

@@ -1,15 +1,18 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.2.1.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
any.HsOpenSSL ==0.11.7.1,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.HsYAML ==0.2.1.0,
HsYAML -exe,
any.HsYAML-aeson ==0.2.0.0,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
aeson-pretty +lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
@@ -22,8 +25,7 @@ constraints: any.Cabal ==3.2.1.0,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.14.2.0,
any.base ==4.14.3.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
any.base-orphans ==0.8.4,
@@ -32,41 +34,34 @@ constraints: any.Cabal ==3.2.1.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.63,
any.brick ==0.64,
brick -demos,
any.bytestring ==0.10.12.0,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0,
cabal-plan -_ -exe -license-report,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.4,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
@@ -74,44 +69,32 @@ constraints: any.Cabal ==3.2.1.0,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.data-fix ==0.3.2,
any.deepseq ==1.4.4.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.0,
any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-boot-th ==8.10.5,
any.ghc-boot-th ==8.10.7,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.6.1,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
any.hashable ==1.3.3.0,
hashable +integer-gmp -random-initial-seed,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10 || ==2.8.2,
any.hspec-discover ==2.7.10 || ==2.8.3,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
@@ -128,34 +111,22 @@ constraints: any.Cabal ==3.2.1.0,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
@@ -167,8 +138,8 @@ constraints: any.Cabal ==3.2.1.0,
any.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.process ==1.6.9.0,
any.primitive ==0.7.2.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0,
@@ -178,7 +149,7 @@ constraints: any.Cabal ==3.2.1.0,
any.regex-base ==0.94.0.1,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.resourcet ==1.2.4.3,
any.rts ==1.0.1,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.2,
@@ -187,55 +158,41 @@ constraints: any.Cabal ==3.2.1.0,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.1,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.16.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-conversions ==0.3.1,
any.text-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0,
unordered-containers -debug,
@@ -245,20 +202,12 @@ constraints: any.Cabal ==3.2.1.0,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-27T07:59:57Z
any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2021-08-29T16:24:29Z

View File

@@ -8,26 +8,27 @@ package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/jtdaugherty/brick.git
tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-9.0.1

View File

@@ -1,15 +1,18 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.4.0.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
any.HsOpenSSL ==0.11.7.1,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.HsYAML ==0.2.1.0,
HsYAML -exe,
any.HsYAML-aeson ==0.2.0.0,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
aeson-pretty +lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
@@ -22,7 +25,6 @@ constraints: any.Cabal ==3.4.0.0,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.15.0.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
@@ -32,41 +34,34 @@ constraints: any.Cabal ==3.4.0.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.63,
any.brick ==0.64,
brick -demos,
any.bytestring ==0.10.12.1,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0,
cabal-plan -_ -exe -license-report,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.4,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
@@ -74,45 +69,33 @@ constraints: any.Cabal ==3.4.0.0,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.data-fix ==0.3.2,
any.deepseq ==1.4.5.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.1,
any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-bignum ==1.0,
any.ghc-boot-th ==9.0.1,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.7.0,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
any.hashable ==1.3.3.0,
hashable +integer-gmp -random-initial-seed,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10 || ==2.8.2,
any.hspec-discover ==2.7.10 || ==2.8.3,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
@@ -128,34 +111,22 @@ constraints: any.Cabal ==3.4.0.0,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
@@ -167,7 +138,7 @@ constraints: any.Cabal ==3.4.0.0,
any.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.primitive ==0.7.2.0,
any.process ==1.6.11.0,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
@@ -178,7 +149,7 @@ constraints: any.Cabal ==3.4.0.0,
any.regex-base ==0.94.0.1,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.resourcet ==1.2.4.3,
any.rts ==1.0,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.2,
@@ -187,55 +158,41 @@ constraints: any.Cabal ==3.4.0.0,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.17.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-conversions ==0.3.1,
any.text-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0,
unordered-containers -debug,
@@ -245,20 +202,12 @@ constraints: any.Cabal ==3.4.0.0,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-27T07:59:57Z
any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2021-08-29T16:24:29Z

View File

@@ -16,7 +16,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli

9
data/build_mk/cross Normal file
View File

@@ -0,0 +1,9 @@
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
ifneq "$(BuildFlavour)" ""
include mk/flavours/$(BuildFlavour).mk
endif
Stage1Only = YES

8
data/build_mk/default Normal file
View File

@@ -0,0 +1,8 @@
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES
ifneq "$(BuildFlavour)" ""
include mk/flavours/$(BuildFlavour).mk
endif

21
docs/RELEASING.md Normal file
View File

@@ -0,0 +1,21 @@
# RELEASING
1. Update version in `ghcup.cabal` and `boostrap-haskell` (`ghver` variable at the top of the script)
2. Update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `GHCupInfo` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version, read from `ghcup.cabal`.
3. Add ChangeLog entry
4. Add/fix downloads in `ghcup-<ver>.yaml` (under `data/metadata`), then verify with `ghcup-gen check -f ghcup-<ver>.yaml` and possibly (example only) `ghcup-gen check-tarballs -f ghcup-<ver>.yaml -u 'ghc-8.10.7'`. Generally, new GHC/cabal/stack/hls versions are only added to the latest yaml file. New GHCup versions are added to all (great care must be taken here to not break the parser... e.g. ARM platforms don't parse in all older formats).
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
6. Download release artifacts and upload them `downloads.haskell.org/ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u <your-email> SHA256SUMS`)
7. Add ghcup release artifacts to ALL yaml files (see point 4.)
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
9. Update `bootstrap-haskell` and `bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
10. Update the ghcup symlinks at `downloads.haskell.org/ghcup`

View File

@@ -16,15 +16,19 @@ description:
category: System
build-type: Simple
extra-doc-files:
CHANGELOG.md
config.yaml
ghcup-0.0.4.yaml
ghcup-0.0.5.yaml
ghcup-0.0.6.yaml
ghcup-0.0.7.yaml
HACKING.md
README.md
RELEASING.md
docs/CHANGELOG.md
docs/HACKING.md
docs/RELEASING.md
data/config.yaml
data/metadata/ghcup-0.0.4.yaml
data/metadata/ghcup-0.0.5.yaml
data/metadata/ghcup-0.0.6.yaml
data/metadata/ghcup-0.0.7.yaml
extra-source-files:
data/build_mk/default
data/build_mk/cross
source-repository head
type: git
@@ -104,14 +108,12 @@ library
, deepseq ^>=1.4.4.0
, directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1
, extra ^>=1.7.9
, filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, lzma-static ^>=5.2.5.3
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics ^>=0.4
, os-release ^>=1.0.0
@@ -134,8 +136,7 @@ library
, vector ^>=0.12
, versions >=4.0.1 && <5.1
, word8 ^>=0.1.3
, yaml ^>=0.11.4.0
, zip ^>=1.7.1
, HsYAML-aeson ^>=0.2.0.0
, zlib ^>=0.6.2.2
if (flag(internal-downloader) && !os(windows))
@@ -199,7 +200,6 @@ executable ghcup
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1
@@ -212,7 +212,7 @@ executable ghcup
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
, HsYAML-aeson ^>=0.2.0.0
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
@@ -261,7 +261,6 @@ executable ghcup-gen
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17
@@ -273,7 +272,7 @@ executable ghcup-gen
, text ^>=1.2.4.0
, transformers ^>=0.5
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
, HsYAML-aeson ^>=0.2.0.0
test-suite ghcup-test
type: exitcode-stdio-1.0

View File

@@ -48,7 +48,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -58,7 +57,6 @@ import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.List.Extra
import Data.Maybe
import Data.String ( fromString )
import Data.Text ( Text )
@@ -67,9 +65,10 @@ import Data.Time.Format.ISO8601
import Data.Versions
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe hiding ( at )
@@ -112,7 +111,7 @@ fetchToolBindist :: ( MonadFail m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -140,7 +139,7 @@ fetchGHCSrc :: ( MonadFail m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -177,7 +176,7 @@ installGHCBindist :: ( MonadFail m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -202,7 +201,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver isoFilepath = do
let tver = mkTVer ver
lift $ $(logDebug) $ "Requested to install GHC with " <> prettyVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
@@ -219,7 +218,7 @@ installGHCBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing GHC to " <> T.pack isoDir
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
@@ -233,9 +232,9 @@ installGHCBindist dlinfo ver isoFilepath = do
case catMaybes r of
[] -> pure ()
_ -> do
lift $ $(logWarn) "CC/LD environment variable is set. This will change the compiler/linker"
lift $ $(logWarn) "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall."
lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"
<> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
<> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
@@ -247,7 +246,7 @@ installPackedGHC :: ( MonadMask m
, HasPlatformReq env
, HasSettings env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -305,7 +304,7 @@ installUnpackedGHC :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadMask m
@@ -316,7 +315,7 @@ installUnpackedGHC :: ( MonadReader env m
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do
#if defined(IS_WINDOWS)
lift $ $(logInfo) "Installing GHC (this may take a while)"
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
@@ -333,7 +332,7 @@ installUnpackedGHC path inst ver = do
| otherwise
= []
lift $ $(logInfo) "Installing GHC (this may take a while)"
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
: alpineArgs
@@ -359,7 +358,7 @@ installGHCBin :: ( MonadFail m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -393,7 +392,7 @@ installCabalBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -417,7 +416,7 @@ installCabalBindist :: ( MonadMask m
m
()
installCabalBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install cabal version " <> prettyVer ver
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -448,7 +447,7 @@ installCabalBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Cabal to " <> T.pack isoDir
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing
Nothing -> do -- regular install
@@ -460,13 +459,13 @@ installCabalBindist dlinfo ver isoFilepath = do
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
installCabalUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do
lift $ $(logInfo) "Installing cabal"
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile
@@ -491,7 +490,7 @@ installCabalBin :: ( MonadMask m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -526,7 +525,7 @@ installHLSBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -550,7 +549,7 @@ installHLSBindist :: ( MonadMask m
m
()
installHLSBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install hls version " <> prettyVer ver
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -576,7 +575,7 @@ installHLSBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do
lift $ $(logInfo) $ "isolated installing HLS to " <> T.pack isoDir
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing
Nothing -> do
@@ -589,13 +588,13 @@ installHLSBindist dlinfo ver isoFilepath = do
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do
lift $ $(logInfo) "Installing HLS"
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
@@ -645,7 +644,7 @@ installHLSBin :: ( MonadMask m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -682,7 +681,7 @@ installStackBin :: ( MonadMask m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -717,7 +716,7 @@ installStackBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -741,7 +740,7 @@ installStackBindist :: ( MonadMask m
m
()
installStackBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install stack version " <> prettyVer ver
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -766,7 +765,7 @@ installStackBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Stack to " <> T.pack isoDir
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver)
@@ -778,13 +777,13 @@ installStackBindist dlinfo ver isoFilepath = do
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do
lift $ $(logInfo) "Installing stack"
lift $ logInfo "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile
@@ -817,7 +816,7 @@ installStackUnpacked path inst mver' = do
-- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -851,7 +850,7 @@ setGHC ver sghc = do
SetGHCOnly -> pure $ Just file
SetGHC_XY -> do
handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ do
(mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi
@@ -876,7 +875,7 @@ setGHC ver sghc = do
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadMask m
)
@@ -893,9 +892,9 @@ setGHC ver sghc = do
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) $ "rm -f " <> T.pack fullF
logDebug $ "rm -f " <> T.pack fullF
hideError doesNotExistErrorType $ rmDirectoryLink fullF
$(logDebug) $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
liftIO
#if defined(IS_WINDOWS)
-- On windows we need to be more permissive
@@ -913,7 +912,7 @@ setGHC ver sghc = do
setCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -945,7 +944,7 @@ setCabal ver = do
setHLS :: ( MonadCatch m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -961,7 +960,7 @@ setHLS ver = do
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) $ "rm " <> T.pack (binDir </> f)
lift $ logDebug $ "rm " <> T.pack (binDir </> f)
lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
@@ -986,7 +985,7 @@ setHLS ver = do
setStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -1049,9 +1048,9 @@ availableToolVersions av tool = view
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1107,7 +1106,7 @@ listVersions lt' criteria = do
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1147,7 +1146,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1155,7 +1154,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1182,7 +1181,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1190,7 +1189,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m)
=> Map.Map Version VersionInfo
-> Maybe Version
@@ -1216,7 +1215,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1224,7 +1223,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1251,7 +1250,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1276,7 +1275,7 @@ listVersions lt' criteria = do
}
-- NOTE: this are not cross ones, because no bindists
toListResult :: ( MonadLogger m
toListResult :: ( HasLog env
, MonadReader env m
, HasDirs env
, HasGHCupInfo env
@@ -1378,7 +1377,7 @@ listVersions lt' criteria = do
rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1395,23 +1394,23 @@ rmGHCVer ver = do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) "Removing ghc symlinks"
lift $ logInfo "Removing ghc symlinks"
liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) "Removing ghc-x.y.z symlinks"
lift $ logInfo "Removing ghc-x.y.z symlinks"
liftE $ rmMinorSymlinks ver
lift $ $(logInfo) "Removing/rewiring ghc-x.y symlinks"
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) $ "Removing directory recursively: " <> T.pack dir
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
lift $ recyclePathForcibly dir
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
@@ -1428,7 +1427,7 @@ rmCabalVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1459,7 +1458,7 @@ rmHLSVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1482,7 +1481,7 @@ rmHLSVer ver = do
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
let fullF = binDir </> f
lift $ $(logDebug) $ "rm " <> T.pack fullF
lift $ logDebug $ "rm " <> T.pack fullF
lift $ rmLink fullF
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
@@ -1497,7 +1496,7 @@ rmStackVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1527,7 +1526,7 @@ rmGhcup :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadMask m
, MonadUnliftIO m
)
@@ -1552,7 +1551,7 @@ rmGhcup = do
let areEqualPaths = equalFilePath p1 p2
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exe on windows
@@ -1568,7 +1567,7 @@ rmGhcup = do
where
handlePathNotPresent fp _err = do
$logDebug $ "Error: The path does not exist, " <> T.pack fp
logDebug $ "Error: The path does not exist, " <> T.pack fp
pure fp
nonStandardInstallLocationMsg path = T.pack $
@@ -1578,7 +1577,7 @@ rmGhcup = do
rmTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadFail m
, MonadMask m
, MonadUnliftIO m)
@@ -1598,7 +1597,7 @@ rmTool ListResult {lVer, lTool, lCross} = do
rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadMask m )
=> m [FilePath]
@@ -1625,7 +1624,7 @@ rmGhcupDirs = do
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS)
$logInfo $ "removing " <> T.pack (baseDir </> "msys64")
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif
@@ -1636,27 +1635,27 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
handleRm = handleIO (\e -> $logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
<> "continuing regardless...")
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File"
logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File"
logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do
$logInfo $ "removing " <> T.pack dir
logInfo $ "removing " <> T.pack dir
contents <- liftIO $ getDirectoryContentsRecursive dir
forM_ contents (deleteFile . (dir </>))
@@ -1729,7 +1728,7 @@ getDebugInfo :: ( Alternative m
, MonadFail m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadIO m
)
@@ -1765,7 +1764,7 @@ compileGHC :: ( MonadMask m
, HasSettings env
, MonadThrow m
, MonadResource m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
@@ -1805,7 +1804,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
lift $ $(logDebug) $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball
dlInfo <-
@@ -1830,7 +1829,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ $(logInfo) $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
@@ -1857,7 +1856,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
-- the version that's installed may differ from the
@@ -1869,10 +1868,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
when alreadyInstalled $ do
case isolateDir of
Just isoDir ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
Nothing ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
lift $ $(logWarn)
lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
lift $ logWarn
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -1899,7 +1898,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Nothing ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
lift $ $(logInfo) "Deleting existing installation"
lift $ logInfo "Deleting existing installation"
liftE $ rmGHCVer tver
_ -> pure ()
@@ -1924,26 +1923,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
pure tver
where
defaultConf = case targetGhc of
Left (GHCTargetVersion (Just _) _) -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
ifneq "$(BuildFlavour)" ""
include mk/flavours/$(BuildFlavour).mk
endif
Stage1Only = YES|]
_ -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES
ifneq "$(BuildFlavour)" ""
include mk/flavours/$(BuildFlavour).mk
endif|]
defaultConf =
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of
Left (GHCTargetVersion (Just _) _) -> cross_mk
_ -> default_mk
compileHadrianBindist :: ( MonadReader env m
, HasDirs env
@@ -1951,7 +1936,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -1974,7 +1959,7 @@ endif|]
liftE $ configureBindist bghc tver workdir ghcdir
lift $ $(logInfo) "Building (this may take a while)..."
lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execLogged hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs
@@ -2013,7 +1998,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -2044,15 +2029,15 @@ endif|]
liftE $ checkBuildConfig (build_mk workdir)
lift $ $(logInfo) "Building (this may take a while)..."
lift $ logInfo "Building (this may take a while)..."
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
if | isCross tver -> do
lift $ $(logInfo) "Installing cross toolchain..."
lift $ logInfo "Installing cross toolchain..."
lEM $ make ["install"] (Just workdir)
pure Nothing
| otherwise -> do
lift $ $(logInfo) "Creating bindist..."
lift $ logInfo "Creating bindist..."
lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
workdir
@@ -2071,7 +2056,7 @@ endif|]
, MonadIO m
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
)
=> GHCTargetVersion
-> FilePath -- ^ tar file
@@ -2106,10 +2091,10 @@ endif|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
lift $ $(logInfo) $ "Copied bindist to " <> T.pack tarPath
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath
checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
=> FilePath
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig]
@@ -2132,7 +2117,7 @@ endif|]
forM_ buildFlavour $ \bf ->
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
lift $ $(logWarn) $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
liftIO $ threadDelay 5000000
addBuildFlavourToConf bc = case buildFlavour of
@@ -2149,7 +2134,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -2168,7 +2153,7 @@ endif|]
m
()
configureBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [s|configuring build|]
lift $ logInfo [s|configuring build|]
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
@@ -2232,7 +2217,7 @@ upgradeGHCup :: ( MonadMask m
, HasGHCupInfo env
, HasSettings env
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadResource m
, MonadIO m
@@ -2254,7 +2239,7 @@ upgradeGHCup mtarget force' = do
Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) "Upgrading GHCup..."
lift $ logInfo "Upgrading GHCup..."
let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer
@@ -2263,20 +2248,20 @@ upgradeGHCup mtarget force' = do
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) $ "mkdir -p " <> T.pack destDir
lift $ logDebug $ "mkdir -p " <> T.pack destDir
liftIO $ createDirRecursive' destDir
lift $ $(logDebug) $ "rm -f " <> T.pack destFile
lift $ logDebug $ "rm -f " <> T.pack destFile
lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) $ "cp " <> T.pack p <> " " <> T.pack destFile
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $
lift $ $(logWarn) $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
liftIO (isShadowed destFile) >>= \case
Nothing -> pure ()
Just pa -> lift $ $(logWarn) $ "ghcup is shadowed by "
Just pa -> lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa
<> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa
@@ -2300,7 +2285,7 @@ upgradeGHCup mtarget force' = do
-- both installing from source and bindist.
postGHCInstall :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -2316,7 +2301,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
v' <-
handle (\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
@@ -2332,7 +2317,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m

View File

@@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -34,8 +31,8 @@ import GHCup.Download.Utils
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -47,7 +44,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -57,8 +53,8 @@ import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( mk )
#endif
import Data.List.Extra
import Data.Maybe
import Data.List
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Versions
@@ -72,6 +68,7 @@ import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.Directory
import System.Environment
import System.Exit
@@ -89,7 +86,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
@@ -111,7 +108,7 @@ getDownloadsF :: ( FromJSONKey Tool
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -164,21 +161,21 @@ getBase :: ( MonadReader env m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadMask m
)
=> URI
-> Excepts '[JSONError] m GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do
Settings { noNetwork } <- lift getSettings
Settings { noNetwork, downloader } <- lift getSettings
-- try to download yaml... usually this writes it into cache dir,
-- but in some cases not (e.g. when using file://), so we honour
-- the return filepath, if any
mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
then pure Nothing
else handleIO (\e -> warnCache (displayException e) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e) >> pure Nothing)
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. fmap Just
. smartDl
@@ -186,28 +183,37 @@ getBase uri = do
-- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml
yamlContents <- liftIOException doesNotExistErrorType (FileDoesNotExistError actualYaml) $ liftIO $ L.readFile actualYaml
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] JSONDecodeError
. fmap (first (\e -> unlines [displayException e
,"Consider removing " <> actualYaml <> " manually."]))
. liftIO
. Y.decodeFileEither
$ actualYaml
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first (\(_, e) -> unlines [e, "Consider removing " <> actualYaml <> " manually."])
. Y.decode1
$ yamlContents
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 :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
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))
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 s = do
lift $ $(logWarn) "Could not get download info, trying cached version (this may not be recent!)"
lift $ $(logDebug) $ "Error was: " <> T.pack s
warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
warnCache s downloader' = do
let tryDownloder = case downloader' of
Curl -> "Wget"
Wget -> "Curl"
#if defined(INTERNAL_DOWNLOADER)
Internal -> "Curl"
#endif
logWarn $ "Could not get download info, trying cached version (this may not be recent!)" <> "\n" <>
"If this problem persists, consider switching downloader via: " <> "\n " <>
"ghcup config set downloader " <> tryDownloder
logDebug $ "Error was: " <> T.pack s
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
@@ -221,7 +227,7 @@ getBase uri = do
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, HasLog env1
, MonadMask m1
)
=> URI
@@ -312,7 +318,7 @@ download :: ( MonadReader env m
, HasDirs env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> URI
@@ -326,7 +332,7 @@ download uri eDigest dest mfn etags
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) $ "using local file: " <> T.pack destFile'
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@@ -335,7 +341,7 @@ download uri eDigest dest mfn etags
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
@@ -358,7 +364,7 @@ download uri eDigest dest mfn etags
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
metag <- readETag destFile
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
@@ -370,14 +376,14 @@ download uri eDigest dest mfn etags
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
$logDebug $ "Status code was " <> sc <> ", overwriting"
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
writeEtags destFile (parseEtags headers)
lift $ writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -387,20 +393,20 @@ download uri eDigest dest mfn etags
o' <- liftIO getWgetOpts
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
$logDebug "Not modified, skipping download"
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -411,14 +417,14 @@ download uri eDigest dest mfn etags
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
@@ -444,33 +450,33 @@ download uri eDigest dest mfn etags
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
case T.words <$> mEtag of
(Just []) -> do
$logDebug "Couldn't parse etags, no input: "
logDebug "Couldn't parse etags, no input: "
pure Nothing
(Just [_, etag']) -> do
$logDebug $ "Parsed etag: " <> etag'
logDebug $ "Parsed etag: " <> etag'
pure (Just etag')
(Just xs) -> do
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
pure Nothing
Nothing -> do
$logDebug "No etags header found"
logDebug "No etags header found"
pure Nothing
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
$logDebug "No etags files written"
logDebug "No etags files written"
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag fp = do
e <- liftIO $ doesFileExist fp
if e
@@ -478,13 +484,13 @@ download uri eDigest dest mfn etags
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of
(Right et) -> do
$logDebug $ "Read etag: " <> et
logDebug $ "Read etag: " <> et
pure (Just et)
(Left _) -> do
$logDebug "Etag file doesn't exist (yet)"
logDebug "Etag file doesn't exist (yet)"
pure Nothing
else do
$logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing
@@ -497,7 +503,7 @@ downloadCached :: ( MonadReader env m
, MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -518,7 +524,7 @@ downloadCached' :: ( MonadReader env m
, HasSettings env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -552,7 +558,7 @@ checkDigest :: ( MonadReader env m
, HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
, HasLog env
)
=> T.Text -- ^ the hash
-> FilePath
@@ -562,7 +568,7 @@ checkDigest eDigest file = do
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ $(logInfo) $ "verifying digest of: " <> T.pack p'
lift $ logInfo $ "verifying digest of: " <> T.pack p'
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

View File

@@ -50,7 +50,7 @@ instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
-- | Unable to find a download for the requested versio/distro.
-- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload
deriving Show
@@ -285,31 +285,37 @@ instance Pretty HadrianNotFound where
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall x xs . (Show x, Show (V xs), Pretty x, Pretty (V xs)) => DownloadFailed (V (x ': xs))
data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
text "Download failed:" <+> pPrint reason
case reason of
VMaybe (_ :: DownloadFailed) -> pPrint reason
_ -> text "Download failed:" <+> pPrint reason
deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
case reason of
VMaybe (_ :: BuildFailed) -> pPrint reason
_ -> text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . (Show (V es), Pretty (V es)) => GHCupSetError (V es)
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
text "Setting the current GHC version failed:" <+> pPrint reason
case reason of
VMaybe (_ :: GHCupSetError) -> pPrint reason
_ -> text "Setting the current GHC version failed:" <+> pPrint reason
deriving instance Show GHCupSetError

View File

@@ -20,6 +20,7 @@ module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -28,7 +29,6 @@ import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
@@ -57,7 +57,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -82,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -107,7 +107,7 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr)
lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
pure pfr
where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
@@ -142,9 +142,7 @@ getLinuxDistro = do
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
hasWord t matches = foldr (\x y -> match (regex x) (T.unpack t) || y)
False
matches
hasWord t = any (\x -> match (regex x) (T.unpack t))
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])

View File

@@ -25,21 +25,17 @@ module GHCup.Types
)
where
import Control.Applicative
import Control.DeepSeq ( NFData, rnf )
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -152,7 +148,7 @@ data Tag = Latest
| Recommended
| Prerelease
| Base PVP
| Old -- ^ old version are hidden by default in TUI
| Old -- ^ old versions are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
@@ -241,7 +237,7 @@ instance NFData LinuxDistro
distroToString :: LinuxDistro -> String
distroToString Debian = "debian"
distroToString Ubuntu = "ubuntu"
distroToString Mint= "mint"
distroToString Mint = "mint"
distroToString Fedora = "fedora"
distroToString CentOS = "centos"
distroToString RedHat = "redhat"
@@ -396,6 +392,7 @@ data AppState = AppState
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData AppState
@@ -404,6 +401,7 @@ data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData LeanAppState
@@ -555,14 +553,25 @@ instance Pretty Versioning where
instance Pretty Version where
pPrint = text . T.unpack . prettyVer
instance Show (a -> b) where
show _ = "<function>"
instance (Monad m, Alternative m) => Alternative (LoggingT m) where
empty = Trans.lift empty
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance Show (IO ()) where
show _ = "<io>"
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
data LogLevel = Warn
| Info
| Debug
| Error
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug

View File

@@ -42,7 +42,7 @@ import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit

View File

@@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types.Optics
@@ -21,9 +22,13 @@ module GHCup.Types.Optics where
import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics
import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool
makePrisms ''Architecture
@@ -87,13 +92,15 @@ getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
)
=> m LeanAppState
getLeanAppState = do
s <- gets @"settings"
d <- gets @"dirs"
k <- gets @"keyBindings"
pure (LeanAppState s d k)
l <- gets @"loggerConfig"
pure (LeanAppState s d k l)
getSettings :: ( MonadReader env m
@@ -110,6 +117,87 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)
=> m (IO ())
getLogCleanup = gets @"logCleanup"
getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
@@ -136,6 +224,7 @@ type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)
getCache :: (MonadReader env m, HasSettings env) => m Bool

View File

@@ -40,14 +40,12 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Codec.Archive hiding ( Directory )
import Codec.Archive.Zip
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -59,7 +57,6 @@ import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Extra
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.Maybe
import Data.Text ( Text )
@@ -115,7 +112,7 @@ ghcLinkDestination tool ver = do
rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -129,14 +126,14 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -151,11 +148,11 @@ rmPlain target = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file)
lift $ logDebug ("rm -f " <> T.pack hdc_file)
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
@@ -163,7 +160,7 @@ rmPlain target = do
rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -179,7 +176,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) "rm -f #{fullF}"
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -251,9 +248,9 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadLogger m
, MonadReader env m
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadCatch m
)
@@ -271,14 +268,14 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
@@ -295,7 +292,7 @@ cabalSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse cabal symlink target with: "
logWarn $ "Failed to parse cabal symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack cabalbin
@@ -366,7 +363,7 @@ getInstalledStacks = do
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet = do
Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt
@@ -383,7 +380,7 @@ stackSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse stack symlink target with: "
logWarn $ "Failed to parse stack symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack stackBin
@@ -601,7 +598,7 @@ getLatestGHCFor major' minor' dls =
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
@@ -609,7 +606,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
] m ()
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
@@ -628,12 +625,11 @@ unpackToDir dfp av = do
| ".tar.bz2" `isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av (unpackInto dfp)
| ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av)
| otherwise -> throwE $ UnknownArchive fn
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
, ArchiveResult
@@ -658,14 +654,11 @@ getArchiveFiles av = do
| ".tar.bz2" `isSuffixOf` fn ->
liftE (entries . BZip.decompress =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av $ do
entries' <- getEntries
pure $ fmap unEntrySelector $ Map.keys entries'
| ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av)
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m FilePath
@@ -793,14 +786,19 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
patches <- (fmap . fmap) (pdir </>) $ liftIO $ findFiles
pdir
(makeRegexOpts compExtended
execBlank
([s|.+\.(patch|diff)$|] :: ByteString)
)
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) $ "Applying patch " <> T.pack patch'
lift $ logInfo $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just)
(exec
"patch"
@@ -836,12 +834,14 @@ getChangeLog dls tool (Right tag) =
-- 2. the install destination, depending on whether the build failed
runBuildAction :: ( Pretty (V e)
, Show (V e)
, PopVariant BuildFailed e
, ToVariantMaybe BuildFailed e
, MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, MonadLogger m
, HasLog env
, MonadUnliftIO m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
@@ -869,9 +869,9 @@ runBuildAction bdir instdir action = do
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn) $
liftIO $ handleIO (\e -> run $ logWarn $
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
@@ -984,7 +984,7 @@ rmLink = hideError doesNotExistErrorType . recycleFile
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1006,24 +1006,24 @@ createLink link exe = do
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
rmLink exe
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) $ "ln -s " <> T.pack link <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1041,8 +1041,8 @@ ensureGlobalTools = do
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) "Digest doesn't match, redownloading gs.exe..."
lift $ $(logDebug) "rm -f #{shimDownload}"
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)

View File

@@ -2,9 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Dirs
@@ -45,7 +43,6 @@ import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
@@ -61,7 +58,7 @@ import System.IO.Temp
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -224,7 +221,7 @@ ghcupConfigFile = do
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
case contents of
Nothing -> pure defaultUserSettings
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
Just contents' -> lE' JSONDecodeError . first snd . Y.decode1Strict $ contents'
-------------------------
@@ -261,7 +258,7 @@ parseGHCupGHCDir (T.pack -> fp) =
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadThrow m
, MonadMask m
@@ -273,14 +270,14 @@ mkGhcupTmpDir = do
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) ("Possibly insufficient disk space on "
logWarn ("Possibly insufficient disk space on "
<> T.pack tmpdir
<> ". At least "
<> T.pack (show minSpace)
<> " MB are recommended, but only "
<> toMB (fromJust space)
<> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
$(logWarn)
logWarn
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -295,8 +292,9 @@ mkGhcupTmpDir = do
withGHCupTmpDir :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadLogger m
, MonadCatch m
, MonadResource m
, MonadThrow m
@@ -309,7 +307,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
$ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly
$ fp))
@@ -341,9 +339,10 @@ relativeSymlink p1 p2 =
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
)
=> m ()
cleanupTrash = do
@@ -352,8 +351,8 @@ cleanupTrash = do
if null contents
then pure ()
else do
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir)
logWarn ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp))

View File

@@ -7,7 +7,6 @@ module GHCup.Utils.File.Common where
import GHCup.Utils.Prelude
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
import GHC.IO.Exception
@@ -29,11 +28,11 @@ data ProcessError = NonZeroExit Int FilePath [String]
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " failed with exit code " <+> text (show e) <+> "."
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " terminated."
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " stopped."
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."

View File

@@ -1,8 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
@@ -28,7 +25,6 @@ import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
@@ -131,7 +127,7 @@ execLogged exe args chdir lfile env = do
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
tee fileFd = readTilEOF lineAction
where
lineAction :: ByteString -> IO ()
@@ -350,7 +346,7 @@ toProcessError exe args mps = case mps of
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
@@ -361,7 +357,7 @@ chmod_755 fp = do
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) ("chmod 755 " <> T.pack fp)
logDebug ("chmod 755 " <> T.pack fp)
liftIO $ setFileMode fp exe_mode

View File

@@ -22,11 +22,8 @@ import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Char ( ord )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
@@ -35,53 +32,6 @@ import qualified Data.ByteString as B
import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> toLogStr (style' "[ ... ] ") <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug:"
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: ( MonadReader env m
, HasDirs env

View File

@@ -5,7 +5,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Prelude
@@ -30,10 +29,10 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf )
import Data.Maybe
import Data.Foldable
import Data.String
import Data.Text ( Text )
@@ -75,8 +74,9 @@ import qualified System.Win32.File as Win32
-- >>> import Data.ByteString.Internal (c2w, w2c)
-- >>> import Test.QuickCheck
-- >>> import Data.Word8
-- >>> import Data.Word8
-- >>> import qualified Data.Text as T
-- >>> import qualified Data.Char as C
-- >>> import Data.List
-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
@@ -174,8 +174,12 @@ lEM' :: forall e' e es a m
lEM' f em = lift em >>= lE . first f
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v))
catchWarn :: forall es m env . ( Pretty (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
@@ -520,7 +524,7 @@ forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | Strip @\\r@ and @\\n@ from 'ByteString's
-- | Strip @\\r@ and @\\n@ from 'String's
--
-- >>> stripNewline "foo\n\n\n"
-- "foo"
@@ -532,13 +536,10 @@ forFold = \t -> (`traverseFold` t)
-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
stripNewline :: String -> String
stripNewline s
| null s = []
| head s `elem` "\n\r" = stripNewline (tail s)
| otherwise = head s : stripNewline (tail s)
stripNewline = filter (`notElem` "\n\r")
-- | Strip @\\r@ and @\\n@ from 'ByteString's
-- | Strip @\\r@ and @\\n@ from 'Text's
--
-- >>> stripNewline' "foo\n\n\n"
-- "foo"
@@ -550,10 +551,7 @@ stripNewline s
-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
stripNewline' :: T.Text -> T.Text
stripNewline' s
| T.null s = mempty
| T.head s `elem` "\n\r" = stripNewline' (T.tail s)
| otherwise = T.singleton (T.head s) <> stripNewline' (T.tail s)
stripNewline' = T.filter (`notElem` "\n\r")
-- | Is the word8 a newline?
@@ -587,3 +585,117 @@ splitOnPVP c s = case Split.splitOn c s of
| otherwise -> def
where
def = (s, "")
-- | Like 'find', but where the test can be monadic.
--
-- >>> findM (Just . C.isUpper) "teST"
-- Just (Just 'S')
-- >>> findM (Just . C.isUpper) "test"
-- Just Nothing
-- >>> findM (Just . const True) ["x",undefined]
-- Just (Just "x")
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
-- | Drops the given suffix from a list.
-- It returns the original sequence if the sequence doesn't end with the given suffix.
--
-- >>> dropSuffix "!" "Hello World!"
-- "Hello World"
-- >>> dropSuffix "!" "Hello World!!"
-- "Hello World!"
-- >>> dropSuffix "!" "Hello World."
-- "Hello World."
dropSuffix :: Eq a => [a] -> [a] -> [a]
dropSuffix a b = fromMaybe b $ stripSuffix a b
-- | Return the prefix of the second list if its suffix
-- matches the entire first list.
--
-- >>> stripSuffix "bar" "foobar"
-- Just "foo"
-- >>> stripSuffix "" "baz"
-- Just "baz"
-- >>> stripSuffix "foo" "quux"
-- Nothing
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)
-- | Drops the given prefix from a list.
-- It returns the original sequence if the sequence doesn't start with the given prefix.
--
-- >>> dropPrefix "Mr. " "Mr. Men"
-- "Men"
-- >>> dropPrefix "Mr. " "Dr. Men"
-- "Dr. Men"
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix a b = fromMaybe b $ stripPrefix a b
-- | Break a list into pieces separated by the first
-- list argument, consuming the delimiter. An empty delimiter is
-- invalid, and will cause an error to be raised.
--
-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
-- ["a","b","d","e"]
-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"
-- ["","X","X","X",""]
-- >>> splitOn "x" "x"
-- ["",""]
-- >>> splitOn "x" ""
-- [""]
--
-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
-- prop> \c x -> splitOn [c] x == split (==c) x
splitOn :: Eq a => [a] -> [a] -> [[a]]
splitOn [] _ = error "splitOn, needle may not be empty"
splitOn _ [] = [[]]
splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b
where (a,b) = breakOn needle haystack
-- | Splits a list into components delimited by separators,
-- where the predicate returns True for a separator element. The
-- resulting components do not contain the separators. Two adjacent
-- separators result in an empty component in the output.
--
-- >>> split (== 'a') "aabbaca"
-- ["","","bb","c",""]
-- >>> split (== 'a') ""
-- [""]
-- >>> split (== ':') "::xyz:abc::123::"
-- ["","","xyz","abc","","123","",""]
-- >>> split (== ',') "my,list,here"
-- ["my","list","here"]
split :: (a -> Bool) -> [a] -> [[a]]
split _ [] = [[]]
split f (x:xs)
| f x = [] : split f xs
| y:ys <- split f xs = (x:y) : ys
| otherwise = [[]]
-- | Find the first instance of @needle@ in @haystack@.
-- The first element of the returned tuple
-- is the prefix of @haystack@ before @needle@ is matched. The second
-- is the remainder of @haystack@, starting with the match.
-- If you want the remainder /without/ the match, use 'stripInfix'.
--
-- >>> breakOn "::" "a::b::c"
-- ("a","::b::c")
-- >>> breakOn "/" "foobar"
-- ("foobar","")
--
-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
breakOn :: Eq a => [a] -> [a] -> ([a], [a])
breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
breakOn _ [] = ([], [])
breakOn needle (x:xs) = first (x:) $ breakOn needle xs

View File

@@ -44,15 +44,14 @@ import Language.Haskell.TH.Quote
-- The pattern portion is undefined.
s :: QuasiQuoter
s = QuasiQuoter
(\s' -> case and $ fmap isAscii s' of
(\s' -> case all isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
(error "Cannot use s as a pattern")
(error "Cannot use s as a type")
(error "Cannot use s as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

View File

@@ -24,6 +24,9 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
-- | This reflects the API version of the YAML.
--
-- Note that when updating this, CI requires that the file exsists AND the same file exists at
-- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.7.yaml|]

View File

@@ -3,6 +3,7 @@
# Main settings:
# * BOOTSTRAP_HASKELL_NONINTERACTIVE - any nonzero value for noninteractive installation
# * BOOTSTRAP_HASKELL_NO_UPGRADE - any nonzero value to not trigger the upgrade
# * BOOTSTRAP_HASKELL_MINIMAL - any nonzero value to only install ghcup
# * GHCUP_USE_XDG_DIRS - any nonzero value to respect The XDG Base Directory Specification
# * BOOTSTRAP_HASKELL_VERBOSE - any nonzero value for more verbose installation
# * BOOTSTRAP_HASKELL_GHC_VERSION - the ghc version to install
@@ -175,7 +176,15 @@ download_ghcup() {
_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
;;
aarch64|arm64|armv8l)
_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
# we could be in a 32bit docker container, in which
# case uname doesn't give us what we want
if [ "$(getconf LONG_BIT)" = "32" ] ; then
_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
;;
*) die "Unknown architecture: ${arch}"
;;
@@ -292,16 +301,7 @@ ask_bashrc() {
read -r bashrc_answer </dev/tty
else
# On windows .bashrc isn't an important user config, so we adjust it
# always. On other platforms, let's be a bit more conservative.
case "${plat}" in
MSYS*|MINGW*)
return 1
;;
*)
return 0
;;
esac
return 0
fi
case $bashrc_answer in
[Pp]* | "")
@@ -371,6 +371,13 @@ adjust_bashrc() {
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi
;;
MSYS*|MINGW*)
if [ ! -e "${HOME}/.bash_profile" ] ; then
echo '# generated by ghcup' > "${HOME}/.bash_profile"
echo 'test -f ~/.profile && . ~/.profile' >> "${HOME}/.bash_profile"
echo 'test -f ~/.bashrc && . ~/.bashrc' >> "${HOME}/.bash_profile"
fi
;;
esac
break ;;
@@ -591,10 +598,12 @@ ask_bashrc
ask_bashrc_answer=$?
ask_cabal_config_init
ask_cabal_config_init_answer=$?
ask_hls
ask_hls_answer=$?
ask_stack
ask_stack_answer=$?
if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
ask_hls
ask_hls_answer=$?
ask_stack
ask_stack_answer=$?
fi
edo mkdir -p "${GHCUP_BIN}"
@@ -620,14 +629,30 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
do_cabal_config_init $ask_cabal_config_init_answer
do_cabal_config_init $ask_cabal_config_init_answer
edo cabal new-update
edo cabal new-update
else # don't install ghc and cabal
case "${plat}" in
MSYS*|MINGW*)
# need to bootstrap cabal to initialize config on windows
# we'll remove it afterwards
tmp_dir="$(mktemp -d)"
eghcup --cache install cabal -i "${tmp_dir}" "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
PATH="${tmp_dir}:$PATH" do_cabal_config_init $ask_cabal_config_init_answer
rm "${tmp_dir}/cabal"
unset tmp_dir
;;
*)
;;
esac
fi
case $ask_hls_answer in
1)

View File

@@ -15,24 +15,26 @@
param (
# Run an interactive installation
[switch]$Interactive,
# Specify the install root (default: 'C:\')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir,
# Overwrite (or rather backup) a previous install
[switch]$Overwrite,
# Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
[string]$BootstrapUrl,
# Do minimal installation of ghcup and msys2 only
[switch]$Minimal,
# Run the final bootstrap script via 'bash' instead of a full newly spawned msys2 shell
[switch]$InBash,
# Overwrite (or rather backup) a previous install
[switch]$Overwrite,
# Skip adjusting cabal.config with mingw paths
[switch]$NoAdjustCabalConfig,
# Whether to install stack as well
[switch]$InstallStack,
# Whether to install hls as well
[switch]$InstallHLS,
# Skip adjusting cabal.config with mingw paths
[switch]$NoAdjustCabalConfig
# Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$BootstrapUrl,
# Specify the install root (default: 'C:\')
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir
)
$Silent = !$Interactive
@@ -180,7 +182,7 @@ elevated command prompt:
if ($GhcupBasePrefixEnv) {
$defaultGhcupBasePrefix = $GhcupBasePrefixEnv
} else {
} elseif (!($InstallDir)) {
$partitions = Get-CimInstance win32_logicaldisk
$defaultGhcupBasePrefix = $null
foreach ($p in $partitions){
@@ -209,10 +211,10 @@ if ($Silent -and !($InstallDir)) {
$GhcupBasePrefix = $defaultGhcupBasePrefix
} elseif ($InstallDir) {
if (!(Test-Path -LiteralPath ('{0}' -f $InstallDir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory!"
Print-Msg -color Red -msg "Not a valid directory! (InstallDir)"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$InstallDir")) {
Print-Msg -color Red -msg "Non-absolute Path specified!"
Print-Msg -color Red -msg "Non-absolute Path specified! (InstallDir)"
Exit 1
} else {
$GhcupBasePrefix = $InstallDir
@@ -243,7 +245,20 @@ $null = [Environment]::SetEnvironmentVariable("GHCUP_INSTALL_BASE_PREFIX", $Ghcu
$GhcupDir = ('{0}\ghcup' -f $GhcupBasePrefix)
$MsysDir = ('{0}\msys64' -f $GhcupDir)
if ($ExistingMsys2Dir) {
if (!(Test-Path -LiteralPath ('{0}' -f $ExistingMsys2Dir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory! (ExistingMsys2Dir)"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$ExistingMsys2Dir")) {
Print-Msg -color Red -msg "Non-absolute Path specified! (ExistingMsys2Dir)"
Exit 1
} else {
$MsysDir = $ExistingMsys2Dir
}
} else {
$MsysDir = ('{0}\msys64' -f $GhcupDir)
}
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
if (!($BootstrapUrl)) {
$BootstrapUrl = 'https://www.haskell.org/ghcup/sh/bootstrap-haskell'
@@ -398,6 +413,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -msg 'Setting default home directory...'
Exec "$Bash" '-lc' "sed -i -e 's/db_home:.*$/db_home: windows/' /etc/nsswitch.conf"
} elseif ($msys2Decision -eq 1) {
Print-Msg -color Yellow -msg 'Skipping MSys2 installation.'
while ($true) {
@@ -529,10 +545,14 @@ if (!($NoAdjustCabalConfig)) {
$AdjustCabalConfigExport = 'export BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG=1 ;'
}
if ($Minimal) {
$MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;'
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} {6} {7} {8} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
}

View File

@@ -1,4 +1,4 @@
resolver: lts-18.7
resolver: lts-18.2
packages:
- .
@@ -6,21 +6,22 @@ packages:
extra-deps:
- git: https://github.com/bgamari/terminal-size
commit: 34ea816bd63f75f800eedac12c6908c6f3736036
- git: https://github.com/hasufell/libarchive
commit: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99
- brick-0.64@sha256:f03fa14607c22cf48af99e24c44f79a0fb073f7ec229f15e969fed9ff73c93f6,16530
- git: https://github.com/hasufell/libarchive
commit: 8587aab78dd515928024ecd82c8f215e06db85cd
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
- base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231
- brick-0.64@sha256:f03fa14607c22cf48af99e24c44f79a0fb073f7ec229f15e969fed9ff73c93f6,16530
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
- chs-cabal-0.1.1.0@sha256:20ec6a9fb5ab6991f1a4adf157c537bd5d3b98d08d3c09c387c954c7c50bd011,1153
- chs-deps-0.1.0.0@sha256:0cdada6d2c682c41b20331b8c63c2ecfc7e806928585195fd544c9d41f3074fd,2496
- composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
- haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
- haskus-utils-variant-3.1@sha256:e602dd23e068c98d03c1027af20503addef8df6368577622453f44ccabea2a5b,2159
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
@@ -29,11 +30,11 @@ extra-deps:
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
@@ -41,7 +42,6 @@ extra-deps:
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- zip-1.7.1@sha256:0ce03d0fbffba47c1ab6fbb9166f8ba5373d828d78587df21b7e9d7bb150f929,3918
flags:
http-io-streams:
@@ -63,3 +63,11 @@ ghc-options:
"$locals": -O2
streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
ghcup: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
build:
test: true
test-arguments:
no-run-tests: true
bench: true
benchmark-opts:
no-run-benchmarks: true

View File

@@ -66,7 +66,7 @@ instance Arbitrary ByteString where
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ pure (Scheme "http"), pure (Scheme "https") ]
arbitrary = elements [ Scheme "http", Scheme "https" ]
instance Arbitrary Host where
arbitrary = genericArbitrary

View File

@@ -13,4 +13,5 @@ import Test.Hspec
spec :: Spec
spec = do
roundtripAndGoldenSpecs (Proxy @GHCupInfo)
roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName "test/golden" }) (Proxy @GHCupInfo)