Compare commits
34 Commits
remove-zip
...
ghc-compil
| Author | SHA1 | Date | |
|---|---|---|---|
|
db8207f8b9
|
|||
|
e5918de7af
|
|||
|
d2346a543a
|
|||
|
c057b4ae5c
|
|||
|
b962bf4af9
|
|||
|
c54dc05d92
|
|||
|
8c72bf697e
|
|||
|
cc8cf3d12a
|
|||
|
9bdf6bde17
|
|||
|
8363495843
|
|||
|
bc80b1048f
|
|||
|
d61981bc1b
|
|||
|
4ccdc5dd6c
|
|||
|
3240118226
|
|||
|
254989d63d
|
|||
|
283f2a6e46
|
|||
|
94637dfbab
|
|||
|
3e26d7057c
|
|||
|
3f710112f3
|
|||
|
34df41b44a
|
|||
|
3897434ef0
|
|||
|
375dba9dd1
|
|||
|
2edd1fb583
|
|||
|
11326060fb
|
|||
|
d343c01737
|
|||
|
3925f78721
|
|||
|
d98e54a743
|
|||
|
13143b8e4d
|
|||
|
3a7895e5ea
|
|||
|
2893b2e2d2
|
|||
|
987436fed2
|
|||
|
96ac66e909
|
|||
|
e5947f3490
|
|||
|
b35fe15703
|
@@ -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
@@ -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}" ]
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
107
README.md
@@ -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 from sourc](#compiling-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 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
|
||||
|
||||
|
||||
19
RELEASING.md
19
RELEASING.md
@@ -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`
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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 <> "'"
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -3,6 +3,9 @@ constraints: any.Cabal ==3.2.1.0,
|
||||
any.HUnit ==1.6.2.0,
|
||||
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,
|
||||
@@ -22,7 +25,6 @@ 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.3.0,
|
||||
any.base-compat ==0.11.2,
|
||||
any.base-compat-batteries ==0.11.2,
|
||||
@@ -32,14 +34,12 @@ 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.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,
|
||||
@@ -47,8 +47,6 @@ constraints: any.Cabal ==3.2.1.0,
|
||||
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,
|
||||
@@ -60,9 +58,6 @@ constraints: any.Cabal ==3.2.1.0,
|
||||
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.5.1,
|
||||
@@ -74,21 +69,15 @@ 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.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.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,
|
||||
@@ -122,27 +111,16 @@ 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.1,
|
||||
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,
|
||||
@@ -184,9 +162,6 @@ constraints: any.Cabal ==3.2.1.0,
|
||||
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,
|
||||
@@ -214,12 +189,10 @@ constraints: any.Cabal ==3.2.1.0,
|
||||
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.1,
|
||||
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,
|
||||
@@ -229,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-08-24T16:50:39Z
|
||||
any.zlib-bindings ==0.1.1.5
|
||||
index-state: hackage.haskell.org 2021-08-29T16:24:29Z
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -3,6 +3,9 @@ constraints: any.Cabal ==3.4.0.0,
|
||||
any.HUnit ==1.6.2.0,
|
||||
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,
|
||||
@@ -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,14 +34,12 @@ 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.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,
|
||||
@@ -47,8 +47,6 @@ constraints: any.Cabal ==3.4.0.0,
|
||||
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,
|
||||
@@ -60,9 +58,6 @@ constraints: any.Cabal ==3.4.0.0,
|
||||
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,
|
||||
@@ -74,21 +69,15 @@ 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.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.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,
|
||||
@@ -122,27 +111,16 @@ 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.1,
|
||||
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,
|
||||
@@ -184,9 +162,6 @@ constraints: any.Cabal ==3.4.0.0,
|
||||
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,
|
||||
@@ -214,12 +189,10 @@ constraints: any.Cabal ==3.4.0.0,
|
||||
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.1,
|
||||
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,
|
||||
@@ -229,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-08-24T16:50:39Z
|
||||
any.zlib-bindings ==0.1.1.5
|
||||
index-state: hackage.haskell.org 2021-08-29T16:24:29Z
|
||||
|
||||
9
data/build_mk/cross
Normal file
9
data/build_mk/cross
Normal 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
8
data/build_mk/default
Normal 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
21
docs/RELEASING.md
Normal 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`
|
||||
29
ghcup.cabal
29
ghcup.cabal
@@ -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
|
||||
@@ -110,7 +114,6 @@ library
|
||||
, 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
|
||||
@@ -133,7 +136,7 @@ library
|
||||
, vector ^>=0.12
|
||||
, versions >=4.0.1 && <5.1
|
||||
, word8 ^>=0.1.3
|
||||
, yaml ^>=0.11.4.0
|
||||
, HsYAML-aeson ^>=0.2.0.0
|
||||
, zlib ^>=0.6.2.2
|
||||
|
||||
if (flag(internal-downloader) && !os(windows))
|
||||
@@ -197,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
|
||||
@@ -210,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
|
||||
@@ -259,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
|
||||
@@ -271,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
|
||||
|
||||
242
lib/GHCup.hs
242
lib/GHCup.hs
@@ -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 )
|
||||
@@ -66,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 )
|
||||
@@ -111,7 +111,7 @@ fetchToolBindist :: ( MonadFail m
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -139,7 +139,7 @@ fetchGHCSrc :: ( MonadFail m
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -176,7 +176,7 @@ installGHCBindist :: ( MonadFail m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -201,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
|
||||
@@ -218,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
|
||||
@@ -232,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
|
||||
@@ -246,7 +246,7 @@ installPackedGHC :: ( MonadMask m
|
||||
, HasPlatformReq env
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
@@ -304,7 +304,7 @@ installUnpackedGHC :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
@@ -315,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.
|
||||
@@ -332,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
|
||||
@@ -358,7 +358,7 @@ installGHCBin :: ( MonadFail m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -392,7 +392,7 @@ installCabalBindist :: ( MonadMask m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -416,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
|
||||
@@ -447,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
|
||||
@@ -459,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
|
||||
@@ -490,7 +490,7 @@ installCabalBin :: ( MonadMask m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -525,7 +525,7 @@ installHLSBindist :: ( MonadMask m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -549,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
|
||||
@@ -575,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
|
||||
@@ -588,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>
|
||||
@@ -644,7 +644,7 @@ installHLSBin :: ( MonadMask m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -681,7 +681,7 @@ installStackBin :: ( MonadMask m
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -716,7 +716,7 @@ installStackBindist :: ( MonadMask m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@@ -740,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
|
||||
@@ -765,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)
|
||||
@@ -777,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
|
||||
@@ -816,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
|
||||
@@ -850,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
|
||||
@@ -875,7 +875,7 @@ setGHC ver sghc = do
|
||||
symlinkShareDir :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadCatch m
|
||||
, MonadMask m
|
||||
)
|
||||
@@ -892,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
|
||||
@@ -912,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
|
||||
@@ -944,7 +944,7 @@ setCabal ver = do
|
||||
setHLS :: ( MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
@@ -960,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
|
||||
@@ -985,7 +985,7 @@ setHLS ver = do
|
||||
setStack :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
@@ -1048,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
|
||||
@@ -1106,7 +1106,7 @@ listVersions lt' criteria = do
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
@@ -1146,7 +1146,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
@@ -1154,7 +1154,7 @@ listVersions lt' criteria = do
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
@@ -1181,7 +1181,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
@@ -1189,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
|
||||
@@ -1215,7 +1215,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
@@ -1223,7 +1223,7 @@ listVersions lt' criteria = do
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
@@ -1250,7 +1250,7 @@ listVersions lt' criteria = do
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
@@ -1275,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
|
||||
@@ -1377,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
|
||||
@@ -1394,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))
|
||||
@@ -1427,7 +1427,7 @@ rmCabalVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
@@ -1458,7 +1458,7 @@ rmHLSVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
@@ -1481,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
|
||||
@@ -1496,7 +1496,7 @@ rmStackVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
@@ -1526,7 +1526,7 @@ rmGhcup :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
@@ -1551,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
|
||||
@@ -1567,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 $
|
||||
@@ -1577,7 +1577,7 @@ rmGhcup = do
|
||||
|
||||
rmTool :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m)
|
||||
@@ -1597,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]
|
||||
@@ -1624,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
|
||||
|
||||
@@ -1635,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 </>))
|
||||
|
||||
@@ -1728,7 +1728,7 @@ getDebugInfo :: ( Alternative m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
)
|
||||
@@ -1764,7 +1764,7 @@ compileGHC :: ( MonadMask m
|
||||
, HasSettings env
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
@@ -1804,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 <-
|
||||
@@ -1829,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"
|
||||
@@ -1856,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
|
||||
@@ -1868,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
|
||||
|
||||
@@ -1898,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 ()
|
||||
@@ -1923,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
|
||||
@@ -1950,7 +1936,7 @@ endif|]
|
||||
, HasPlatformReq env
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
@@ -1973,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
|
||||
@@ -2012,7 +1998,7 @@ endif|]
|
||||
, HasPlatformReq env
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
@@ -2043,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
|
||||
@@ -2070,7 +2056,7 @@ endif|]
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> FilePath -- ^ tar file
|
||||
@@ -2105,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]
|
||||
@@ -2131,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
|
||||
@@ -2148,7 +2134,7 @@ endif|]
|
||||
, HasPlatformReq env
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
@@ -2167,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)
|
||||
|
||||
@@ -2231,7 +2217,7 @@ upgradeGHCup :: ( MonadMask m
|
||||
, HasGHCupInfo env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
@@ -2253,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
|
||||
@@ -2262,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
|
||||
@@ -2299,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
|
||||
@@ -2315,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)
|
||||
@@ -2331,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
|
||||
|
||||
@@ -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 )
|
||||
@@ -90,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
|
||||
|
||||
|
||||
|
||||
@@ -112,7 +108,7 @@ getDownloadsF :: ( FromJSONKey Tool
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
@@ -165,7 +161,7 @@ getBase :: ( MonadReader env m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadMask m
|
||||
)
|
||||
=> URI
|
||||
@@ -187,28 +183,27 @@ 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 <- 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
|
||||
lift $ logWarn "Could not get download info, trying cached version (this may not be recent!)"
|
||||
lift $ 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
|
||||
@@ -222,7 +217,7 @@ getBase uri = do
|
||||
, MonadCatch m1
|
||||
, MonadIO m1
|
||||
, MonadFail m1
|
||||
, MonadLogger m1
|
||||
, HasLog env1
|
||||
, MonadMask m1
|
||||
)
|
||||
=> URI
|
||||
@@ -313,7 +308,7 @@ download :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> URI
|
||||
@@ -327,7 +322,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)
|
||||
@@ -336,7 +331,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
|
||||
@@ -359,7 +354,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
|
||||
@@ -371,14 +366,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
|
||||
@@ -388,20 +383,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']
|
||||
@@ -412,14 +407,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 _) ->
|
||||
@@ -445,33 +440,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
|
||||
@@ -479,13 +474,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
|
||||
|
||||
@@ -498,7 +493,7 @@ downloadCached :: ( MonadReader env m
|
||||
, MonadMask m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
@@ -519,7 +514,7 @@ downloadCached' :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
@@ -553,7 +548,7 @@ checkDigest :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
)
|
||||
=> T.Text -- ^ the hash
|
||||
-> FilePath
|
||||
@@ -563,7 +558,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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -46,7 +46,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 )
|
||||
@@ -113,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
|
||||
@@ -127,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
|
||||
@@ -149,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
|
||||
|
||||
|
||||
@@ -161,7 +160,7 @@ rmPlain target = do
|
||||
rmMajorSymlinks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
@@ -177,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
|
||||
|
||||
|
||||
@@ -249,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
|
||||
)
|
||||
@@ -269,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
|
||||
@@ -293,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
|
||||
@@ -364,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
|
||||
@@ -381,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
|
||||
@@ -599,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
|
||||
@@ -607,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
|
||||
@@ -630,7 +629,7 @@ unpackToDir dfp av = do
|
||||
| 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
|
||||
@@ -659,7 +658,7 @@ getArchiveFiles av = do
|
||||
| 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
|
||||
@@ -787,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"
|
||||
@@ -835,7 +839,7 @@ runBuildAction :: ( Pretty (V e)
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
, HasLog env
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||
@@ -863,9 +867,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)
|
||||
@@ -978,7 +982,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
|
||||
@@ -1000,24 +1004,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
|
||||
@@ -1035,8 +1039,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)
|
||||
|
||||
@@ -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))
|
||||
|
||||
|
||||
@@ -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 )
|
||||
@@ -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
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Prelude
|
||||
@@ -30,7 +29,6 @@ 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, stripPrefix, isPrefixOf )
|
||||
@@ -176,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
|
||||
|
||||
@@ -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|]
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -371,6 +372,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 +599,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 +630,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)
|
||||
@@ -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)
|
||||
}
|
||||
|
||||
|
||||
@@ -13,4 +13,5 @@ import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
roundtripAndGoldenSpecs (Proxy @GHCupInfo)
|
||||
roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName "test/golden" }) (Proxy @GHCupInfo)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user