Compare commits
1 Commits
yaml
...
update-tra
| Author | SHA1 | Date | |
|---|---|---|---|
| 939ebdee0e |
10
.gitignore
vendored
10
.gitignore
vendored
@@ -1,14 +1,4 @@
|
|||||||
.ghci
|
|
||||||
.vim
|
|
||||||
codex.tags
|
|
||||||
dist-newstyle/
|
dist-newstyle/
|
||||||
cabal.project.local
|
cabal.project.local
|
||||||
.stack-work/
|
.stack-work/
|
||||||
bin/
|
bin/
|
||||||
/*.prof
|
|
||||||
/*.ps
|
|
||||||
/*.hp
|
|
||||||
tags
|
|
||||||
TAGS
|
|
||||||
/tmp/
|
|
||||||
.entangled
|
|
||||||
|
|||||||
@@ -2,7 +2,7 @@ variables:
|
|||||||
GIT_SSL_NO_VERIFY: "1"
|
GIT_SSL_NO_VERIFY: "1"
|
||||||
|
|
||||||
# Commit of ghc/ci-images repository from which to pull Docker images
|
# Commit of ghc/ci-images repository from which to pull Docker images
|
||||||
DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
|
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
|
||||||
|
|
||||||
############################################################
|
############################################################
|
||||||
# CI Step
|
# CI Step
|
||||||
@@ -97,7 +97,7 @@ variables:
|
|||||||
test:linux:recommended:
|
test:linux:recommended:
|
||||||
extends: .test_ghcup_version:linux
|
extends: .test_ghcup_version:linux
|
||||||
variables:
|
variables:
|
||||||
GHC_VERSION: "8.8.4"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
CABAL_VERSION: "3.2.0.0"
|
||||||
|
|
||||||
test:linux:latest:
|
test:linux:latest:
|
||||||
@@ -113,7 +113,7 @@ test:linux:latest:
|
|||||||
test:mac:recommended:
|
test:mac:recommended:
|
||||||
extends: .test_ghcup_version:darwin
|
extends: .test_ghcup_version:darwin
|
||||||
variables:
|
variables:
|
||||||
GHC_VERSION: "8.8.4"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
CABAL_VERSION: "3.2.0.0"
|
||||||
|
|
||||||
test:mac:latest:
|
test:mac:latest:
|
||||||
@@ -129,7 +129,7 @@ test:mac:latest:
|
|||||||
test:freebsd:recommended:
|
test:freebsd:recommended:
|
||||||
extends: .test_ghcup_version:freebsd
|
extends: .test_ghcup_version:freebsd
|
||||||
variables:
|
variables:
|
||||||
GHC_VERSION: "8.8.4"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
CABAL_VERSION: "3.2.0.0"
|
||||||
|
|
||||||
test:freebsd:latest:
|
test:freebsd:latest:
|
||||||
@@ -150,7 +150,7 @@ release:linux:64bit:
|
|||||||
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
||||||
variables:
|
variables:
|
||||||
ARTIFACT: "x86_64-linux-ghcup"
|
ARTIFACT: "x86_64-linux-ghcup"
|
||||||
GHC_VERSION: "8.8.4"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
CABAL_VERSION: "3.2.0.0"
|
||||||
|
|
||||||
|
|
||||||
@@ -162,7 +162,7 @@ release:linux:32bit:
|
|||||||
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
||||||
variables:
|
variables:
|
||||||
ARTIFACT: "i386-linux-ghcup"
|
ARTIFACT: "i386-linux-ghcup"
|
||||||
GHC_VERSION: "8.8.4"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
CABAL_VERSION: "3.2.0.0"
|
||||||
|
|
||||||
|
|
||||||
@@ -194,5 +194,4 @@ release:freebsd:
|
|||||||
variables:
|
variables:
|
||||||
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
|
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
|
||||||
GHC_VERSION: "8.8.3"
|
GHC_VERSION: "8.8.3"
|
||||||
CABAL_VERSION: "3.2.0.0"
|
|
||||||
|
|
||||||
|
|||||||
@@ -12,7 +12,7 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
|
|||||||
chmod +x ghcup-bin
|
chmod +x ghcup-bin
|
||||||
|
|
||||||
./ghcup-bin install ${GHC_VERSION}
|
./ghcup-bin install ${GHC_VERSION}
|
||||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
|
||||||
./ghcup-bin set ${GHC_VERSION}
|
./ghcup-bin set ${GHC_VERSION}
|
||||||
|
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||||
|
|
||||||
exit 0
|
exit 0
|
||||||
|
|||||||
@@ -18,14 +18,29 @@ apk add --no-cache \
|
|||||||
tar \
|
tar \
|
||||||
perl
|
perl
|
||||||
|
|
||||||
|
ln -s libncurses.so /usr/lib/libtinfo.so
|
||||||
|
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
|
||||||
if [ "${BIT}" = "32" ] ; then
|
if [ "${BIT}" = "32" ] ; then
|
||||||
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
|
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
|
||||||
else
|
else
|
||||||
curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
|
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
|
||||||
fi
|
fi
|
||||||
chmod +x ghcup-bin
|
chmod +x ghcup-bin
|
||||||
|
./ghcup-bin upgrade
|
||||||
./ghcup-bin install ${GHC_VERSION}
|
./ghcup-bin install ${GHC_VERSION}
|
||||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
# ./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||||
|
# install cabal-3.2.0.0
|
||||||
|
if [ "${BIT}" = "32" ] ; then
|
||||||
|
curl -sSfL -o cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz&dl=1'
|
||||||
|
tar xf cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz
|
||||||
|
cp cabal-install-3.2.0.0-i386-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
|
||||||
|
else
|
||||||
|
curl -sSfL -o cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz&dl=1'
|
||||||
|
tar xf cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz
|
||||||
|
cp cabal-install-3.2.0.0-x86_64-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
|
||||||
|
fi
|
||||||
|
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
|
||||||
|
|
||||||
|
|
||||||
# utils
|
# utils
|
||||||
apk add --no-cache \
|
apk add --no-cache \
|
||||||
@@ -42,6 +57,7 @@ apk add --no-cache \
|
|||||||
openssl-dev \
|
openssl-dev \
|
||||||
openssl-libs-static \
|
openssl-libs-static \
|
||||||
xz \
|
xz \
|
||||||
xz-dev \
|
xz-dev
|
||||||
ncurses-static
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -16,24 +16,16 @@ git describe
|
|||||||
ecabal update
|
ecabal update
|
||||||
|
|
||||||
if [ "${OS}" = "LINUX" ] ; then
|
if [ "${OS}" = "LINUX" ] ; then
|
||||||
if [ "${BIT}" = "32" ] ; then
|
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
|
||||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
|
|
||||||
else
|
|
||||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
|
|
||||||
fi
|
|
||||||
elif [ "${OS}" = "FREEBSD" ] ; then
|
elif [ "${OS}" = "FREEBSD" ] ; then
|
||||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui
|
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
|
||||||
else
|
else
|
||||||
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
|
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
|
||||||
fi
|
fi
|
||||||
|
|
||||||
mkdir out
|
mkdir out
|
||||||
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||||
ver=$(./ghcup --numeric-version)
|
ver=$(./ghcup --numeric-version)
|
||||||
if [ "${OS}" = "DARWIN" ] ; then
|
strip -s ./ghcup
|
||||||
strip ./ghcup
|
|
||||||
else
|
|
||||||
strip -s ./ghcup
|
|
||||||
fi
|
|
||||||
cp ghcup out/${ARTIFACT}-${ver}
|
cp ghcup out/${ARTIFACT}-${ver}
|
||||||
|
|
||||||
|
|||||||
@@ -11,7 +11,7 @@ ecabal() {
|
|||||||
}
|
}
|
||||||
|
|
||||||
eghcup() {
|
eghcup() {
|
||||||
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
|
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
|
||||||
}
|
}
|
||||||
|
|
||||||
git describe --always
|
git describe --always
|
||||||
@@ -21,13 +21,11 @@ git describe --always
|
|||||||
ecabal update
|
ecabal update
|
||||||
|
|
||||||
if [ "${OS}" = "DARWIN" ] ; then
|
if [ "${OS}" = "DARWIN" ] ; then
|
||||||
ecabal build -w ghc-${GHC_VERSION} -ftui
|
ecabal build -w ghc-${GHC_VERSION}
|
||||||
else
|
else
|
||||||
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
|
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
|
||||||
fi
|
fi
|
||||||
|
|
||||||
ecabal haddock
|
|
||||||
|
|
||||||
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||||
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
|
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
|
||||||
|
|
||||||
@@ -42,10 +40,16 @@ rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
|
|||||||
### manual cli based testing
|
### manual cli based testing
|
||||||
|
|
||||||
|
|
||||||
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
|
ghcup-gen check -f ghcup-${JSON_VERSION}.json
|
||||||
|
|
||||||
eghcup --numeric-version
|
eghcup --numeric-version
|
||||||
|
|
||||||
|
# TODO: rm once we have tarballs
|
||||||
|
if [ "${OS}" = "FREEBSD" ] ; then
|
||||||
|
GHC_VERSION=8.6.3
|
||||||
|
CABAL_VERSION=2.4.1.0
|
||||||
|
fi
|
||||||
|
|
||||||
eghcup install ${GHC_VERSION}
|
eghcup install ${GHC_VERSION}
|
||||||
eghcup set ${GHC_VERSION}
|
eghcup set ${GHC_VERSION}
|
||||||
eghcup install-cabal ${CABAL_VERSION}
|
eghcup install-cabal ${CABAL_VERSION}
|
||||||
|
|||||||
12
.travis.yml
12
.travis.yml
@@ -1,10 +1,5 @@
|
|||||||
jobs:
|
jobs:
|
||||||
include:
|
include:
|
||||||
- os: osx
|
|
||||||
osx_image: xcode8
|
|
||||||
language: generic
|
|
||||||
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
|
|
||||||
|
|
||||||
- os: osx
|
- os: osx
|
||||||
osx_image: xcode10.1
|
osx_image: xcode10.1
|
||||||
language: generic
|
language: generic
|
||||||
@@ -15,13 +10,6 @@ jobs:
|
|||||||
language: generic
|
language: generic
|
||||||
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
|
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
|
||||||
|
|
||||||
allow_failures:
|
|
||||||
- os: osx
|
|
||||||
osx_image: xcode8
|
|
||||||
language: generic
|
|
||||||
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
|
|
||||||
|
|
||||||
|
|
||||||
script: ".travis/build.sh"
|
script: ".travis/build.sh"
|
||||||
|
|
||||||
deploy:
|
deploy:
|
||||||
|
|||||||
@@ -18,7 +18,7 @@ ghcup set 8.8.3
|
|||||||
## install ghcup
|
## install ghcup
|
||||||
|
|
||||||
cabal update
|
cabal update
|
||||||
cabal build --constraint="zlib static" --constraint="lzma static" -ftui
|
cabal build --constraint="zlib static" --constraint="lzma static"
|
||||||
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||||
strip ./ghcup
|
strip -s ghcup
|
||||||
cp ghcup "./${ARTIFACT}"
|
cp ghcup "./${ARTIFACT}"
|
||||||
|
|||||||
2
3rdparty/lzma/lzma.cabal
vendored
2
3rdparty/lzma/lzma.cabal
vendored
@@ -86,7 +86,7 @@ test-suite lzma-tests
|
|||||||
-- additional dependencies that require version bounds
|
-- additional dependencies that require version bounds
|
||||||
build-depends: HUnit >= 1.2 && <1.7
|
build-depends: HUnit >= 1.2 && <1.7
|
||||||
, QuickCheck >= 2.8 && <2.14
|
, QuickCheck >= 2.8 && <2.14
|
||||||
, tasty >= 0.10 && <1.4
|
, tasty >= 0.10 && <1.3
|
||||||
, tasty-hunit >= 0.9 && <0.11
|
, tasty-hunit >= 0.9 && <0.11
|
||||||
, tasty-quickcheck >= 0.8.3.2 && <0.11
|
, tasty-quickcheck >= 0.8.3.2 && <0.11
|
||||||
|
|
||||||
|
|||||||
2
3rdparty/zlib/zlib.cabal
vendored
2
3rdparty/zlib/zlib.cabal
vendored
@@ -110,7 +110,7 @@ test-suite tests
|
|||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
build-depends: base, bytestring, zlib,
|
build-depends: base, bytestring, zlib,
|
||||||
QuickCheck == 2.*,
|
QuickCheck == 2.*,
|
||||||
tasty >= 0.8 && < 1.4,
|
tasty >= 0.8 && < 1.3,
|
||||||
tasty-quickcheck >= 0.8 && < 0.11,
|
tasty-quickcheck >= 0.8 && < 0.11,
|
||||||
tasty-hunit >= 0.8 && < 0.11
|
tasty-hunit >= 0.8 && < 0.11
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|||||||
26
CHANGELOG.md
26
CHANGELOG.md
@@ -1,31 +1,5 @@
|
|||||||
# Revision history for ghcup
|
# Revision history for ghcup
|
||||||
|
|
||||||
## 0.1.8 -- 2020-07-21
|
|
||||||
|
|
||||||
* Fix bug in logging thread dying on newlines
|
|
||||||
* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
|
|
||||||
|
|
||||||
## 0.1.7 -- 2020-07-20
|
|
||||||
|
|
||||||
* Fix a bug in libarchive not unpacking some uncleanly packed bindists
|
|
||||||
* Improved fish support in bootstrap-haskell
|
|
||||||
* Only check for upgrades when not upgrading
|
|
||||||
* Fix platform detection for i386 docker images
|
|
||||||
* Improve alpine support
|
|
||||||
- more/proper bindists
|
|
||||||
- don't fall back to glibc based bindists
|
|
||||||
- install bindists with `--disable-ld-override` to avoid ld.gold bugs
|
|
||||||
|
|
||||||
## 0.1.6 -- 2020-07-13
|
|
||||||
|
|
||||||
* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
|
|
||||||
* Support multiple installed versions of cabal #23
|
|
||||||
* Improvements to `ghcup list` (show unavailable bindists for platform)
|
|
||||||
* Fix redhat downloads #29
|
|
||||||
* Support for hadrian bindists (fixes alpine-8.10.1) #31
|
|
||||||
* Add FreeBSD bindists 8.6.5 and 8.8.3
|
|
||||||
* Fix memory leak during unpack
|
|
||||||
|
|
||||||
## 0.1.5 -- 2020-04-30
|
## 0.1.5 -- 2020-04-30
|
||||||
|
|
||||||
* Fix errors when PATH variable contains path components that are actually files
|
* Fix errors when PATH variable contains path components that are actually files
|
||||||
|
|||||||
@@ -40,13 +40,7 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
|
|||||||
|
|
||||||
See `ghcup --help`.
|
See `ghcup --help`.
|
||||||
|
|
||||||
For the simple interactive TUI, run:
|
Common use cases are:
|
||||||
|
|
||||||
```sh
|
|
||||||
ghcup tui
|
|
||||||
```
|
|
||||||
|
|
||||||
For the full functionality via cli:
|
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
# list available ghc/cabal versions
|
# list available ghc/cabal versions
|
||||||
|
|||||||
@@ -1,19 +1,19 @@
|
|||||||
# RELEASING
|
# 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.
|
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the JSON representation of it. The version of the json represents the change increments. `ghcUpVer` is the current application version.
|
||||||
|
|
||||||
2. Update version in ghcup.cabal
|
2. Update version in ghcup.cabal
|
||||||
|
|
||||||
3. Add ChangeLog entry
|
3. Add ChangeLog entry
|
||||||
|
|
||||||
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
|
4. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
|
||||||
|
|
||||||
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
|
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`
|
6. Download release artifacts and upload them `downloads.haskell.org/ghcup`
|
||||||
|
|
||||||
7. Add release artifacts to yaml file (see point 4.)
|
7. Add release artifacts to GHCupDownloads (see point 4.)
|
||||||
|
|
||||||
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
|
8. Upload the final `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
|
||||||
|
|
||||||
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`
|
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`
|
||||||
|
|||||||
@@ -10,10 +10,13 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import GHCup.Data.GHCupInfo
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Types.JSON ( )
|
import GHCup.Types.JSON ( )
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
|
|
||||||
|
import Data.Aeson ( eitherDecode, encode )
|
||||||
|
import Data.Aeson.Encode.Pretty
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
import Data.Semigroup ( (<>) )
|
import Data.Semigroup ( (<>) )
|
||||||
#endif
|
#endif
|
||||||
@@ -24,15 +27,48 @@ import System.IO ( stdout )
|
|||||||
import Validate
|
import Validate
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.Yaml as Y
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
|
||||||
|
|
||||||
data Options = Options
|
data Options = Options
|
||||||
{ optCommand :: Command
|
{ optCommand :: Command
|
||||||
}
|
}
|
||||||
|
|
||||||
data Command = ValidateYAML ValidateYAMLOpts
|
data Command = GenJSON GenJSONOpts
|
||||||
| ValidateTarballs ValidateYAMLOpts
|
| ValidateJSON ValidateJSONOpts
|
||||||
|
| ValidateTarballs ValidateJSONOpts
|
||||||
|
|
||||||
|
data Output
|
||||||
|
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
||||||
|
| StdOutput
|
||||||
|
|
||||||
|
fileOutput :: Parser Output
|
||||||
|
fileOutput =
|
||||||
|
FileOutput
|
||||||
|
<$> (strOption
|
||||||
|
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||||
|
"Output to a file"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
stdOutput :: Parser Output
|
||||||
|
stdOutput = flag'
|
||||||
|
StdOutput
|
||||||
|
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
|
||||||
|
|
||||||
|
outputP :: Parser Output
|
||||||
|
outputP = fileOutput <|> stdOutput
|
||||||
|
|
||||||
|
|
||||||
|
data GenJSONOpts = GenJSONOpts
|
||||||
|
{ output :: Maybe Output
|
||||||
|
, pretty :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
genJSONOpts :: Parser GenJSONOpts
|
||||||
|
genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
|
||||||
|
(short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
data Input
|
data Input
|
||||||
@@ -56,12 +92,12 @@ stdInput = flag'
|
|||||||
inputP :: Parser Input
|
inputP :: Parser Input
|
||||||
inputP = fileInput <|> stdInput
|
inputP = fileInput <|> stdInput
|
||||||
|
|
||||||
data ValidateYAMLOpts = ValidateYAMLOpts
|
data ValidateJSONOpts = ValidateJSONOpts
|
||||||
{ vInput :: Maybe Input
|
{ input :: Maybe Input
|
||||||
}
|
}
|
||||||
|
|
||||||
validateYAMLOpts :: Parser ValidateYAMLOpts
|
validateJSONOpts :: Parser ValidateJSONOpts
|
||||||
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
|
validateJSONOpts = ValidateJSONOpts <$> optional inputP
|
||||||
|
|
||||||
opts :: Parser Options
|
opts :: Parser Options
|
||||||
opts = Options <$> com
|
opts = Options <$> com
|
||||||
@@ -69,10 +105,18 @@ opts = Options <$> com
|
|||||||
com :: Parser Command
|
com :: Parser Command
|
||||||
com = subparser
|
com = subparser
|
||||||
( (command
|
( (command
|
||||||
|
"gen"
|
||||||
|
( GenJSON
|
||||||
|
<$> (info (genJSONOpts <**> helper)
|
||||||
|
(progDesc "Generate the json downloads file")
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
<> (command
|
||||||
"check"
|
"check"
|
||||||
( ValidateYAML
|
( ValidateJSON
|
||||||
<$> (info (validateYAMLOpts <**> helper)
|
<$> (info (validateJSONOpts <**> helper)
|
||||||
(progDesc "Validate the YAML")
|
(progDesc "Validate the JSON")
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@@ -80,7 +124,7 @@ com = subparser
|
|||||||
"check-tarballs"
|
"check-tarballs"
|
||||||
( ValidateTarballs
|
( ValidateTarballs
|
||||||
<$> (info
|
<$> (info
|
||||||
(validateYAMLOpts <**> helper)
|
(validateJSONOpts <**> helper)
|
||||||
(progDesc "Validate all tarballs (download and checksum)")
|
(progDesc "Validate all tarballs (download and checksum)")
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@@ -91,27 +135,38 @@ com = subparser
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||||
>>= \Options {..} -> case optCommand of
|
>>= \Options {..} -> case optCommand of
|
||||||
ValidateYAML vopts -> case vopts of
|
GenJSON gopts -> do
|
||||||
ValidateYAMLOpts { vInput = Nothing } ->
|
let bs True =
|
||||||
B.getContents >>= valAndExit validate
|
encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
|
||||||
ValidateYAMLOpts { vInput = Just StdInput } ->
|
bs False = encode ghcupInfo
|
||||||
B.getContents >>= valAndExit validate
|
case gopts of
|
||||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
GenJSONOpts { output = Nothing, pretty } ->
|
||||||
B.readFile file >>= valAndExit validate
|
L.hPutStr stdout (bs pretty)
|
||||||
|
GenJSONOpts { output = Just StdOutput, pretty } ->
|
||||||
|
L.hPutStr stdout (bs pretty)
|
||||||
|
GenJSONOpts { output = Just (FileOutput file), pretty } ->
|
||||||
|
L.writeFile file (bs pretty)
|
||||||
|
ValidateJSON vopts -> case vopts of
|
||||||
|
ValidateJSONOpts { input = Nothing } ->
|
||||||
|
L.getContents >>= valAndExit validate
|
||||||
|
ValidateJSONOpts { input = Just StdInput } ->
|
||||||
|
L.getContents >>= valAndExit validate
|
||||||
|
ValidateJSONOpts { input = Just (FileInput file) } ->
|
||||||
|
L.readFile file >>= valAndExit validate
|
||||||
ValidateTarballs vopts -> case vopts of
|
ValidateTarballs vopts -> case vopts of
|
||||||
ValidateYAMLOpts { vInput = Nothing } ->
|
ValidateJSONOpts { input = Nothing } ->
|
||||||
B.getContents >>= valAndExit validateTarballs
|
L.getContents >>= valAndExit validateTarballs
|
||||||
ValidateYAMLOpts { vInput = Just StdInput } ->
|
ValidateJSONOpts { input = Just StdInput } ->
|
||||||
B.getContents >>= valAndExit validateTarballs
|
L.getContents >>= valAndExit validateTarballs
|
||||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
ValidateJSONOpts { input = Just (FileInput file) } ->
|
||||||
B.readFile file >>= valAndExit validateTarballs
|
L.readFile file >>= valAndExit validateTarballs
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
where
|
where
|
||||||
valAndExit f contents = do
|
valAndExit f contents = do
|
||||||
(GHCupInfo _ av) <- case Y.decodeEither' contents of
|
(GHCupInfo _ av) <- case eitherDecode contents of
|
||||||
Right r -> pure r
|
Right r -> pure r
|
||||||
Left e -> die (color Red $ show e)
|
Left e -> die (color Red $ show e)
|
||||||
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
|
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
|
||||||
|
|||||||
@@ -179,7 +179,7 @@ validateTarballs dls = do
|
|||||||
|
|
||||||
where
|
where
|
||||||
downloadAll dli = do
|
downloadAll dli = do
|
||||||
let settings = Settings True False Never Curl False
|
let settings = Settings True False Never Curl
|
||||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||||
, colorOutter = B.hPut stderr
|
, colorOutter = B.hPut stderr
|
||||||
, rawOutter = (\_ -> pure ())
|
, rawOutter = (\_ -> pure ())
|
||||||
|
|||||||
@@ -1,362 +0,0 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module BrickMain where
|
|
||||||
|
|
||||||
import GHCup
|
|
||||||
import GHCup.Download
|
|
||||||
import GHCup.Errors
|
|
||||||
import GHCup.Types
|
|
||||||
import GHCup.Utils
|
|
||||||
import GHCup.Utils.File
|
|
||||||
import GHCup.Utils.Logger
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import Brick.Widgets.Border
|
|
||||||
import Brick.Widgets.Border.Style
|
|
||||||
import Brick.Widgets.Center
|
|
||||||
import Brick.Widgets.List
|
|
||||||
#if !defined(TAR)
|
|
||||||
import Codec.Archive
|
|
||||||
#endif
|
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad.Logger
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Control.Monad.Trans.Resource
|
|
||||||
import Data.Bool
|
|
||||||
import Data.Functor
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Char
|
|
||||||
import Data.IORef
|
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Vector ( Vector )
|
|
||||||
import Data.Versions hiding ( str )
|
|
||||||
import Haskus.Utils.Variant.Excepts
|
|
||||||
import Prelude hiding ( appendFile )
|
|
||||||
import System.Exit
|
|
||||||
import System.IO.Unsafe
|
|
||||||
import URI.ByteString
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
|
|
||||||
|
|
||||||
data AppState = AppState {
|
|
||||||
lr :: LR
|
|
||||||
, dls :: GHCupDownloads
|
|
||||||
, pfreq :: PlatformRequest
|
|
||||||
}
|
|
||||||
|
|
||||||
type LR = GenericList String Vector ListResult
|
|
||||||
|
|
||||||
|
|
||||||
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
|
|
||||||
keyHandlers =
|
|
||||||
[ ('q', "Quit" , halt)
|
|
||||||
, ('i', "Install" , withIOAction install')
|
|
||||||
, ('u', "Uninstall", withIOAction del')
|
|
||||||
, ('s', "Set" , withIOAction set')
|
|
||||||
, ('c', "ChangeLog", withIOAction changelog')
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
ui :: AppState -> Widget String
|
|
||||||
ui AppState {..} =
|
|
||||||
( padBottom Max
|
|
||||||
$ ( withBorderStyle unicode
|
|
||||||
$ borderWithLabel (str "GHCup")
|
|
||||||
$ (center $ renderList renderItem True lr)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<=> ( withAttr "help"
|
|
||||||
. txtWrap
|
|
||||||
. T.pack
|
|
||||||
. foldr1 (\x y -> x <> " " <> y)
|
|
||||||
. (++ ["↑↓:Navigation"])
|
|
||||||
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
|
|
||||||
)
|
|
||||||
|
|
||||||
where
|
|
||||||
renderItem b ListResult {..} =
|
|
||||||
let marks = if
|
|
||||||
| lSet -> (withAttr "set" $ str "✔✔")
|
|
||||||
| lInstalled -> (withAttr "installed" $ str "✓ ")
|
|
||||||
| otherwise -> (withAttr "not-installed" $ str "✗ ")
|
|
||||||
ver = case lCross of
|
|
||||||
Nothing -> T.unpack . prettyVer $ lVer
|
|
||||||
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
|
|
||||||
dim = if lNoBindist
|
|
||||||
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
|
|
||||||
else id
|
|
||||||
in dim
|
|
||||||
( marks
|
|
||||||
<+> ( padLeft (Pad 2)
|
|
||||||
$ minHSize 20
|
|
||||||
$ ((if b then withAttr "active" else id)
|
|
||||||
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<+> (padLeft (Pad 1) $ if null lTag
|
|
||||||
then emptyWidget
|
|
||||||
else
|
|
||||||
foldr1 (\x y -> x <+> str "," <+> y)
|
|
||||||
$ (fmap printTag $ sort lTag)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
||||||
printTag Recommended = withAttr "recommended" $ str "recommended"
|
|
||||||
printTag Latest = withAttr "latest" $ str "latest"
|
|
||||||
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
|
|
||||||
printTag (UnknownTag t ) = str t
|
|
||||||
|
|
||||||
|
|
||||||
minHSize :: Int -> Widget n -> Widget n
|
|
||||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
|
||||||
|
|
||||||
|
|
||||||
app :: App AppState e String
|
|
||||||
app = App { appDraw = \st -> [ui st]
|
|
||||||
, appHandleEvent = eventHandler
|
|
||||||
, appStartEvent = return
|
|
||||||
, appAttrMap = const defaultAttributes
|
|
||||||
, appChooseCursor = neverShowCursor
|
|
||||||
}
|
|
||||||
|
|
||||||
defaultAttributes :: AttrMap
|
|
||||||
defaultAttributes = attrMap
|
|
||||||
Vty.defAttr
|
|
||||||
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
|
|
||||||
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
|
|
||||||
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
|
||||||
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
|
||||||
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
|
||||||
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
|
|
||||||
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
dimAttributes :: AttrMap
|
|
||||||
dimAttributes = attrMap
|
|
||||||
(Vty.defAttr `Vty.withStyle` Vty.dim)
|
|
||||||
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
|
|
||||||
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
|
|
||||||
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
|
|
||||||
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
|
|
||||||
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
|
|
||||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
|
|
||||||
continue (AppState (listMoveUp lr) dls pfreq)
|
|
||||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
|
|
||||||
continue (AppState (listMoveDown lr) dls pfreq)
|
|
||||||
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
|
||||||
case find (\(c', _, _) -> c' == c) keyHandlers of
|
|
||||||
Nothing -> continue as
|
|
||||||
Just (_, _, handler) -> handler as
|
|
||||||
eventHandler st _ = continue st
|
|
||||||
|
|
||||||
|
|
||||||
-- | Suspend the current UI and run an IO action in terminal. If the
|
|
||||||
-- IO action returns a Left value, then it's thrown as userError.
|
|
||||||
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
|
|
||||||
-> AppState
|
|
||||||
-> EventM n (Next AppState)
|
|
||||||
withIOAction action as = case listSelectedElement (lr as) of
|
|
||||||
Nothing -> continue as
|
|
||||||
Just (ix, e) -> suspendAndResume $ do
|
|
||||||
r <- action as (ix, e)
|
|
||||||
case r of
|
|
||||||
Left err -> throwIO $ userError err
|
|
||||||
Right _ -> do
|
|
||||||
apps <- (fmap . fmap)
|
|
||||||
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
|
|
||||||
$ getAppState Nothing (pfreq as)
|
|
||||||
case apps of
|
|
||||||
Right nas -> do
|
|
||||||
putStrLn "Press enter to continue"
|
|
||||||
_ <- getLine
|
|
||||||
pure nas
|
|
||||||
Left err -> throwIO $ userError err
|
|
||||||
|
|
||||||
|
|
||||||
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
||||||
install' AppState {..} (_, ListResult {..}) = do
|
|
||||||
settings <- readIORef settings'
|
|
||||||
l <- readIORef logger'
|
|
||||||
let runLogger = myLoggerT l
|
|
||||||
|
|
||||||
let
|
|
||||||
run =
|
|
||||||
runLogger
|
|
||||||
. flip runReaderT settings
|
|
||||||
. runResourceT
|
|
||||||
. runE
|
|
||||||
@'[AlreadyInstalled
|
|
||||||
, UnknownArchive
|
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
, FileDoesNotExistError
|
|
||||||
, CopyError
|
|
||||||
, NoDownload
|
|
||||||
, NotInstalled
|
|
||||||
, BuildFailed
|
|
||||||
, TagNotFound
|
|
||||||
, DigestError
|
|
||||||
, DownloadFailed
|
|
||||||
, NoUpdate]
|
|
||||||
|
|
||||||
(run $ do
|
|
||||||
case lTool of
|
|
||||||
GHC -> liftE $ installGHCBin dls lVer pfreq
|
|
||||||
Cabal -> liftE $ installCabalBin dls lVer pfreq
|
|
||||||
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
|
|
||||||
)
|
|
||||||
>>= \case
|
|
||||||
VRight _ -> pure $ Right ()
|
|
||||||
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
|
||||||
VLeft (V (BuildFailed _ e)) ->
|
|
||||||
pure $ Left [i|Build failed with #{e}|]
|
|
||||||
VLeft (V NoDownload) ->
|
|
||||||
pure $ Left [i|No available version for #{prettyVer lVer}|]
|
|
||||||
VLeft (V NoUpdate) -> pure $ Right ()
|
|
||||||
VLeft e -> pure $ Left [i|#{e}
|
|
||||||
Also check the logs in ~/.ghcup/logs|]
|
|
||||||
|
|
||||||
|
|
||||||
set' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
||||||
set' _ (_, ListResult {..}) = do
|
|
||||||
settings <- readIORef settings'
|
|
||||||
l <- readIORef logger'
|
|
||||||
let runLogger = myLoggerT l
|
|
||||||
|
|
||||||
let run =
|
|
||||||
runLogger
|
|
||||||
. flip runReaderT settings
|
|
||||||
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
|
|
||||||
|
|
||||||
(run $ do
|
|
||||||
case lTool of
|
|
||||||
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
|
|
||||||
Cabal -> liftE $ setCabal lVer $> ()
|
|
||||||
GHCup -> pure ()
|
|
||||||
)
|
|
||||||
>>= \case
|
|
||||||
VRight _ -> pure $ Right ()
|
|
||||||
VLeft e -> pure $ Left [i|#{e}|]
|
|
||||||
|
|
||||||
|
|
||||||
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
||||||
del' _ (_, ListResult {..}) = do
|
|
||||||
settings <- readIORef settings'
|
|
||||||
l <- readIORef logger'
|
|
||||||
let runLogger = myLoggerT l
|
|
||||||
|
|
||||||
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
|
||||||
|
|
||||||
(run $ do
|
|
||||||
case lTool of
|
|
||||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
|
|
||||||
Cabal -> liftE $ rmCabalVer lVer $> ()
|
|
||||||
GHCup -> pure ()
|
|
||||||
)
|
|
||||||
>>= \case
|
|
||||||
VRight _ -> pure $ Right ()
|
|
||||||
VLeft e -> pure $ Left [i|#{e}|]
|
|
||||||
|
|
||||||
|
|
||||||
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
||||||
changelog' AppState {..} (_, ListResult {..}) = do
|
|
||||||
case getChangeLog dls lTool (Left lVer) of
|
|
||||||
Nothing -> pure $ Left
|
|
||||||
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
|
|
||||||
Just uri -> do
|
|
||||||
let cmd = case _rPlatform pfreq of
|
|
||||||
Darwin -> "open"
|
|
||||||
Linux _ -> "xdg-open"
|
|
||||||
FreeBSD -> "xdg-open"
|
|
||||||
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
|
||||||
Right _ -> pure $ Right ()
|
|
||||||
Left e -> pure $ Left [i|#{e}|]
|
|
||||||
|
|
||||||
|
|
||||||
uri' :: IORef (Maybe URI)
|
|
||||||
{-# NOINLINE uri' #-}
|
|
||||||
uri' = unsafePerformIO (newIORef Nothing)
|
|
||||||
|
|
||||||
|
|
||||||
settings' :: IORef Settings
|
|
||||||
{-# NOINLINE settings' #-}
|
|
||||||
settings' = unsafePerformIO
|
|
||||||
(newIORef Settings { cache = True
|
|
||||||
, noVerify = False
|
|
||||||
, keepDirs = Never
|
|
||||||
, downloader = Curl
|
|
||||||
, verbose = False
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
logger' :: IORef LoggerConfig
|
|
||||||
{-# NOINLINE logger' #-}
|
|
||||||
logger' = unsafePerformIO
|
|
||||||
(newIORef $ LoggerConfig { lcPrintDebug = False
|
|
||||||
, colorOutter = \_ -> pure ()
|
|
||||||
, rawOutter = \_ -> pure ()
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
|
||||||
brickMain s muri l av pfreq' = do
|
|
||||||
writeIORef uri' muri
|
|
||||||
writeIORef settings' s
|
|
||||||
-- logger interpreter
|
|
||||||
writeIORef logger' l
|
|
||||||
let runLogger = myLoggerT l
|
|
||||||
|
|
||||||
eApps <- getAppState (Just av) pfreq'
|
|
||||||
case eApps of
|
|
||||||
Right as -> defaultMain app (selectLatest as) $> ()
|
|
||||||
Left e -> do
|
|
||||||
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
|
||||||
exitWith $ ExitFailure 2
|
|
||||||
where
|
|
||||||
selectLatest :: AppState -> AppState
|
|
||||||
selectLatest AppState {..} =
|
|
||||||
(\ix -> AppState { lr = listMoveTo ix lr, .. })
|
|
||||||
. fromJust
|
|
||||||
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
|
||||||
$ (listElements lr)
|
|
||||||
|
|
||||||
|
|
||||||
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
|
|
||||||
getAppState mg pfreq' = do
|
|
||||||
muri <- readIORef uri'
|
|
||||||
settings <- readIORef settings'
|
|
||||||
l <- readIORef logger'
|
|
||||||
let runLogger = myLoggerT l
|
|
||||||
|
|
||||||
r <-
|
|
||||||
runLogger
|
|
||||||
. flip runReaderT settings
|
|
||||||
. runE
|
|
||||||
@'[JSONError, DownloadFailed, FileDoesNotExistError]
|
|
||||||
$ do
|
|
||||||
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
|
|
||||||
|
|
||||||
lV <- lift $ listVersions dls Nothing Nothing pfreq'
|
|
||||||
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
|
|
||||||
|
|
||||||
case r of
|
|
||||||
VRight a -> pure $ Right a
|
|
||||||
VLeft e -> pure $ Left [i|#{e}|]
|
|
||||||
@@ -10,10 +10,6 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
#if defined(BRICK)
|
|
||||||
import BrickMain ( brickMain )
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import GHCup
|
import GHCup
|
||||||
import GHCup.Download
|
import GHCup.Download
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
@@ -25,12 +21,8 @@ import GHCup.Utils.File
|
|||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.MegaParsec
|
import GHCup.Utils.MegaParsec
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Utils.String.QQ
|
|
||||||
import GHCup.Version
|
import GHCup.Version
|
||||||
|
|
||||||
#if !defined(TAR)
|
|
||||||
import Codec.Archive
|
|
||||||
#endif
|
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
import Control.Monad.Fail ( MonadFail )
|
import Control.Monad.Fail ( MonadFail )
|
||||||
@@ -38,7 +30,6 @@ import Control.Monad.Fail ( MonadFail )
|
|||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
import Data.Aeson ( eitherDecode )
|
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Either
|
import Data.Either
|
||||||
@@ -69,7 +60,6 @@ import URI.ByteString
|
|||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.UTF8 as UTF8
|
import qualified Data.ByteString.UTF8 as UTF8
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as BLU
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
@@ -103,9 +93,6 @@ data Command
|
|||||||
| Upgrade UpgradeOpts Bool
|
| Upgrade UpgradeOpts Bool
|
||||||
| ToolRequirements
|
| ToolRequirements
|
||||||
| ChangeLog ChangeLogOptions
|
| ChangeLog ChangeLogOptions
|
||||||
#if defined(BRICK)
|
|
||||||
| Interactive
|
|
||||||
#endif
|
|
||||||
|
|
||||||
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
||||||
| ToolTag Tag
|
| ToolTag Tag
|
||||||
@@ -121,7 +108,6 @@ data InstallCommand = InstallGHC InstallOptions
|
|||||||
data InstallOptions = InstallOptions
|
data InstallOptions = InstallOptions
|
||||||
{ instVer :: Maybe ToolVersion
|
{ instVer :: Maybe ToolVersion
|
||||||
, instPlatform :: Maybe PlatformRequest
|
, instPlatform :: Maybe PlatformRequest
|
||||||
, instBindist :: Maybe DownloadInfo
|
|
||||||
}
|
}
|
||||||
|
|
||||||
data SetCommand = SetGHC SetOptions
|
data SetCommand = SetGHC SetOptions
|
||||||
@@ -235,20 +221,7 @@ opts =
|
|||||||
com :: Parser Command
|
com :: Parser Command
|
||||||
com =
|
com =
|
||||||
subparser
|
subparser
|
||||||
#if defined(BRICK)
|
|
||||||
( command
|
( command
|
||||||
"tui"
|
|
||||||
( (\_ -> Interactive)
|
|
||||||
<$> (info
|
|
||||||
helper
|
|
||||||
( progDesc "Start the interactive GHCup UI"
|
|
||||||
)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<> command
|
|
||||||
#else
|
|
||||||
( command
|
|
||||||
#endif
|
|
||||||
"install"
|
"install"
|
||||||
( Install
|
( Install
|
||||||
<$> (info
|
<$> (info
|
||||||
@@ -339,32 +312,32 @@ com =
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
installToolFooter :: String
|
installToolFooter :: String
|
||||||
installToolFooter = [s|Discussion:
|
installToolFooter = [i|Discussion:
|
||||||
Installs GHC or cabal. When no command is given, installs GHC
|
Installs GHC or cabal. When no command is given, installs GHC
|
||||||
with the specified version/tag.
|
with the specified version/tag.
|
||||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||||
|
|
||||||
setFooter :: String
|
setFooter :: String
|
||||||
setFooter = [s|Discussion:
|
setFooter = [i|Discussion:
|
||||||
Sets the currently active GHC or cabal version. When no command is given,
|
Sets the currently active GHC or cabal version. When no command is given,
|
||||||
defaults to setting GHC with the specified version/tag (if no tag
|
defaults to setting GHC with the specified version/tag (if no tag
|
||||||
is given, sets GHC to 'recommended' version).
|
is given, sets GHC to 'recommended' version).
|
||||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||||
|
|
||||||
rmFooter :: String
|
rmFooter :: String
|
||||||
rmFooter = [s|Discussion:
|
rmFooter = [i|Discussion:
|
||||||
Remove the given GHC or cabal version. When no command is given,
|
Remove the given GHC or cabal version. When no command is given,
|
||||||
defaults to removing GHC with the specified version.
|
defaults to removing GHC with the specified version.
|
||||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||||
|
|
||||||
changeLogFooter :: String
|
changeLogFooter :: String
|
||||||
changeLogFooter = [s|Discussion:
|
changeLogFooter = [i|Discussion:
|
||||||
By default returns the URI of the ChangeLog of the latest GHC release.
|
By default returns the URI of the ChangeLog of the latest GHC release.
|
||||||
Pass '-o' to automatically open via xdg-open.|]
|
Pass '-o' to automatically open via xdg-open.|]
|
||||||
|
|
||||||
|
|
||||||
installCabalFooter :: String
|
installCabalFooter :: String
|
||||||
installCabalFooter = [s|Discussion:
|
installCabalFooter = [i|Discussion:
|
||||||
Installs the specified cabal-install version (or a recommended default one)
|
Installs the specified cabal-install version (or a recommended default one)
|
||||||
into "~/.ghcup/bin", so it can be overwritten by later
|
into "~/.ghcup/bin", so it can be overwritten by later
|
||||||
"cabal install cabal-install", which installs into "~/.cabal/bin" by
|
"cabal install cabal-install", which installs into "~/.cabal/bin" by
|
||||||
@@ -400,7 +373,7 @@ installParser =
|
|||||||
<|> (Right <$> installOpts)
|
<|> (Right <$> installOpts)
|
||||||
where
|
where
|
||||||
installGHCFooter :: String
|
installGHCFooter :: String
|
||||||
installGHCFooter = [s|Discussion:
|
installGHCFooter = [i|Discussion:
|
||||||
Installs the specified GHC version (or a recommended default one) into
|
Installs the specified GHC version (or a recommended default one) into
|
||||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
|
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
|
||||||
@@ -408,7 +381,7 @@ installParser =
|
|||||||
|
|
||||||
installOpts :: Parser InstallOptions
|
installOpts :: Parser InstallOptions
|
||||||
installOpts =
|
installOpts =
|
||||||
(\p u v -> InstallOptions v p u)
|
(flip InstallOptions)
|
||||||
<$> (optional
|
<$> (optional
|
||||||
(option
|
(option
|
||||||
(eitherReader platformParser)
|
(eitherReader platformParser)
|
||||||
@@ -420,17 +393,6 @@ installOpts =
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
<*> (optional
|
|
||||||
(option
|
|
||||||
(eitherReader bindistParser)
|
|
||||||
( short 'u'
|
|
||||||
<> long "url"
|
|
||||||
<> metavar "BINDIST_URL"
|
|
||||||
<> help
|
|
||||||
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
|
|
||||||
)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<*> optional toolVersionArgument
|
<*> optional toolVersionArgument
|
||||||
|
|
||||||
|
|
||||||
@@ -462,13 +424,13 @@ setParser =
|
|||||||
<|> (Right <$> setOpts)
|
<|> (Right <$> setOpts)
|
||||||
where
|
where
|
||||||
setGHCFooter :: String
|
setGHCFooter :: String
|
||||||
setGHCFooter = [s|Discussion:
|
setGHCFooter = [i|Discussion:
|
||||||
Sets the the current GHC version by creating non-versioned
|
Sets the the current GHC version by creating non-versioned
|
||||||
symlinks for all ghc binaries of the specified version in
|
symlinks for all ghc binaries of the specified version in
|
||||||
"~/.ghcup/bin/<binary>".|]
|
"~/.ghcup/bin/<binary>".|]
|
||||||
|
|
||||||
setCabalFooter :: String
|
setCabalFooter :: String
|
||||||
setCabalFooter = [s|Discussion:
|
setCabalFooter = [i|Discussion:
|
||||||
Sets the the current Cabal version.|]
|
Sets the the current Cabal version.|]
|
||||||
|
|
||||||
|
|
||||||
@@ -568,7 +530,7 @@ compileP = subparser
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
compileFooter = [s|Discussion:
|
compileFooter = [i|Discussion:
|
||||||
Compiles and installs the specified GHC version into
|
Compiles and installs the specified GHC version into
|
||||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||||
@@ -814,8 +776,6 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
|||||||
pure v
|
pure v
|
||||||
|
|
||||||
|
|
||||||
bindistParser :: String -> Either String DownloadInfo
|
|
||||||
bindistParser = eitherDecode . BLU.fromString
|
|
||||||
|
|
||||||
|
|
||||||
toSettings :: Options -> Settings
|
toSettings :: Options -> Settings
|
||||||
@@ -824,7 +784,6 @@ toSettings Options {..} =
|
|||||||
noVerify = optNoVerify
|
noVerify = optNoVerify
|
||||||
keepDirs = optKeepDirs
|
keepDirs = optKeepDirs
|
||||||
downloader = optsDownloader
|
downloader = optsDownloader
|
||||||
verbose = optVerbose
|
|
||||||
in Settings { .. }
|
in Settings { .. }
|
||||||
|
|
||||||
|
|
||||||
@@ -884,7 +843,7 @@ main = do
|
|||||||
<> internal
|
<> internal
|
||||||
)
|
)
|
||||||
|
|
||||||
let main_footer = [s|Discussion:
|
let main_footer = [i|Discussion:
|
||||||
ghcup installs the Glasgow Haskell Compiler from the official
|
ghcup installs the Glasgow Haskell Compiler from the official
|
||||||
release channels, enabling you to easily switch between different
|
release channels, enabling you to easily switch between different
|
||||||
versions. It maintains a self-contained ~/.ghcup directory.
|
versions. It maintains a self-contained ~/.ghcup directory.
|
||||||
@@ -909,12 +868,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
|
|
||||||
-- logger interpreter
|
-- logger interpreter
|
||||||
logfile <- initGHCupFileLogging [rel|ghcup.log|]
|
logfile <- initGHCupFileLogging [rel|ghcup.log|]
|
||||||
let loggerConfig = LoggerConfig
|
let runLogger = myLoggerT LoggerConfig
|
||||||
{ lcPrintDebug = optVerbose
|
{ lcPrintDebug = optVerbose
|
||||||
, colorOutter = B.hPut stderr
|
, colorOutter = B.hPut stderr
|
||||||
, rawOutter = appendFile logfile
|
, rawOutter = appendFile logfile
|
||||||
}
|
}
|
||||||
let runLogger = myLoggerT loggerConfig
|
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
@@ -928,13 +886,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
. runE
|
. runE
|
||||||
@'[ AlreadyInstalled
|
@'[ AlreadyInstalled
|
||||||
, UnknownArchive
|
, UnknownArchive
|
||||||
#if !defined(TAR)
|
, DistroNotFound
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
, FileDoesNotExistError
|
, FileDoesNotExistError
|
||||||
, CopyError
|
, CopyError
|
||||||
|
, NoCompatibleArch
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NotInstalled
|
, NotInstalled
|
||||||
|
, NoCompatiblePlatform
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
, TagNotFound
|
, TagNotFound
|
||||||
, DigestError
|
, DigestError
|
||||||
@@ -949,6 +907,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
@'[ FileDoesNotExistError
|
@'[ FileDoesNotExistError
|
||||||
, NotInstalled
|
, NotInstalled
|
||||||
, TagNotFound
|
, TagNotFound
|
||||||
|
, TagNotFound
|
||||||
]
|
]
|
||||||
|
|
||||||
let
|
let
|
||||||
@@ -959,9 +918,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
, TagNotFound
|
, TagNotFound
|
||||||
]
|
]
|
||||||
|
|
||||||
let runListGHC = runLogger
|
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
|
||||||
|
|
||||||
let runRm =
|
let runRmGHC =
|
||||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||||
|
|
||||||
let runDebugInfo =
|
let runDebugInfo =
|
||||||
@@ -978,15 +937,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
@'[ AlreadyInstalled
|
@'[ AlreadyInstalled
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
, DigestError
|
, DigestError
|
||||||
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
, GHCupSetError
|
, GHCupSetError
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoCompatiblePlatform
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NotFoundInPATH
|
, NotFoundInPATH
|
||||||
, PatchFailed
|
, PatchFailed
|
||||||
, UnknownArchive
|
, UnknownArchive
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
]
|
||||||
|
|
||||||
let runCompileCabal =
|
let runCompileCabal =
|
||||||
@@ -998,14 +957,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
, BuildFailed
|
, BuildFailed
|
||||||
, CopyError
|
, CopyError
|
||||||
, DigestError
|
, DigestError
|
||||||
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoCompatiblePlatform
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NotInstalled
|
, NotInstalled
|
||||||
, PatchFailed
|
, PatchFailed
|
||||||
, UnknownArchive
|
, UnknownArchive
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
]
|
||||||
|
|
||||||
let runUpgrade =
|
let runUpgrade =
|
||||||
@@ -1014,6 +973,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
. runResourceT
|
. runResourceT
|
||||||
. runE
|
. runE
|
||||||
@'[ DigestError
|
@'[ DigestError
|
||||||
|
, DistroNotFound
|
||||||
|
, NoCompatiblePlatform
|
||||||
|
, NoCompatibleArch
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NoUpdate
|
, NoUpdate
|
||||||
, FileDoesNotExistError
|
, FileDoesNotExistError
|
||||||
@@ -1022,19 +984,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
----------------------------------------
|
---------------------------
|
||||||
-- Getting download and platform info --
|
-- Getting download info --
|
||||||
----------------------------------------
|
---------------------------
|
||||||
|
|
||||||
pfreq <- (
|
|
||||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
|
||||||
) >>= \case
|
|
||||||
VRight r -> pure r
|
|
||||||
VLeft e -> do
|
|
||||||
runLogger
|
|
||||||
($(logError) [i|Error determining Platform: #{e}|])
|
|
||||||
exitWith (ExitFailure 2)
|
|
||||||
|
|
||||||
|
|
||||||
(GHCupInfo treq dls) <-
|
(GHCupInfo treq dls) <-
|
||||||
( runLogger
|
( runLogger
|
||||||
@@ -1049,11 +1001,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
runLogger
|
runLogger
|
||||||
($(logError) [i|Error fetching download info: #{e}|])
|
($(logError) [i|Error fetching download info: #{e}|])
|
||||||
exitWith (ExitFailure 2)
|
exitWith (ExitFailure 2)
|
||||||
|
(runLogger
|
||||||
case optCommand of
|
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
|
||||||
Upgrade _ _ -> pure ()
|
)
|
||||||
_ -> runLogger $ checkForUpdates dls pfreq
|
>>= \case
|
||||||
|
VRight _ -> pure ()
|
||||||
|
VLeft e -> do
|
||||||
|
runLogger
|
||||||
|
($(logError) [i|Error checking for upgrades: #{e}|])
|
||||||
|
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
@@ -1063,9 +1018,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
let installGHC InstallOptions{..} =
|
let installGHC InstallOptions{..} =
|
||||||
(runInstTool $ do
|
(runInstTool $ do
|
||||||
v <- liftE $ fromVersion dls instVer GHC
|
v <- liftE $ fromVersion dls instVer GHC
|
||||||
case instBindist of
|
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
|
||||||
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
|
||||||
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
|
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
VRight _ -> do
|
VRight _ -> do
|
||||||
@@ -1099,9 +1052,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
let installCabal InstallOptions{..} =
|
let installCabal InstallOptions{..} =
|
||||||
(runInstTool $ do
|
(runInstTool $ do
|
||||||
v <- liftE $ fromVersion dls instVer Cabal
|
v <- liftE $ fromVersion dls instVer Cabal
|
||||||
case instBindist of
|
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
|
||||||
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
|
||||||
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
|
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
VRight _ -> do
|
VRight _ -> do
|
||||||
@@ -1151,7 +1102,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
pure $ ExitFailure 14
|
pure $ ExitFailure 14
|
||||||
|
|
||||||
let rmGHC' RmOptions{..} =
|
let rmGHC' RmOptions{..} =
|
||||||
(runRm $ do
|
(runRmGHC $ do
|
||||||
liftE $ rmGHCVer ghcVer
|
liftE $ rmGHCVer ghcVer
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
@@ -1161,7 +1112,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
pure $ ExitFailure 7
|
pure $ ExitFailure 7
|
||||||
|
|
||||||
let rmCabal' tv =
|
let rmCabal' tv =
|
||||||
(runRm $ do
|
(runSetCabal $ do
|
||||||
liftE $ rmCabalVer tv
|
liftE $ rmCabalVer tv
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
@@ -1173,9 +1124,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
|
|
||||||
|
|
||||||
res <- case optCommand of
|
res <- case optCommand of
|
||||||
#if defined(BRICK)
|
|
||||||
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
|
|
||||||
#endif
|
|
||||||
Install (Right iopts) -> do
|
Install (Right iopts) -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
||||||
installGHC iopts
|
installGHC iopts
|
||||||
@@ -1193,10 +1141,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
|
|
||||||
List (ListOptions {..}) ->
|
List (ListOptions {..}) ->
|
||||||
(runListGHC $ do
|
(runListGHC $ do
|
||||||
l <- listVersions dls lTool lCriteria pfreq
|
l <- listVersions dls lTool lCriteria
|
||||||
liftIO $ printListResult lRawFormat l
|
pure l
|
||||||
pure ExitSuccess
|
|
||||||
)
|
)
|
||||||
|
>>= \case
|
||||||
|
VRight r -> do
|
||||||
|
liftIO $ printListResult lRawFormat r
|
||||||
|
pure ExitSuccess
|
||||||
|
VLeft e -> do
|
||||||
|
runLogger ($(logError) [i|#{e}|])
|
||||||
|
pure $ ExitFailure 6
|
||||||
|
|
||||||
Rm (Right rmopts) -> do
|
Rm (Right rmopts) -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
|
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
|
||||||
@@ -1223,7 +1177,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
buildConfig
|
buildConfig
|
||||||
patchDir
|
patchDir
|
||||||
addConfArgs
|
addConfArgs
|
||||||
pfreq
|
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
VRight _ -> do
|
VRight _ -> do
|
||||||
@@ -1248,7 +1201,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
|
|
||||||
Compile (CompileCabal CabalCompileOptions {..}) ->
|
Compile (CompileCabal CabalCompileOptions {..}) ->
|
||||||
(runCompileCabal $ do
|
(runCompileCabal $ do
|
||||||
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
|
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
VRight _ -> do
|
VRight _ -> do
|
||||||
@@ -1279,7 +1232,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
bdir <- liftIO $ ghcupBinDir
|
bdir <- liftIO $ ghcupBinDir
|
||||||
pure (Just (bdir </> [rel|ghcup|]))
|
pure (Just (bdir </> [rel|ghcup|]))
|
||||||
|
|
||||||
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
|
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
|
||||||
VRight v' -> do
|
VRight v' -> do
|
||||||
let pretty_v = prettyVer v'
|
let pretty_v = prettyVer v'
|
||||||
runLogger $ $(logInfo)
|
runLogger $ $(logInfo)
|
||||||
@@ -1331,14 +1284,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||||
cmd = case _rPlatform pfreq of
|
|
||||||
Darwin -> "open"
|
|
||||||
Linux _ -> "xdg-open"
|
|
||||||
FreeBSD -> "xdg-open"
|
|
||||||
|
|
||||||
if clOpen
|
if clOpen
|
||||||
then
|
then
|
||||||
exec cmd
|
exec "xdg-open"
|
||||||
True
|
True
|
||||||
[serializeURIRef' uri]
|
[serializeURIRef' uri]
|
||||||
Nothing
|
Nothing
|
||||||
@@ -1430,32 +1378,37 @@ printListResult raw lr = do
|
|||||||
|
|
||||||
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
|
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
|
||||||
=> GHCupDownloads
|
=> GHCupDownloads
|
||||||
-> PlatformRequest
|
-> Excepts
|
||||||
-> m ()
|
'[ NoCompatiblePlatform
|
||||||
checkForUpdates dls pfreq = do
|
, NoCompatibleArch
|
||||||
|
, DistroNotFound
|
||||||
|
]
|
||||||
|
m
|
||||||
|
()
|
||||||
|
checkForUpdates dls = do
|
||||||
forM_ (getLatest dls GHCup) $ \l -> do
|
forM_ (getLatest dls GHCup) $ \l -> do
|
||||||
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
||||||
when (l > ghc_ver)
|
when (l > ghc_ver)
|
||||||
$ $(logWarn)
|
$ lift $ $(logWarn)
|
||||||
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
|
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
|
||||||
|
|
||||||
forM_ (getLatest dls GHC) $ \l -> do
|
forM_ (getLatest dls GHC) $ \l -> do
|
||||||
mghc_ver <- latestInstalled GHC
|
mghc_ver <- latestInstalled GHC
|
||||||
forM mghc_ver $ \ghc_ver ->
|
forM mghc_ver $ \ghc_ver ->
|
||||||
when (l > ghc_ver)
|
when (l > ghc_ver)
|
||||||
$ $(logWarn)
|
$ lift $ $(logWarn)
|
||||||
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
|
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
|
||||||
|
|
||||||
forM_ (getLatest dls Cabal) $ \l -> do
|
forM_ (getLatest dls Cabal) $ \l -> do
|
||||||
mcabal_ver <- latestInstalled Cabal
|
mcabal_ver <- latestInstalled Cabal
|
||||||
forM mcabal_ver $ \cabal_ver ->
|
forM mcabal_ver $ \cabal_ver ->
|
||||||
when (l > cabal_ver)
|
when (l > cabal_ver)
|
||||||
$ $(logWarn)
|
$ lift $ $(logWarn)
|
||||||
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
|
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
|
||||||
|
|
||||||
where
|
where
|
||||||
latestInstalled tool = (fmap lVer . lastMay)
|
latestInstalled tool = (fmap lVer . lastMay)
|
||||||
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
|
<$> (listVersions dls (Just tool) (Just ListInstalled))
|
||||||
|
|
||||||
|
|
||||||
prettyDebugInfo :: DebugInfo -> String
|
prettyDebugInfo :: DebugInfo -> String
|
||||||
@@ -1472,13 +1425,6 @@ Version: #{describe_result}|]
|
|||||||
prettyArch :: Architecture -> String
|
prettyArch :: Architecture -> String
|
||||||
prettyArch A_64 = "amd64"
|
prettyArch A_64 = "amd64"
|
||||||
prettyArch A_32 = "i386"
|
prettyArch A_32 = "i386"
|
||||||
prettyArch A_PowerPC = "PowerPC"
|
|
||||||
prettyArch A_PowerPC64 = "PowerPC64"
|
|
||||||
prettyArch A_Sparc = "Sparc"
|
|
||||||
prettyArch A_Sparc64 = "Sparc64"
|
|
||||||
prettyArch A_ARM = "ARM"
|
|
||||||
prettyArch A_ARM64 = "ARM64"
|
|
||||||
|
|
||||||
prettyPlatform :: PlatformResult -> String
|
prettyPlatform :: PlatformResult -> String
|
||||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
|
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||||
= show plat <> ", " <> show v'
|
= show plat <> ", " <> show v'
|
||||||
|
|||||||
@@ -18,39 +18,26 @@ edo()
|
|||||||
}
|
}
|
||||||
|
|
||||||
eghcup() {
|
eghcup() {
|
||||||
edo _eghcup "$@"
|
|
||||||
}
|
|
||||||
|
|
||||||
_eghcup() {
|
|
||||||
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
|
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
|
||||||
ghcup "$@"
|
edo ghcup "$@"
|
||||||
else
|
else
|
||||||
ghcup --verbose "$@"
|
edo ghcup --verbose "$@"
|
||||||
fi
|
fi
|
||||||
}
|
}
|
||||||
|
|
||||||
download_ghcup() {
|
download_ghcup() {
|
||||||
_plat="$(uname -s)"
|
_plat="$(uname -s)"
|
||||||
_arch=$(uname -m)
|
_arch=$(uname -m)
|
||||||
_ghver="0.1.8"
|
_ghver="0.1.5"
|
||||||
_base_url="https://downloads.haskell.org/~ghcup"
|
|
||||||
|
|
||||||
case "${_plat}" in
|
case "${_plat}" in
|
||||||
"linux"|"Linux")
|
"linux"|"Linux")
|
||||||
case "${_arch}" in
|
case "${_arch}" in
|
||||||
x86_64|amd64)
|
x86_64|amd64)
|
||||||
# we could be in a 32bit docker container, in which
|
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-linux-ghcup-${_ghver}
|
||||||
# case uname doesn't give us what we want
|
|
||||||
if [ "$(getconf LONG_BIT)" = "32" ] ; then
|
|
||||||
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
|
|
||||||
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
|
|
||||||
_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
|
|
||||||
else
|
|
||||||
die "Unknown long bit size: $(getconf LONG_BIT)"
|
|
||||||
fi
|
|
||||||
;;
|
;;
|
||||||
i*86)
|
i*86)
|
||||||
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
|
_url=https://downloads.haskell.org/~ghcup/${_ghver}/i386-linux-ghcup-${_ghver}
|
||||||
;;
|
;;
|
||||||
*) die "Unknown architecture: ${_arch}"
|
*) die "Unknown architecture: ${_arch}"
|
||||||
;;
|
;;
|
||||||
@@ -66,7 +53,7 @@ download_ghcup() {
|
|||||||
*) die "Unknown architecture: ${_arch}"
|
*) die "Unknown architecture: ${_arch}"
|
||||||
;;
|
;;
|
||||||
esac
|
esac
|
||||||
_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
|
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
|
||||||
;;
|
;;
|
||||||
"Darwin"|"darwin")
|
"Darwin"|"darwin")
|
||||||
case "${_arch}" in
|
case "${_arch}" in
|
||||||
@@ -78,23 +65,14 @@ download_ghcup() {
|
|||||||
*) die "Unknown architecture: ${_arch}"
|
*) die "Unknown architecture: ${_arch}"
|
||||||
;;
|
;;
|
||||||
esac
|
esac
|
||||||
_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
|
_url=https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2 ;;
|
||||||
*) die "Unknown platform: ${_plat}"
|
*) die "Unknown platform: ${_plat}"
|
||||||
;;
|
;;
|
||||||
esac
|
esac
|
||||||
|
|
||||||
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
||||||
|
|
||||||
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
unset _plat _arch _url _ghver
|
||||||
|
|
||||||
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
|
|
||||||
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
|
|
||||||
EOF
|
|
||||||
# shellcheck disable=SC1090
|
|
||||||
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
|
|
||||||
eghcup upgrade
|
|
||||||
|
|
||||||
unset _plat _arch _url _ghver _base_url
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@@ -123,10 +101,18 @@ edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
|
|||||||
|
|
||||||
if command -V "ghcup" >/dev/null 2>&1 ; then
|
if command -V "ghcup" >/dev/null 2>&1 ; then
|
||||||
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
|
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
|
||||||
_eghcup upgrade || download_ghcup
|
eghcup upgrade
|
||||||
fi
|
fi
|
||||||
else
|
else
|
||||||
download_ghcup
|
download_ghcup
|
||||||
|
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
||||||
|
|
||||||
|
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
|
||||||
|
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
|
||||||
|
EOF
|
||||||
|
# shellcheck disable=SC1090
|
||||||
|
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
|
||||||
|
eghcup upgrade
|
||||||
fi
|
fi
|
||||||
|
|
||||||
echo
|
echo
|
||||||
@@ -143,10 +129,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
|||||||
read -r answer </dev/tty
|
read -r answer </dev/tty
|
||||||
fi
|
fi
|
||||||
|
|
||||||
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
eghcup --cache install "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||||
|
|
||||||
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
eghcup set "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||||
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
|
eghcup --cache install-cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
|
||||||
|
|
||||||
edo cabal new-update
|
edo cabal new-update
|
||||||
|
|
||||||
@@ -177,9 +163,6 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
|||||||
exit 0
|
exit 0
|
||||||
fi
|
fi
|
||||||
;;
|
;;
|
||||||
*/fish) # login shell is fish
|
|
||||||
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
|
|
||||||
MY_SHELL="fish" ;;
|
|
||||||
*) exit 0 ;;
|
*) exit 0 ;;
|
||||||
esac
|
esac
|
||||||
|
|
||||||
@@ -195,16 +178,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
|||||||
|
|
||||||
case $next_answer in
|
case $next_answer in
|
||||||
[Yy]*)
|
[Yy]*)
|
||||||
case $MY_SHELL in
|
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
|
||||||
"") break ;;
|
|
||||||
fish)
|
|
||||||
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
|
|
||||||
echo "test -f \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env ; and set -gx PATH \$HOME/.cabal/bin \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
|
|
||||||
break ;;
|
|
||||||
*)
|
|
||||||
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
|
|
||||||
break ;;
|
|
||||||
esac
|
|
||||||
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
|
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
|
||||||
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
|
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
|
||||||
exit 0;;
|
exit 0;;
|
||||||
|
|||||||
@@ -2,12 +2,6 @@ packages: ./ghcup.cabal
|
|||||||
|
|
||||||
optional-packages: ./3rdparty/*/*.cabal
|
optional-packages: ./3rdparty/*/*.cabal
|
||||||
|
|
||||||
source-repository-package
|
|
||||||
type: git
|
|
||||||
location: https://github.com/haskus/packages.git
|
|
||||||
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
|
|
||||||
subdir: haskus-utils-types
|
|
||||||
|
|
||||||
optimization: 2
|
optimization: 2
|
||||||
|
|
||||||
package streamly
|
package streamly
|
||||||
@@ -16,9 +10,9 @@ package streamly
|
|||||||
package ghcup
|
package ghcup
|
||||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||||
|
|
||||||
|
package tar-bytestring
|
||||||
|
ghc-options: -O2
|
||||||
|
|
||||||
constraints: http-io-streams -brotli
|
constraints: http-io-streams -brotli
|
||||||
|
|
||||||
package libarchive
|
allow-newer: base
|
||||||
flags: static
|
|
||||||
|
|
||||||
allow-newer: base ghc-prim template-haskell
|
|
||||||
|
|||||||
2299
ghcup-0.0.2.json
Normal file
2299
ghcup-0.0.2.json
Normal file
File diff suppressed because it is too large
Load Diff
1322
ghcup-0.0.2.yaml
1322
ghcup-0.0.2.yaml
File diff suppressed because it is too large
Load Diff
78
ghcup.cabal
78
ghcup.cabal
@@ -1,6 +1,6 @@
|
|||||||
cabal-version: 3.0
|
cabal-version: 3.0
|
||||||
name: ghcup
|
name: ghcup
|
||||||
version: 0.1.8
|
version: 0.1.5
|
||||||
synopsis: ghc toolchain installer as an exe/library
|
synopsis: ghc toolchain installer as an exe/library
|
||||||
description:
|
description:
|
||||||
A rewrite of the shell script ghcup, for providing
|
A rewrite of the shell script ghcup, for providing
|
||||||
@@ -21,21 +21,11 @@ source-repository head
|
|||||||
type: git
|
type: git
|
||||||
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||||
|
|
||||||
flag tui
|
|
||||||
description: Build the brick powered tui (ghcup tui)
|
|
||||||
default: False
|
|
||||||
manual: True
|
|
||||||
|
|
||||||
flag internal-downloader
|
flag internal-downloader
|
||||||
description: Compile the internal downloader, which links against OpenSSL
|
description: Compile the internal downloader, which links against OpenSSL
|
||||||
default: False
|
default: False
|
||||||
manual: True
|
manual: True
|
||||||
|
|
||||||
flag tar
|
|
||||||
description: Use tar-bytestring instead of libarchive
|
|
||||||
default: False
|
|
||||||
manual: True
|
|
||||||
|
|
||||||
common HsOpenSSL
|
common HsOpenSSL
|
||||||
build-depends: HsOpenSSL >=0.11.4.18
|
build-depends: HsOpenSSL >=0.11.4.18
|
||||||
|
|
||||||
@@ -60,9 +50,6 @@ common base16-bytestring
|
|||||||
common binary
|
common binary
|
||||||
build-depends: binary >=0.8.6.0
|
build-depends: binary >=0.8.6.0
|
||||||
|
|
||||||
common brick
|
|
||||||
build-depends: brick >=0.54
|
|
||||||
|
|
||||||
common bytestring
|
common bytestring
|
||||||
build-depends: bytestring >=0.10
|
build-depends: bytestring >=0.10
|
||||||
|
|
||||||
@@ -94,13 +81,13 @@ common hpath
|
|||||||
build-depends: hpath >=0.11
|
build-depends: hpath >=0.11
|
||||||
|
|
||||||
common hpath-directory
|
common hpath-directory
|
||||||
build-depends: hpath-directory >=0.14
|
build-depends: hpath-directory >=0.13.3
|
||||||
|
|
||||||
common hpath-filepath
|
common hpath-filepath
|
||||||
build-depends: hpath-filepath >=0.10.3
|
build-depends: hpath-filepath >=0.10.3
|
||||||
|
|
||||||
common hpath-io
|
common hpath-io
|
||||||
build-depends: hpath-io >=0.14
|
build-depends: hpath-io >=0.13.1
|
||||||
|
|
||||||
common hpath-posix
|
common hpath-posix
|
||||||
build-depends: hpath-posix >=0.13.2
|
build-depends: hpath-posix >=0.13.2
|
||||||
@@ -111,8 +98,8 @@ common http-io-streams
|
|||||||
common io-streams
|
common io-streams
|
||||||
build-depends: io-streams >=1.5
|
build-depends: io-streams >=1.5
|
||||||
|
|
||||||
common libarchive
|
common language-bash
|
||||||
build-depends: libarchive >= 2.2.5.2
|
build-depends: language-bash >=0.9
|
||||||
|
|
||||||
common lzma
|
common lzma
|
||||||
build-depends: lzma >=0.0.0.3
|
build-depends: lzma >=0.0.0.3
|
||||||
@@ -171,17 +158,17 @@ common string-interpolate
|
|||||||
common table-layout
|
common table-layout
|
||||||
build-depends: table-layout >=0.8
|
build-depends: table-layout >=0.8
|
||||||
|
|
||||||
common template-haskell
|
|
||||||
build-depends: template-haskell >=2.7
|
|
||||||
|
|
||||||
common tar-bytestring
|
common tar-bytestring
|
||||||
build-depends: tar-bytestring >=0.6.3.1
|
build-depends: tar-bytestring >=0.6.3.1
|
||||||
|
|
||||||
|
common template-haskell
|
||||||
|
build-depends: template-haskell >=2.7
|
||||||
|
|
||||||
common terminal-progress-bar
|
common terminal-progress-bar
|
||||||
build-depends: terminal-progress-bar >=0.4.1
|
build-depends: terminal-progress-bar >=0.4.1
|
||||||
|
|
||||||
common text
|
common text
|
||||||
build-depends: text >=1.2.4.0
|
build-depends: text >=1.2
|
||||||
|
|
||||||
common time
|
common time
|
||||||
build-depends: time >=1.9.3
|
build-depends: time >=1.9.3
|
||||||
@@ -189,18 +176,12 @@ common time
|
|||||||
common transformers
|
common transformers
|
||||||
build-depends: transformers >=0.5
|
build-depends: transformers >=0.5
|
||||||
|
|
||||||
common os-release
|
|
||||||
build-depends: os-release >=1.0.0
|
|
||||||
|
|
||||||
common unix
|
common unix
|
||||||
build-depends: unix >=2.7
|
build-depends: unix >=2.7
|
||||||
|
|
||||||
common unix-bytestring
|
common unix-bytestring
|
||||||
build-depends: unix-bytestring >=0.3
|
build-depends: unix-bytestring >=0.3
|
||||||
|
|
||||||
common unordered-containers
|
|
||||||
build-depends: unordered-containers >= 0.2.10.0
|
|
||||||
|
|
||||||
common uri-bytestring
|
common uri-bytestring
|
||||||
build-depends: uri-bytestring >=0.3.2.2
|
build-depends: uri-bytestring >=0.3.2.2
|
||||||
|
|
||||||
@@ -213,15 +194,12 @@ common vector
|
|||||||
common versions
|
common versions
|
||||||
build-depends: versions >=3.5
|
build-depends: versions >=3.5
|
||||||
|
|
||||||
common vty
|
common waargonaut
|
||||||
build-depends: vty >=5.28.2
|
build-depends: waargonaut >=0.8
|
||||||
|
|
||||||
common word8
|
common word8
|
||||||
build-depends: word8 >=0.1.3
|
build-depends: word8 >=0.1.3
|
||||||
|
|
||||||
common yaml
|
|
||||||
build-depends: yaml >=0.11.4.0
|
|
||||||
|
|
||||||
common zlib
|
common zlib
|
||||||
build-depends: zlib >=0.6.2.1
|
build-depends: zlib >=0.6.2.1
|
||||||
|
|
||||||
@@ -264,6 +242,7 @@ library
|
|||||||
, hpath-filepath
|
, hpath-filepath
|
||||||
, hpath-io
|
, hpath-io
|
||||||
, hpath-posix
|
, hpath-posix
|
||||||
|
, language-bash
|
||||||
, lzma
|
, lzma
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, monad-logger
|
, monad-logger
|
||||||
@@ -281,24 +260,25 @@ library
|
|||||||
, streamly-bytestring
|
, streamly-bytestring
|
||||||
, strict-base
|
, strict-base
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
|
, tar-bytestring
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, os-release
|
|
||||||
, unix
|
, unix
|
||||||
, unix-bytestring
|
, unix-bytestring
|
||||||
, unordered-containers
|
|
||||||
, uri-bytestring
|
, uri-bytestring
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, vector
|
, vector
|
||||||
, versions
|
, versions
|
||||||
, word8
|
, word8
|
||||||
, yaml
|
|
||||||
, zlib
|
, zlib
|
||||||
|
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
GHCup
|
GHCup
|
||||||
|
GHCup.Data.GHCupDownloads
|
||||||
|
GHCup.Data.GHCupInfo
|
||||||
|
GHCup.Data.ToolRequirements
|
||||||
GHCup.Download
|
GHCup.Download
|
||||||
GHCup.Download.Utils
|
GHCup.Download.Utils
|
||||||
GHCup.Errors
|
GHCup.Errors
|
||||||
@@ -308,6 +288,7 @@ library
|
|||||||
GHCup.Types.JSON
|
GHCup.Types.JSON
|
||||||
GHCup.Types.Optics
|
GHCup.Types.Optics
|
||||||
GHCup.Utils
|
GHCup.Utils
|
||||||
|
GHCup.Utils.Bash
|
||||||
GHCup.Utils.Dirs
|
GHCup.Utils.Dirs
|
||||||
GHCup.Utils.File
|
GHCup.Utils.File
|
||||||
GHCup.Utils.Logger
|
GHCup.Utils.Logger
|
||||||
@@ -323,26 +304,17 @@ library
|
|||||||
|
|
||||||
if flag(internal-downloader)
|
if flag(internal-downloader)
|
||||||
import:
|
import:
|
||||||
HsOpenSSL
|
, HsOpenSSL
|
||||||
, http-io-streams
|
, http-io-streams
|
||||||
, io-streams
|
, io-streams
|
||||||
, terminal-progress-bar
|
, terminal-progress-bar
|
||||||
exposed-modules: GHCup.Download.IOStreams
|
exposed-modules: GHCup.Download.IOStreams
|
||||||
cpp-options: -DINTERNAL_DOWNLOADER
|
cpp-options: -DINTERNAL_DOWNLOADER
|
||||||
|
|
||||||
if flag(tar)
|
|
||||||
import:
|
|
||||||
tar-bytestring
|
|
||||||
cpp-options: -DTAR
|
|
||||||
else
|
|
||||||
import:
|
|
||||||
libarchive
|
|
||||||
|
|
||||||
executable ghcup
|
executable ghcup
|
||||||
import:
|
import:
|
||||||
config
|
config
|
||||||
, base
|
, base
|
||||||
, aeson
|
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, haskus-utils-variant
|
, haskus-utils-variant
|
||||||
@@ -376,19 +348,6 @@ executable ghcup
|
|||||||
if flag(internal-downloader)
|
if flag(internal-downloader)
|
||||||
cpp-options: -DINTERNAL_DOWNLOADER
|
cpp-options: -DINTERNAL_DOWNLOADER
|
||||||
|
|
||||||
if flag(tui)
|
|
||||||
import:
|
|
||||||
brick
|
|
||||||
, vector
|
|
||||||
, vty
|
|
||||||
other-modules: BrickMain
|
|
||||||
cpp-options: -DBRICK
|
|
||||||
|
|
||||||
if flag(tar)
|
|
||||||
cpp-options: -DTAR
|
|
||||||
else
|
|
||||||
import:
|
|
||||||
libarchive
|
|
||||||
|
|
||||||
executable ghcup-gen
|
executable ghcup-gen
|
||||||
import:
|
import:
|
||||||
@@ -414,7 +373,6 @@ executable ghcup-gen
|
|||||||
, uri-bytestring
|
, uri-bytestring
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, versions
|
, versions
|
||||||
, yaml
|
|
||||||
|
|
||||||
--
|
--
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
|||||||
341
lib/GHCup.hs
341
lib/GHCup.hs
@@ -11,21 +11,6 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup
|
|
||||||
Description : GHCup installation functions
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
This module contains the main functions that correspond
|
|
||||||
to the command line interface, like installation, listing versions
|
|
||||||
and so on.
|
|
||||||
|
|
||||||
These are the entry points.
|
|
||||||
-}
|
|
||||||
module GHCup where
|
module GHCup where
|
||||||
|
|
||||||
|
|
||||||
@@ -42,9 +27,6 @@ import GHCup.Utils.String.QQ
|
|||||||
import GHCup.Utils.Version.QQ
|
import GHCup.Utils.Version.QQ
|
||||||
import GHCup.Version
|
import GHCup.Version
|
||||||
|
|
||||||
#if !defined(TAR)
|
|
||||||
import Codec.Archive ( ArchiveResult )
|
|
||||||
#endif
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
@@ -65,7 +47,7 @@ import Data.Versions
|
|||||||
import Data.Word8
|
import Data.Word8
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO hiding ( hideError )
|
import HPath.IO
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import Prelude hiding ( abs
|
import Prelude hiding ( abs
|
||||||
@@ -91,40 +73,42 @@ import qualified Data.Text.Encoding as E
|
|||||||
-------------------------
|
-------------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Like 'installGHCBin', except takes the 'DownloadInfo' as
|
|
||||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
installGHCBin :: ( MonadFail m
|
||||||
installGHCBindist :: ( MonadFail m
|
, MonadMask m
|
||||||
, MonadMask m
|
, MonadCatch m
|
||||||
, MonadCatch m
|
, MonadReader Settings m
|
||||||
, MonadReader Settings m
|
, MonadLogger m
|
||||||
, MonadLogger m
|
, MonadResource m
|
||||||
, MonadResource m
|
, MonadIO m
|
||||||
, MonadIO m
|
)
|
||||||
)
|
=> GHCupDownloads
|
||||||
=> DownloadInfo -- ^ where/how to download
|
-> Version
|
||||||
-> Version -- ^ the version to install
|
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||||
-> PlatformRequest -- ^ the platform to install on
|
-> Excepts
|
||||||
-> Excepts
|
'[ AlreadyInstalled
|
||||||
'[ AlreadyInstalled
|
, BuildFailed
|
||||||
, BuildFailed
|
, DigestError
|
||||||
, DigestError
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
, NoDownload
|
, NoCompatibleArch
|
||||||
, NotInstalled
|
, NoCompatiblePlatform
|
||||||
, UnknownArchive
|
, NoDownload
|
||||||
#if !defined(TAR)
|
, NotInstalled
|
||||||
, ArchiveResult
|
, UnknownArchive
|
||||||
#endif
|
]
|
||||||
]
|
m
|
||||||
m
|
()
|
||||||
()
|
installGHCBin bDls ver mpfReq = do
|
||||||
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
|
|
||||||
let tver = (mkTVer ver)
|
let tver = (mkTVer ver)
|
||||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||||
whenM (liftIO $ ghcInstalled tver)
|
whenM (liftIO $ ghcInstalled tver)
|
||||||
$ (throwE $ AlreadyInstalled GHC ver)
|
$ (throwE $ AlreadyInstalled GHC ver)
|
||||||
|
Settings {..} <- lift ask
|
||||||
|
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
|
||||||
|
|
||||||
-- download (or use cached version)
|
-- download (or use cached version)
|
||||||
|
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
|
||||||
dl <- liftE $ downloadCached dlinfo Nothing
|
dl <- liftE $ downloadCached dlinfo Nothing
|
||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
@@ -144,90 +128,48 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
|
|||||||
|
|
||||||
where
|
where
|
||||||
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
|
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
|
||||||
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
|
installGHC' :: (MonadLogger m, MonadIO m)
|
||||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||||
-> Path Abs -- ^ Path to install to
|
-> Path Abs -- ^ Path to install to
|
||||||
-> Excepts '[ProcessError] m ()
|
-> Excepts '[ProcessError] m ()
|
||||||
installGHC' path inst = do
|
installGHC' path inst = do
|
||||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||||
lEM $ execLogged "./configure"
|
lEM $ liftIO $ execLogged "./configure"
|
||||||
False
|
False
|
||||||
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
|
["--prefix=" <> toFilePath inst]
|
||||||
[rel|ghc-configure|]
|
[rel|ghc-configure|]
|
||||||
(Just path)
|
(Just path)
|
||||||
Nothing
|
Nothing
|
||||||
lEM $ make ["install"] (Just path)
|
lEM $ liftIO $ make ["install"] (Just path)
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
alpineArgs
|
|
||||||
| ver >= [vver|8.2.2|]
|
|
||||||
, Linux Alpine <- _rPlatform = ["--disable-ld-override"]
|
|
||||||
| otherwise = []
|
|
||||||
|
|
||||||
|
installCabalBin :: ( MonadMask m
|
||||||
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
|
, MonadCatch m
|
||||||
-- following symlinks in @~\/.ghcup\/bin@:
|
, MonadReader Settings m
|
||||||
--
|
, MonadLogger m
|
||||||
-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@
|
, MonadResource m
|
||||||
-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)
|
, MonadIO m
|
||||||
installGHCBin :: ( MonadFail m
|
, MonadFail m
|
||||||
, MonadMask m
|
)
|
||||||
, MonadCatch m
|
=> GHCupDownloads
|
||||||
, MonadReader Settings m
|
-> Version
|
||||||
, MonadLogger m
|
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||||
, MonadResource m
|
-> Excepts
|
||||||
, MonadIO m
|
'[ AlreadyInstalled
|
||||||
)
|
, CopyError
|
||||||
=> GHCupDownloads -- ^ the download info to look up the tarball from
|
, DigestError
|
||||||
-> Version -- ^ the version to install
|
, DistroNotFound
|
||||||
-> PlatformRequest -- ^ the platform to install on
|
, DownloadFailed
|
||||||
-> Excepts
|
, NoCompatibleArch
|
||||||
'[ AlreadyInstalled
|
, NoCompatiblePlatform
|
||||||
, BuildFailed
|
, NoDownload
|
||||||
, DigestError
|
, NotInstalled
|
||||||
, DownloadFailed
|
, UnknownArchive
|
||||||
, NoDownload
|
]
|
||||||
, NotInstalled
|
m
|
||||||
, UnknownArchive
|
()
|
||||||
#if !defined(TAR)
|
installCabalBin bDls ver mpfReq = do
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
installGHCBin bDls ver pfreq = do
|
|
||||||
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
|
|
||||||
installGHCBindist dlinfo ver pfreq
|
|
||||||
|
|
||||||
|
|
||||||
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
|
|
||||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
|
||||||
installCabalBindist :: ( MonadMask m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadReader Settings m
|
|
||||||
, MonadLogger m
|
|
||||||
, MonadResource m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> DownloadInfo
|
|
||||||
-> Version
|
|
||||||
-> PlatformRequest
|
|
||||||
-> Excepts
|
|
||||||
'[ AlreadyInstalled
|
|
||||||
, CopyError
|
|
||||||
, DigestError
|
|
||||||
, DownloadFailed
|
|
||||||
, NoDownload
|
|
||||||
, NotInstalled
|
|
||||||
, UnknownArchive
|
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
|
||||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||||
|
|
||||||
bindir <- liftIO ghcupBinDir
|
bindir <- liftIO ghcupBinDir
|
||||||
@@ -241,7 +183,11 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
|||||||
)
|
)
|
||||||
$ (throwE $ AlreadyInstalled Cabal ver)
|
$ (throwE $ AlreadyInstalled Cabal ver)
|
||||||
|
|
||||||
|
Settings {..} <- lift ask
|
||||||
|
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
|
||||||
|
|
||||||
-- download (or use cached version)
|
-- download (or use cached version)
|
||||||
|
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
|
||||||
dl <- liftE $ downloadCached dlinfo Nothing
|
dl <- liftE $ downloadCached dlinfo Nothing
|
||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
@@ -278,40 +224,6 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
|||||||
Overwrite
|
Overwrite
|
||||||
|
|
||||||
|
|
||||||
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
|
|
||||||
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
|
|
||||||
-- the latest installed version.
|
|
||||||
installCabalBin :: ( MonadMask m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadReader Settings m
|
|
||||||
, MonadLogger m
|
|
||||||
, MonadResource m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> GHCupDownloads
|
|
||||||
-> Version
|
|
||||||
-> PlatformRequest
|
|
||||||
-> Excepts
|
|
||||||
'[ AlreadyInstalled
|
|
||||||
, CopyError
|
|
||||||
, DigestError
|
|
||||||
, DownloadFailed
|
|
||||||
, NoDownload
|
|
||||||
, NotInstalled
|
|
||||||
, UnknownArchive
|
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
installCabalBin bDls ver pfreq = do
|
|
||||||
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
|
|
||||||
installCabalBindist dlinfo ver pfreq
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
---------------------
|
---------------------
|
||||||
--[ Set GHC/cabal ]--
|
--[ Set GHC/cabal ]--
|
||||||
@@ -319,15 +231,15 @@ installCabalBin bDls ver pfreq = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends
|
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
|
||||||
-- on `SetGHC`:
|
-- on `SetGHC`:
|
||||||
--
|
--
|
||||||
-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||||
-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||||
-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||||
--
|
--
|
||||||
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
|
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
||||||
-- for 'SetGHCOnly' constructor.
|
-- for `SetGHCOnly` constructor.
|
||||||
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> SetGHC
|
-> SetGHC
|
||||||
@@ -392,7 +304,7 @@ setGHC ver sghc = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
|
-- | Set the ~/.ghcup/bin/cabal symlink.
|
||||||
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||||
=> Version
|
=> Version
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled] m ()
|
||||||
@@ -432,13 +344,10 @@ setCabal ver = do
|
|||||||
------------------
|
------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Filter data type for 'listVersions'.
|
|
||||||
data ListCriteria = ListInstalled
|
data ListCriteria = ListInstalled
|
||||||
| ListSet
|
| ListSet
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
-- | A list result describes a single tool version
|
|
||||||
-- and various of its properties.
|
|
||||||
data ListResult = ListResult
|
data ListResult = ListResult
|
||||||
{ lTool :: Tool
|
{ lTool :: Tool
|
||||||
, lVer :: Version
|
, lVer :: Version
|
||||||
@@ -453,7 +362,6 @@ data ListResult = ListResult
|
|||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
-- | Extract all available tool versions and their tags.
|
|
||||||
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
|
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
|
||||||
availableToolVersions av tool = view
|
availableToolVersions av tool = view
|
||||||
(at tool % non Map.empty % to (fmap (_viTags)))
|
(at tool % non Map.empty % to (fmap (_viTags)))
|
||||||
@@ -471,25 +379,31 @@ listVersions :: ( MonadCatch m
|
|||||||
=> GHCupDownloads
|
=> GHCupDownloads
|
||||||
-> Maybe Tool
|
-> Maybe Tool
|
||||||
-> Maybe ListCriteria
|
-> Maybe ListCriteria
|
||||||
-> PlatformRequest
|
-> Excepts
|
||||||
-> m [ListResult]
|
'[ NoCompatiblePlatform
|
||||||
listVersions av lt criteria pfreq = do
|
, NoCompatibleArch
|
||||||
|
, DistroNotFound
|
||||||
|
]
|
||||||
|
m
|
||||||
|
[ListResult]
|
||||||
|
listVersions av lt criteria = do
|
||||||
|
pfreq <- platformRequest
|
||||||
case lt of
|
case lt of
|
||||||
Just t -> do
|
Just t -> do
|
||||||
-- get versions from GHCupDownloads
|
-- get versions from GHCupDownloads
|
||||||
let avTools = availableToolVersions av t
|
let avTools = availableToolVersions av t
|
||||||
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
|
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t)
|
||||||
|
|
||||||
case t of
|
case t of
|
||||||
-- append stray GHCs
|
-- append stray GHCs
|
||||||
GHC -> do
|
GHC -> do
|
||||||
slr <- strayGHCs avTools
|
slr <- lift $ strayGHCs avTools
|
||||||
pure $ (sort (slr ++ lr))
|
pure $ (sort (slr ++ lr))
|
||||||
_ -> pure lr
|
_ -> pure lr
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
ghcvers <- listVersions av (Just GHC) criteria pfreq
|
ghcvers <- listVersions av (Just GHC) criteria
|
||||||
cabalvers <- listVersions av (Just Cabal) criteria pfreq
|
cabalvers <- listVersions av (Just Cabal) criteria
|
||||||
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
|
ghcupvers <- listVersions av (Just GHCup) criteria
|
||||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||||
|
|
||||||
where
|
where
|
||||||
@@ -534,8 +448,8 @@ listVersions av lt criteria pfreq = do
|
|||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
-- NOTE: this are not cross ones, because no bindists
|
-- NOTE: this are not cross ones, because no bindists
|
||||||
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
|
toListResult :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult
|
||||||
toListResult t (v, tags) = case t of
|
toListResult pfreq t (v, tags) = case t of
|
||||||
GHC -> do
|
GHC -> do
|
||||||
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
|
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
|
||||||
let tver = mkTVer v
|
let tver = mkTVer v
|
||||||
@@ -582,11 +496,7 @@ listVersions av lt criteria pfreq = do
|
|||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Delete a ghc version and all its symlinks.
|
-- | This function may throw and crash in various ways.
|
||||||
--
|
|
||||||
-- This may leave GHCup without a "set" version.
|
|
||||||
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
|
|
||||||
-- older version).
|
|
||||||
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled] m ()
|
||||||
@@ -625,8 +535,7 @@ rmGHCVer ver = do
|
|||||||
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
|
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
|
||||||
|
|
||||||
|
|
||||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
-- | This function may throw and crash in various ways.
|
||||||
-- after removal (e.g. setting it to an older version).
|
|
||||||
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||||
=> Version
|
=> Version
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled] m ()
|
||||||
@@ -675,8 +584,6 @@ getDebugInfo = do
|
|||||||
---------------
|
---------------
|
||||||
|
|
||||||
|
|
||||||
-- | Compile a GHC from source. This behaves wrt symlinks and installation
|
|
||||||
-- the same as 'installGHCBin'.
|
|
||||||
compileGHC :: ( MonadMask m
|
compileGHC :: ( MonadMask m
|
||||||
, MonadReader Settings m
|
, MonadReader Settings m
|
||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
@@ -692,24 +599,23 @@ compileGHC :: ( MonadMask m
|
|||||||
-> Maybe (Path Abs) -- ^ build config
|
-> Maybe (Path Abs) -- ^ build config
|
||||||
-> Maybe (Path Abs) -- ^ patch directory
|
-> Maybe (Path Abs) -- ^ patch directory
|
||||||
-> [Text] -- ^ additional args to ./configure
|
-> [Text] -- ^ additional args to ./configure
|
||||||
-> PlatformRequest
|
|
||||||
-> Excepts
|
-> Excepts
|
||||||
'[ AlreadyInstalled
|
'[ AlreadyInstalled
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
, DigestError
|
, DigestError
|
||||||
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
, GHCupSetError
|
, GHCupSetError
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoCompatiblePlatform
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NotFoundInPATH
|
, NotFoundInPATH
|
||||||
, PatchFailed
|
, PatchFailed
|
||||||
, UnknownArchive
|
, UnknownArchive
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
|
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
|
||||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
||||||
whenM (liftIO $ ghcInstalled tver)
|
whenM (liftIO $ ghcInstalled tver)
|
||||||
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
|
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
|
||||||
@@ -723,6 +629,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
|
|||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
liftE $ unpackToDir tmpUnpack dl
|
liftE $ unpackToDir tmpUnpack dl
|
||||||
|
(PlatformRequest {..}) <- liftE $ platformRequest
|
||||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||||
|
|
||||||
bghc <- case bstrap of
|
bghc <- case bstrap of
|
||||||
@@ -755,7 +662,7 @@ BUILD_SPHINX_PDF = NO
|
|||||||
HADDOCK_DOCS = NO
|
HADDOCK_DOCS = NO
|
||||||
Stage1Only = YES|]
|
Stage1Only = YES|]
|
||||||
|
|
||||||
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
|
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
|
||||||
=> Either (Path Rel) (Path Abs)
|
=> Either (Path Rel) (Path Abs)
|
||||||
-> Path Abs
|
-> Path Abs
|
||||||
-> Path Abs
|
-> Path Abs
|
||||||
@@ -783,7 +690,7 @@ Stage1Only = YES|]
|
|||||||
Left bver -> do
|
Left bver -> do
|
||||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||||
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
|
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
|
||||||
lEM $ execLogged
|
lEM $ liftIO $ execLogged
|
||||||
"./configure"
|
"./configure"
|
||||||
False
|
False
|
||||||
( ["--prefix=" <> toFilePath ghcdir]
|
( ["--prefix=" <> toFilePath ghcdir]
|
||||||
@@ -797,7 +704,7 @@ Stage1Only = YES|]
|
|||||||
(Just workdir)
|
(Just workdir)
|
||||||
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
lEM $ execLogged
|
lEM $ liftIO $ execLogged
|
||||||
"./configure"
|
"./configure"
|
||||||
False
|
False
|
||||||
( [ "--prefix=" <> toFilePath ghcdir
|
( [ "--prefix=" <> toFilePath ghcdir
|
||||||
@@ -822,11 +729,11 @@ Stage1Only = YES|]
|
|||||||
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
||||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
|
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
|
||||||
(Just workdir)
|
(Just workdir)
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Installing...|]
|
lift $ $(logInfo) [i|Installing...|]
|
||||||
lEM $ make ["install"] (Just workdir)
|
lEM $ liftIO $ make ["install"] (Just workdir)
|
||||||
|
|
||||||
markSrcBuilt ghcdir workdir = do
|
markSrcBuilt ghcdir workdir = do
|
||||||
let dest = (ghcdir </> ghcUpSrcBuiltFile)
|
let dest = (ghcdir </> ghcUpSrcBuiltFile)
|
||||||
@@ -858,8 +765,6 @@ Stage1Only = YES|]
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Compile a cabal from source. This behaves wrt symlinks and installation
|
|
||||||
-- the same as 'installCabalBin'.
|
|
||||||
compileCabal :: ( MonadReader Settings m
|
compileCabal :: ( MonadReader Settings m
|
||||||
, MonadResource m
|
, MonadResource m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
@@ -872,24 +777,23 @@ compileCabal :: ( MonadReader Settings m
|
|||||||
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
||||||
-> Maybe Int
|
-> Maybe Int
|
||||||
-> Maybe (Path Abs)
|
-> Maybe (Path Abs)
|
||||||
-> PlatformRequest
|
|
||||||
-> Excepts
|
-> Excepts
|
||||||
'[ AlreadyInstalled
|
'[ AlreadyInstalled
|
||||||
, BuildFailed
|
, BuildFailed
|
||||||
, CopyError
|
, CopyError
|
||||||
, DigestError
|
, DigestError
|
||||||
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoCompatiblePlatform
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NotInstalled
|
, NotInstalled
|
||||||
, PatchFailed
|
, PatchFailed
|
||||||
, UnknownArchive
|
, UnknownArchive
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
compileCabal dls tver bghc jobs patchdir = do
|
||||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
|
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
|
||||||
|
|
||||||
bindir <- liftIO ghcupBinDir
|
bindir <- liftIO ghcupBinDir
|
||||||
@@ -910,6 +814,7 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
|||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
liftE $ unpackToDir tmpUnpack dl
|
liftE $ unpackToDir tmpUnpack dl
|
||||||
|
(PlatformRequest {..}) <- liftE $ platformRequest
|
||||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||||
|
|
||||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||||
@@ -930,7 +835,7 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
|||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
where
|
where
|
||||||
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
|
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
|
||||||
=> Path Abs
|
=> Path Abs
|
||||||
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
|
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
|
||||||
compile workdir = do
|
compile workdir = do
|
||||||
@@ -963,7 +868,7 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
|||||||
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
|
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
|
||||||
lift $ $(logDebug) [i|Environment: #{newEnv}|]
|
lift $ $(logDebug) [i|Environment: #{newEnv}|]
|
||||||
|
|
||||||
lEM $ execLogged "./bootstrap.sh"
|
lEM $ liftIO $ execLogged "./bootstrap.sh"
|
||||||
False
|
False
|
||||||
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
|
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
|
||||||
[rel|cabal-bootstrap|]
|
[rel|cabal-bootstrap|]
|
||||||
@@ -979,8 +884,6 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
|||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
|
|
||||||
-- if no path is provided.
|
|
||||||
upgradeGHCup :: ( MonadMask m
|
upgradeGHCup :: ( MonadMask m
|
||||||
, MonadReader Settings m
|
, MonadReader Settings m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
@@ -993,20 +896,23 @@ upgradeGHCup :: ( MonadMask m
|
|||||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||||
-> Bool -- ^ whether to force update regardless
|
-> Bool -- ^ whether to force update regardless
|
||||||
-- of currently installed version
|
-- of currently installed version
|
||||||
-> PlatformRequest
|
|
||||||
-> Excepts
|
-> Excepts
|
||||||
'[ CopyError
|
'[ CopyError
|
||||||
, DigestError
|
, DigestError
|
||||||
|
, DistroNotFound
|
||||||
, DownloadFailed
|
, DownloadFailed
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoCompatiblePlatform
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, NoUpdate
|
, NoUpdate
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
Version
|
Version
|
||||||
upgradeGHCup dls mtarget force pfreq = do
|
upgradeGHCup dls mtarget force = do
|
||||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
||||||
let latestVer = fromJust $ getLatest dls GHCup
|
let latestVer = fromJust $ getLatest dls GHCup
|
||||||
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
||||||
|
pfreq <- liftE platformRequest
|
||||||
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
|
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
|
||||||
tmp <- lift withGHCupTmpDir
|
tmp <- lift withGHCupTmpDir
|
||||||
let fn = [rel|ghcup|]
|
let fn = [rel|ghcup|]
|
||||||
@@ -1016,13 +922,20 @@ upgradeGHCup dls mtarget force pfreq = do
|
|||||||
`unionFileModes` ownerExecuteMode
|
`unionFileModes` ownerExecuteMode
|
||||||
`unionFileModes` groupExecuteMode
|
`unionFileModes` groupExecuteMode
|
||||||
`unionFileModes` otherExecuteMode
|
`unionFileModes` otherExecuteMode
|
||||||
binDir <- liftIO $ ghcupBinDir
|
case mtarget of
|
||||||
let fullDest = fromMaybe (binDir </> fn) mtarget
|
Nothing -> do
|
||||||
liftIO $ hideError NoSuchThing $ deleteFile fullDest
|
dest <- liftIO $ ghcupBinDir
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
liftIO $ hideError NoSuchThing $ deleteFile (dest </> fn)
|
||||||
fullDest
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||||
Overwrite
|
(dest </> fn)
|
||||||
liftIO $ setFileMode (toFilePath fullDest) fileMode'
|
Overwrite
|
||||||
|
liftIO $ setFileMode (toFilePath (dest </> fn)) fileMode'
|
||||||
|
Just fullDest -> do
|
||||||
|
liftIO $ hideError NoSuchThing $ deleteFile fullDest
|
||||||
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||||
|
fullDest
|
||||||
|
Overwrite
|
||||||
|
liftIO $ setFileMode (toFilePath fullDest) fileMode'
|
||||||
pure latestVer
|
pure latestVer
|
||||||
|
|
||||||
|
|
||||||
@@ -1032,7 +945,7 @@ upgradeGHCup dls mtarget force pfreq = do
|
|||||||
-------------
|
-------------
|
||||||
|
|
||||||
|
|
||||||
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
|
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
|
||||||
-- both installing from source and bindist.
|
-- both installing from source and bindist.
|
||||||
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
|
|||||||
2007
lib/GHCup/Data/GHCupDownloads.hs
Normal file
2007
lib/GHCup/Data/GHCupDownloads.hs
Normal file
File diff suppressed because it is too large
Load Diff
11
lib/GHCup/Data/GHCupInfo.hs
Normal file
11
lib/GHCup/Data/GHCupInfo.hs
Normal file
@@ -0,0 +1,11 @@
|
|||||||
|
module GHCup.Data.GHCupInfo where
|
||||||
|
|
||||||
|
import GHCup.Data.GHCupDownloads
|
||||||
|
import GHCup.Data.ToolRequirements
|
||||||
|
import GHCup.Types
|
||||||
|
|
||||||
|
|
||||||
|
ghcupInfo :: GHCupInfo
|
||||||
|
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
|
||||||
|
, _ghcupDownloads = ghcupDownloads
|
||||||
|
}
|
||||||
147
lib/GHCup/Data/ToolRequirements.hs
Normal file
147
lib/GHCup/Data/ToolRequirements.hs
Normal file
@@ -0,0 +1,147 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
|
module GHCup.Data.ToolRequirements where
|
||||||
|
|
||||||
|
import GHCup.Types
|
||||||
|
import GHCup.Utils.String.QQ
|
||||||
|
import GHCup.Utils.Version.QQ
|
||||||
|
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | Currently 'GHC' is used for both GHC and cabal to simplify
|
||||||
|
-- this, until we need actual separation.
|
||||||
|
toolRequirements :: ToolRequirements
|
||||||
|
toolRequirements = M.fromList
|
||||||
|
[ ( GHC
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, M.fromList
|
||||||
|
[ ( Linux UnknownLinux
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[]
|
||||||
|
[s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( Linux Alpine
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[ "curl"
|
||||||
|
, "gcc"
|
||||||
|
, "g++"
|
||||||
|
, "gmp-dev"
|
||||||
|
, "ncurses-dev"
|
||||||
|
, "libffi-dev"
|
||||||
|
, "make"
|
||||||
|
, "xz"
|
||||||
|
, "tar"
|
||||||
|
, "perl"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( Linux Ubuntu
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[ "build-essential"
|
||||||
|
, "curl"
|
||||||
|
, "libffi-dev"
|
||||||
|
, "libffi6"
|
||||||
|
, "libgmp-dev"
|
||||||
|
, "libgmp10"
|
||||||
|
, "libncurses-dev"
|
||||||
|
, "libncurses5"
|
||||||
|
, "libtinfo5"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( Linux Debian
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[ "build-essential"
|
||||||
|
, "curl"
|
||||||
|
, "libffi-dev"
|
||||||
|
, "libffi6"
|
||||||
|
, "libgmp-dev"
|
||||||
|
, "libgmp10"
|
||||||
|
, "libncurses-dev"
|
||||||
|
, "libncurses5"
|
||||||
|
, "libtinfo5"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( Linux CentOS
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[ "gcc"
|
||||||
|
, "gcc-c++"
|
||||||
|
, "gmp"
|
||||||
|
, "gmp-devel"
|
||||||
|
, "make"
|
||||||
|
, "ncurses"
|
||||||
|
, "ncurses-compat-libs"
|
||||||
|
, "xz"
|
||||||
|
, "perl"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
),
|
||||||
|
( Just [vers|7|]
|
||||||
|
, Requirements
|
||||||
|
[ "gcc"
|
||||||
|
, "gcc-c++"
|
||||||
|
, "gmp"
|
||||||
|
, "gmp-devel"
|
||||||
|
, "make"
|
||||||
|
, "ncurses"
|
||||||
|
, "xz"
|
||||||
|
, "perl"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( Darwin
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[]
|
||||||
|
"On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( FreeBSD
|
||||||
|
, M.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, Requirements
|
||||||
|
[ "curl"
|
||||||
|
, "gcc"
|
||||||
|
, "gmp"
|
||||||
|
, "gmake"
|
||||||
|
, "ncurses"
|
||||||
|
, "perl5"
|
||||||
|
, "libffi"
|
||||||
|
, "libiconv"
|
||||||
|
]
|
||||||
|
""
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
@@ -9,23 +9,6 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Download
|
|
||||||
Description : Downloading
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
Module for handling all download related functions.
|
|
||||||
|
|
||||||
Generally we support downloading via:
|
|
||||||
|
|
||||||
- curl (default)
|
|
||||||
- wget
|
|
||||||
- internal downloader (only when compiled)
|
|
||||||
-}
|
|
||||||
module GHCup.Download where
|
module GHCup.Download where
|
||||||
|
|
||||||
#if defined(INTERNAL_DOWNLOADER)
|
#if defined(INTERNAL_DOWNLOADER)
|
||||||
@@ -52,7 +35,6 @@ import Control.Monad.Reader
|
|||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
hiding ( throwM )
|
hiding ( throwM )
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Bifunctor
|
|
||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
#if defined(INTERNAL_DOWNLOADER)
|
#if defined(INTERNAL_DOWNLOADER)
|
||||||
import Data.CaseInsensitive ( CI )
|
import Data.CaseInsensitive ( CI )
|
||||||
@@ -68,7 +50,7 @@ import Data.Versions
|
|||||||
import Data.Word8
|
import Data.Word8
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO as HIO hiding ( hideError )
|
import HPath.IO as HIO
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import Prelude hiding ( abs
|
import Prelude hiding ( abs
|
||||||
@@ -89,7 +71,6 @@ import qualified Data.Map.Strict as M
|
|||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
#endif
|
#endif
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
import qualified Data.Yaml as Y
|
|
||||||
import qualified System.Posix.Files.ByteString as PF
|
import qualified System.Posix.Files.ByteString as PF
|
||||||
import qualified System.Posix.RawFilePath.Directory
|
import qualified System.Posix.RawFilePath.Directory
|
||||||
as RD
|
as RD
|
||||||
@@ -105,7 +86,7 @@ import qualified System.Posix.RawFilePath.Directory
|
|||||||
|
|
||||||
|
|
||||||
-- | Like 'getDownloads', but tries to fall back to
|
-- | Like 'getDownloads', but tries to fall back to
|
||||||
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
|
-- cached ~/.ghcup/cache/ghcup-<format-ver>.json
|
||||||
getDownloadsF :: ( FromJSONKey Tool
|
getDownloadsF :: ( FromJSONKey Tool
|
||||||
, FromJSONKey Version
|
, FromJSONKey Version
|
||||||
, FromJSON VersionInfo
|
, FromJSON VersionInfo
|
||||||
@@ -137,13 +118,13 @@ getDownloadsF urlSource = do
|
|||||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||||
let path = view pathL' ghcupURL
|
let path = view pathL' ghcupURL
|
||||||
cacheDir <- liftIO $ ghcupCacheDir
|
cacheDir <- liftIO $ ghcupCacheDir
|
||||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||||
bs <-
|
bs <-
|
||||||
handleIO' NoSuchThing
|
handleIO' NoSuchThing
|
||||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
(\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
|
||||||
$ liftIO
|
$ liftIO
|
||||||
$ readFile yaml_file
|
$ readFile json_file
|
||||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
lE' JSONDecodeError $ eitherDecode' bs
|
||||||
|
|
||||||
|
|
||||||
-- | Downloads the download information! But only if we need to ;P
|
-- | Downloads the download information! But only if we need to ;P
|
||||||
@@ -164,10 +145,10 @@ getDownloads urlSource = do
|
|||||||
case urlSource of
|
case urlSource of
|
||||||
GHCupURL -> do
|
GHCupURL -> do
|
||||||
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
|
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
|
||||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
lE' JSONDecodeError $ eitherDecode' bs
|
||||||
(OwnSource url) -> do
|
(OwnSource url) -> do
|
||||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
lE' JSONDecodeError $ eitherDecode' bs
|
||||||
(OwnSpec av) -> pure $ av
|
(OwnSpec av) -> pure $ av
|
||||||
|
|
||||||
where
|
where
|
||||||
@@ -289,10 +270,7 @@ getDownloadInfo :: Tool
|
|||||||
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||||
(Left NoDownload)
|
(Left NoDownload)
|
||||||
Right
|
Right
|
||||||
(case p of
|
(with_distro <|> without_distro_ver <|> without_distro)
|
||||||
-- non-musl won't work on alpine
|
|
||||||
Linux Alpine -> with_distro <|> without_distro_ver
|
|
||||||
_ -> with_distro <|> without_distro_ver <|> without_distro)
|
|
||||||
|
|
||||||
where
|
where
|
||||||
with_distro = distro_preview id id
|
with_distro = distro_preview id id
|
||||||
|
|||||||
@@ -3,15 +3,6 @@
|
|||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Errors
|
|
||||||
Description : GHCup error types
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Errors where
|
module GHCup.Errors where
|
||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
|||||||
@@ -6,21 +6,13 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Plaform
|
|
||||||
Description : Retrieving platform information
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Platform where
|
module GHCup.Platform where
|
||||||
|
|
||||||
|
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Types.JSON ( )
|
import GHCup.Types.JSON ( )
|
||||||
|
import GHCup.Utils.Bash
|
||||||
import GHCup.Utils.File
|
import GHCup.Utils.File
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
@@ -44,7 +36,6 @@ import Prelude hiding ( abs
|
|||||||
, writeFile
|
, writeFile
|
||||||
)
|
)
|
||||||
import System.Info
|
import System.Info
|
||||||
import System.OsRelease
|
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
@@ -57,7 +48,10 @@ import qualified Data.Text as T
|
|||||||
-- | Get the full platform request, consisting of architecture, distro, ...
|
-- | Get the full platform request, consisting of architecture, distro, ...
|
||||||
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
|
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||||
=> Excepts
|
=> Excepts
|
||||||
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
|
'[ NoCompatiblePlatform
|
||||||
|
, NoCompatibleArch
|
||||||
|
, DistroNotFound
|
||||||
|
]
|
||||||
m
|
m
|
||||||
PlatformRequest
|
PlatformRequest
|
||||||
platformRequest = do
|
platformRequest = do
|
||||||
@@ -68,21 +62,15 @@ platformRequest = do
|
|||||||
|
|
||||||
getArchitecture :: Either NoCompatibleArch Architecture
|
getArchitecture :: Either NoCompatibleArch Architecture
|
||||||
getArchitecture = case arch of
|
getArchitecture = case arch of
|
||||||
"x86_64" -> Right A_64
|
"x86_64" -> Right A_64
|
||||||
"i386" -> Right A_32
|
"i386" -> Right A_32
|
||||||
"powerpc" -> Right A_PowerPC
|
what -> Left (NoCompatibleArch what)
|
||||||
"powerpc64" -> Right A_PowerPC64
|
|
||||||
"powerpc64le" -> Right A_PowerPC64
|
|
||||||
"sparc" -> Right A_Sparc
|
|
||||||
"sparc64" -> Right A_Sparc64
|
|
||||||
"arm" -> Right A_ARM
|
|
||||||
"aarch64" -> Right A_ARM64
|
|
||||||
what -> Left (NoCompatibleArch what)
|
|
||||||
|
|
||||||
|
|
||||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||||
=> Excepts
|
=> Excepts
|
||||||
'[NoCompatiblePlatform, DistroNotFound]
|
'[NoCompatiblePlatform , DistroNotFound]
|
||||||
m
|
m
|
||||||
PlatformResult
|
PlatformResult
|
||||||
getPlatform = do
|
getPlatform = do
|
||||||
@@ -94,7 +82,6 @@ getPlatform = do
|
|||||||
ver <-
|
ver <-
|
||||||
( either (const Nothing) Just
|
( either (const Nothing) Just
|
||||||
. versioning
|
. versioning
|
||||||
-- TODO: maybe do this somewhere else
|
|
||||||
. getMajorVersion
|
. getMajorVersion
|
||||||
. decUTF8Safe
|
. decUTF8Safe
|
||||||
)
|
)
|
||||||
@@ -124,6 +111,7 @@ getLinuxDistro = do
|
|||||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||||
[ try_os_release
|
[ try_os_release
|
||||||
, try_lsb_release_cmd
|
, try_lsb_release_cmd
|
||||||
|
, try_lsb_release
|
||||||
, try_redhat_release
|
, try_redhat_release
|
||||||
, try_debian_version
|
, try_debian_version
|
||||||
]
|
]
|
||||||
@@ -148,6 +136,10 @@ getLinuxDistro = do
|
|||||||
where
|
where
|
||||||
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
|
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
|
||||||
|
|
||||||
|
os_release :: Path Abs
|
||||||
|
os_release = [abs|/etc/os-release|]
|
||||||
|
lsb_release :: Path Abs
|
||||||
|
lsb_release = [abs|/etc/lsb-release|]
|
||||||
lsb_release_cmd :: Path Rel
|
lsb_release_cmd :: Path Rel
|
||||||
lsb_release_cmd = [rel|lsb-release|]
|
lsb_release_cmd = [rel|lsb-release|]
|
||||||
redhat_release :: Path Abs
|
redhat_release :: Path Abs
|
||||||
@@ -157,9 +149,9 @@ getLinuxDistro = do
|
|||||||
|
|
||||||
try_os_release :: IO (Text, Maybe Text)
|
try_os_release :: IO (Text, Maybe Text)
|
||||||
try_os_release = do
|
try_os_release = do
|
||||||
Just (OsRelease { name = name, version_id = version_id }) <-
|
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||||
fmap osRelease <$> parseOsRelease
|
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||||
pure (T.pack name, fmap T.pack version_id)
|
pure (T.pack name, fmap T.pack ver)
|
||||||
|
|
||||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||||
try_lsb_release_cmd = do
|
try_lsb_release_cmd = do
|
||||||
@@ -168,6 +160,12 @@ getLinuxDistro = do
|
|||||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
|
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
|
||||||
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
|
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
|
||||||
|
|
||||||
|
try_lsb_release :: IO (Text, Maybe Text)
|
||||||
|
try_lsb_release = do
|
||||||
|
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
||||||
|
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
||||||
|
pure (T.pack name, fmap T.pack ver)
|
||||||
|
|
||||||
try_redhat_release :: IO (Text, Maybe Text)
|
try_redhat_release :: IO (Text, Maybe Text)
|
||||||
try_redhat_release = do
|
try_redhat_release = do
|
||||||
t <- fmap decUTF8Safe' $ readFile redhat_release
|
t <- fmap decUTF8Safe' $ readFile redhat_release
|
||||||
|
|||||||
@@ -1,14 +1,5 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Requirements
|
|
||||||
Description : Requirements utilities
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Requirements where
|
module GHCup.Requirements where
|
||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
|||||||
@@ -2,15 +2,6 @@
|
|||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Types
|
|
||||||
Description : GHCup types
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Types where
|
module GHCup.Types where
|
||||||
|
|
||||||
import Data.Map.Strict ( Map )
|
import Data.Map.Strict ( Map )
|
||||||
@@ -99,12 +90,6 @@ data Tag = Latest
|
|||||||
|
|
||||||
data Architecture = A_64
|
data Architecture = A_64
|
||||||
| A_32
|
| A_32
|
||||||
| A_PowerPC
|
|
||||||
| A_PowerPC64
|
|
||||||
| A_Sparc
|
|
||||||
| A_Sparc64
|
|
||||||
| A_ARM
|
|
||||||
| A_ARM64
|
|
||||||
deriving (Eq, GHC.Generic, Ord, Show)
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
@@ -161,7 +146,6 @@ data Settings = Settings
|
|||||||
, noVerify :: Bool
|
, noVerify :: Bool
|
||||||
, keepDirs :: KeepDirs
|
, keepDirs :: KeepDirs
|
||||||
, downloader :: Downloader
|
, downloader :: Downloader
|
||||||
, verbose :: Bool
|
|
||||||
}
|
}
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
|||||||
@@ -10,15 +10,6 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Types.JSON
|
|
||||||
Description : GHCup JSON types/instances
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Types.JSON where
|
module GHCup.Types.JSON where
|
||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
|||||||
@@ -1,14 +1,5 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Types.Optics
|
|
||||||
Description : GHCup optics
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Types.Optics where
|
module GHCup.Types.Optics where
|
||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
|||||||
@@ -6,18 +6,7 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils
|
|
||||||
Description : GHCup domain specific utilities
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
This module contains GHCup helpers specific to
|
|
||||||
installation and introspection of files/versions etc.
|
|
||||||
-}
|
|
||||||
module GHCup.Utils
|
module GHCup.Utils
|
||||||
( module GHCup.Utils.Dirs
|
( module GHCup.Utils.Dirs
|
||||||
, module GHCup.Utils
|
, module GHCup.Utils
|
||||||
@@ -35,9 +24,6 @@ import GHCup.Utils.MegaParsec
|
|||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
|
|
||||||
#if !defined(TAR)
|
|
||||||
import Codec.Archive
|
|
||||||
#endif
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
@@ -56,7 +42,7 @@ import Data.Versions
|
|||||||
import Data.Word8
|
import Data.Word8
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO hiding ( hideError )
|
import HPath.IO
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import Prelude hiding ( abs
|
import Prelude hiding ( abs
|
||||||
@@ -72,18 +58,12 @@ import System.Posix.Files.ByteString ( readSymbolicLink )
|
|||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
|
|
||||||
#if defined(TAR)
|
|
||||||
import qualified Codec.Archive.Tar as Tar
|
import qualified Codec.Archive.Tar as Tar
|
||||||
#endif
|
|
||||||
import qualified Codec.Compression.BZip as BZip
|
import qualified Codec.Compression.BZip as BZip
|
||||||
import qualified Codec.Compression.GZip as GZip
|
import qualified Codec.Compression.GZip as GZip
|
||||||
import qualified Codec.Compression.Lzma as Lzma
|
import qualified Codec.Compression.Lzma as Lzma
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
#if !defined(TAR)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
#endif
|
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
import qualified Text.Megaparsec as MP
|
import qualified Text.Megaparsec as MP
|
||||||
|
|
||||||
@@ -104,7 +84,7 @@ ghcLinkDestination tool ver =
|
|||||||
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
|
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
|
||||||
|
|
||||||
|
|
||||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
-- e.g. ghc-8.6.5
|
||||||
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
|
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
|
||||||
rmMinorSymlinks GHCTargetVersion {..} = do
|
rmMinorSymlinks GHCTargetVersion {..} = do
|
||||||
bindir <- liftIO $ ghcupBinDir
|
bindir <- liftIO $ ghcupBinDir
|
||||||
@@ -123,7 +103,7 @@ rmMinorSymlinks GHCTargetVersion {..} = do
|
|||||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||||
|
|
||||||
|
|
||||||
-- | Removes the set ghc version for the given target, if any.
|
-- Removes the set ghc version for the given target, if any.
|
||||||
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||||
=> Maybe Text -- ^ target
|
=> Maybe Text -- ^ target
|
||||||
-> Excepts '[NotInstalled] m ()
|
-> Excepts '[NotInstalled] m ()
|
||||||
@@ -142,7 +122,7 @@ rmPlain target = do
|
|||||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||||
|
|
||||||
|
|
||||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
-- e.g. ghc-8.6
|
||||||
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
|
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> m ()
|
-> m ()
|
||||||
@@ -173,21 +153,18 @@ rmMajorSymlinks GHCTargetVersion {..} = do
|
|||||||
-----------------------------------
|
-----------------------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Whethe the given GHC versin is installed.
|
|
||||||
ghcInstalled :: GHCTargetVersion -> IO Bool
|
ghcInstalled :: GHCTargetVersion -> IO Bool
|
||||||
ghcInstalled ver = do
|
ghcInstalled ver = do
|
||||||
ghcdir <- ghcupGHCDir ver
|
ghcdir <- ghcupGHCDir ver
|
||||||
doesDirectoryExist ghcdir
|
doesDirectoryExist ghcdir
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC version is installed from source.
|
|
||||||
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
|
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
|
||||||
ghcSrcInstalled ver = do
|
ghcSrcInstalled ver = do
|
||||||
ghcdir <- ghcupGHCDir ver
|
ghcdir <- ghcupGHCDir ver
|
||||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC version is set as the current.
|
|
||||||
ghcSet :: (MonadThrow m, MonadIO m)
|
ghcSet :: (MonadThrow m, MonadIO m)
|
||||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
=> Maybe Text -- ^ the target of the GHC version, if any
|
||||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||||
@@ -233,7 +210,6 @@ getInstalledGHCs = do
|
|||||||
Left _ -> pure $ Left f
|
Left _ -> pure $ Left f
|
||||||
|
|
||||||
|
|
||||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
|
||||||
getInstalledCabals :: IO [Either (Path Rel) Version]
|
getInstalledCabals :: IO [Either (Path Rel) Version]
|
||||||
getInstalledCabals = do
|
getInstalledCabals = do
|
||||||
bindir <- liftIO $ ghcupBinDir
|
bindir <- liftIO $ ghcupBinDir
|
||||||
@@ -248,14 +224,12 @@ getInstalledCabals = do
|
|||||||
pure $ maybe vs (\x -> Right x:vs) cs
|
pure $ maybe vs (\x -> Right x:vs) cs
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given cabal version is installed.
|
|
||||||
cabalInstalled :: Version -> IO Bool
|
cabalInstalled :: Version -> IO Bool
|
||||||
cabalInstalled ver = do
|
cabalInstalled ver = do
|
||||||
vers <- fmap rights $ getInstalledCabals
|
vers <- fmap rights $ getInstalledCabals
|
||||||
pure $ elem ver $ vers
|
pure $ elem ver $ vers
|
||||||
|
|
||||||
|
|
||||||
-- Return the currently set cabal version, if any.
|
|
||||||
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||||
cabalSet = do
|
cabalSet = do
|
||||||
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
|
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
|
||||||
@@ -274,13 +248,11 @@ cabalSet = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------
|
-----------------------------------------
|
||||||
--[ Major version introspection (X.Y) ]--
|
--[ Major version introspection (X.Y) ]--
|
||||||
-----------------------------------------
|
-----------------------------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Extract (major, minor) from any version.
|
|
||||||
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
|
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
|
||||||
getMajorMinorV Version {..} = case _vChunks of
|
getMajorMinorV Version {..} = case _vChunks of
|
||||||
([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y)
|
([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y)
|
||||||
@@ -338,43 +310,25 @@ getLatestGHCFor major' minor' dls = do
|
|||||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||||
=> Path Abs -- ^ destination dir
|
=> Path Abs -- ^ destination dir
|
||||||
-> Path Abs -- ^ archive path
|
-> Path Abs -- ^ archive path
|
||||||
-> Excepts '[UnknownArchive
|
-> Excepts '[UnknownArchive] m ()
|
||||||
#if !defined(TAR)
|
|
||||||
, ArchiveResult
|
|
||||||
#endif
|
|
||||||
] m ()
|
|
||||||
unpackToDir dest av = do
|
unpackToDir dest av = do
|
||||||
fp <- (decUTF8Safe . toFilePath) <$> basename av
|
fp <- (decUTF8Safe . toFilePath) <$> basename av
|
||||||
let dfp = decUTF8Safe . toFilePath $ dest
|
let dfp = decUTF8Safe . toFilePath $ dest
|
||||||
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
|
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
|
||||||
fn <- toFilePath <$> basename av
|
fn <- toFilePath <$> basename av
|
||||||
|
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||||
#if defined(TAR)
|
|
||||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
|
|
||||||
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
|
|
||||||
#else
|
|
||||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
|
||||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if defined(TAR)
|
|
||||||
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
|
|
||||||
#else
|
|
||||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
|
||||||
#endif
|
|
||||||
rf = liftIO . readFile
|
|
||||||
|
|
||||||
-- extract, depending on file extension
|
-- extract, depending on file extension
|
||||||
if
|
if
|
||||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
|
||||||
(untar . GZip.decompress =<< rf av)
|
(untar . GZip.decompress =<< readFile av)
|
||||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||||
filecontents <- liftE $ rf av
|
filecontents <- liftIO $ readFile av
|
||||||
let decompressed = Lzma.decompress filecontents
|
let decompressed = Lzma.decompress filecontents
|
||||||
liftE $ untar decompressed
|
liftIO $ untar decompressed
|
||||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
|
||||||
liftE (untar . BZip.decompress =<< rf av)
|
(untar . BZip.decompress =<< readFile av)
|
||||||
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
|
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||||
| otherwise -> throwE $ UnknownArchive fn
|
| otherwise -> throwE $ UnknownArchive fn
|
||||||
|
|
||||||
|
|
||||||
@@ -434,12 +388,11 @@ urlBaseName :: MonadThrow m
|
|||||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||||
|
|
||||||
|
|
||||||
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
|
-- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
|
||||||
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
|
-- while ignoring *-<ver> symlinks and accounting for cross triple prefix.
|
||||||
--
|
--
|
||||||
-- Returns unversioned relative files, e.g.:
|
-- Returns unversioned relative files, e.g.:
|
||||||
--
|
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
|
||||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
|
||||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> Excepts '[NotInstalled] m [Path Rel]
|
-> Excepts '[NotInstalled] m [Path Rel]
|
||||||
@@ -464,42 +417,26 @@ ghcToolFiles ver = do
|
|||||||
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
|
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
|
||||||
)
|
)
|
||||||
|
|
||||||
let ghcbinPath = bindir </> ghcbin
|
(Just symver) <-
|
||||||
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
|
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
|
||||||
onlyUnversioned <- if ghcIsHadrian
|
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> ghcbin))
|
||||||
then pure id
|
when (B.null symver)
|
||||||
else do
|
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
||||||
(Just symver) <-
|
|
||||||
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
|
|
||||||
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath)
|
|
||||||
when (B.null symver)
|
|
||||||
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
|
||||||
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
|
|
||||||
|
|
||||||
pure $ onlyUnversioned files
|
pure . filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) $ files
|
||||||
where
|
|
||||||
-- GHC is moving some builds to Hadrian for bindists,
|
|
||||||
-- which doesn't create versioned binaries.
|
|
||||||
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
|
|
||||||
isHadrian :: Path Abs -- ^ ghcbin path
|
|
||||||
-> IO Bool
|
|
||||||
isHadrian = fmap (/= SymbolicLink) . getFileType
|
|
||||||
|
|
||||||
|
|
||||||
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
|
||||||
-- this GHC was built from source. It contains the build config.
|
-- this GHC was built from source. It contains the build config.
|
||||||
ghcUpSrcBuiltFile :: Path Rel
|
ghcUpSrcBuiltFile :: Path Rel
|
||||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||||
|
|
||||||
|
|
||||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||||
make :: (MonadThrow m, MonadIO m, MonadReader Settings m)
|
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
|
||||||
=> [ByteString]
|
|
||||||
-> Maybe (Path Abs)
|
|
||||||
-> m (Either ProcessError ())
|
|
||||||
make args workdir = do
|
make args workdir = do
|
||||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
|
||||||
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
|
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
|
||||||
let mymake = if has_gmake then "gmake" else "make"
|
let mymake = if has_gmake then "gmake" else "make"
|
||||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
||||||
|
|
||||||
@@ -524,7 +461,6 @@ applyPatches pdir ddir = do
|
|||||||
!? PatchFailed
|
!? PatchFailed
|
||||||
|
|
||||||
|
|
||||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
|
||||||
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
||||||
darwinNotarization Darwin path = exec
|
darwinNotarization Darwin path = exec
|
||||||
"xattr"
|
"xattr"
|
||||||
|
|||||||
69
lib/GHCup/Utils/Bash.hs
Normal file
69
lib/GHCup/Utils/Bash.hs
Normal file
@@ -0,0 +1,69 @@
|
|||||||
|
module GHCup.Utils.Bash
|
||||||
|
( findAssignment
|
||||||
|
, equalsAssignmentWith
|
||||||
|
, getRValue
|
||||||
|
, getAssignmentValueFor
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Data.ByteString.UTF8 ( toString )
|
||||||
|
import Data.List
|
||||||
|
import Data.Maybe
|
||||||
|
import HPath
|
||||||
|
import HPath.IO
|
||||||
|
import Language.Bash.Parse
|
||||||
|
import Language.Bash.Syntax
|
||||||
|
import Language.Bash.Word
|
||||||
|
import Prelude hiding ( readFile )
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||||
|
|
||||||
|
|
||||||
|
extractAssignments :: List -> [Assign]
|
||||||
|
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||||
|
where
|
||||||
|
getCommands :: [Statement] -> [Command]
|
||||||
|
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||||
|
where
|
||||||
|
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||||
|
findPipes _ = Nothing
|
||||||
|
|
||||||
|
getAssign :: Command -> [Assign]
|
||||||
|
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||||
|
getAssign _ = []
|
||||||
|
|
||||||
|
|
||||||
|
-- | Find an assignment matching the predicate in the given file.
|
||||||
|
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||||
|
findAssignment p predicate = do
|
||||||
|
fileContents <- readFile p
|
||||||
|
-- TODO: this should accept bytestring:
|
||||||
|
-- https://github.com/knrafto/language-bash/issues/37
|
||||||
|
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||||
|
Left e -> fail $ show e
|
||||||
|
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Check that the assignment is of the form Foo= ignoring the
|
||||||
|
-- right hand-side.
|
||||||
|
equalsAssignmentWith :: String -> Assign -> Bool
|
||||||
|
equalsAssignmentWith n ass = case ass of
|
||||||
|
(Assign (Parameter name' Nothing) Equals _) -> n == name'
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
|
||||||
|
-- | This pretty-prints the right hand of an Equals assignment, removing
|
||||||
|
-- quotations. No evaluation is performed.
|
||||||
|
getRValue :: Assign -> Maybe String
|
||||||
|
getRValue ass = case ass of
|
||||||
|
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
-- | Given a bash assignment such as Foo="Bar" in the given file,
|
||||||
|
-- will return "Bar" (without quotations).
|
||||||
|
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
|
||||||
|
getAssignmentValueFor p n = do
|
||||||
|
mass <- findAssignment p (equalsAssignmentWith n)
|
||||||
|
pure (mass >>= getRValue)
|
||||||
@@ -2,15 +2,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.Dirs
|
|
||||||
Description : Definition of GHCup directories
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.Dirs where
|
module GHCup.Utils.Dirs where
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -1,48 +1,37 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.File
|
|
||||||
Description : File and unix APIs
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
This module handles file and executable handling.
|
|
||||||
Some of these functions use sophisticated logging.
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.File where
|
module GHCup.Utils.File where
|
||||||
|
|
||||||
import GHCup.Utils.Dirs
|
import GHCup.Utils.Dirs
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Types
|
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Control.Exception ( evaluate )
|
import Control.Exception ( evaluate )
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
|
||||||
import Control.Monad.Trans.State.Strict
|
|
||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
|
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||||
|
import Data.Char
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Sequence ( Seq, (|>) )
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import Data.Word8
|
import GHC.Foreign ( peekCStringLen )
|
||||||
|
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO hiding ( hideError )
|
import HPath.IO
|
||||||
import Optics hiding ((<|), (|>))
|
import Optics
|
||||||
|
import Streamly
|
||||||
|
import Streamly.External.ByteString
|
||||||
|
import Streamly.External.ByteString.Lazy
|
||||||
import System.Console.Pretty
|
import System.Console.Pretty
|
||||||
import System.Console.Regions
|
import System.Console.Regions
|
||||||
|
import System.IO
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.Posix.Directory.ByteString
|
import System.Posix.Directory.ByteString
|
||||||
import System.Posix.FD as FD
|
import System.Posix.FD as FD
|
||||||
@@ -56,20 +45,31 @@ import Text.Regex.Posix
|
|||||||
|
|
||||||
|
|
||||||
import qualified Control.Exception as EX
|
import qualified Control.Exception as EX
|
||||||
import qualified Data.Sequence as Sq
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
import qualified System.Posix.Process.ByteString
|
import qualified System.Posix.Process.ByteString
|
||||||
as SPPB
|
as SPPB
|
||||||
import Streamly.External.Posix.DirStream
|
import Streamly.External.Posix.DirStream
|
||||||
|
import qualified Streamly.Internal.Memory.ArrayStream
|
||||||
|
as AS
|
||||||
|
import qualified Streamly.FileSystem.Handle as FH
|
||||||
|
import qualified Streamly.Internal.Data.Unfold as SU
|
||||||
import qualified Streamly.Prelude as S
|
import qualified Streamly.Prelude as S
|
||||||
import qualified Text.Megaparsec as MP
|
import qualified Text.Megaparsec as MP
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||||
as SPIB
|
as SPIB
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | Bool signals whether the regions should be cleaned.
|
||||||
|
data StopThread = StopThread Bool
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
instance Exception StopThread
|
||||||
|
|
||||||
|
|
||||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||||
| PTerminated ByteString [ByteString]
|
| PTerminated ByteString [ByteString]
|
||||||
| PStopped ByteString [ByteString]
|
| PStopped ByteString [ByteString]
|
||||||
@@ -87,6 +87,25 @@ data CapturedProcess = CapturedProcess
|
|||||||
makeLenses ''CapturedProcess
|
makeLenses ''CapturedProcess
|
||||||
|
|
||||||
|
|
||||||
|
readFd :: Fd -> IO L.ByteString
|
||||||
|
readFd fd = do
|
||||||
|
handle' <- fdToHandle fd
|
||||||
|
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
|
||||||
|
|
||||||
|
|
||||||
|
-- | Read the lines of a file into a stream. The stream holds
|
||||||
|
-- a file handle as a resource and will close it once the stream
|
||||||
|
-- terminates (either through exception or because it's drained).
|
||||||
|
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||||
|
readFileLines p = do
|
||||||
|
stream <- readFileStream p
|
||||||
|
pure
|
||||||
|
. (fmap fromArray)
|
||||||
|
. AS.splitOn (fromIntegral $ ord '\n')
|
||||||
|
. (fmap toArray)
|
||||||
|
$ stream
|
||||||
|
|
||||||
|
|
||||||
-- | Find the given executable by searching all *absolute* PATH components.
|
-- | Find the given executable by searching all *absolute* PATH components.
|
||||||
-- Relative paths in PATH are ignored.
|
-- Relative paths in PATH are ignored.
|
||||||
--
|
--
|
||||||
@@ -114,156 +133,110 @@ executeOut path args chdir = captureOutStreams $ do
|
|||||||
SPPB.executeFile (toFilePath path) True args Nothing
|
SPPB.executeFile (toFilePath path) True args Nothing
|
||||||
|
|
||||||
|
|
||||||
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
execLogged :: ByteString -- ^ thing to execute
|
||||||
=> ByteString -- ^ thing to execute
|
|
||||||
-> Bool -- ^ whether to search PATH for the thing
|
-> Bool -- ^ whether to search PATH for the thing
|
||||||
-> [ByteString] -- ^ args for the thing
|
-> [ByteString] -- ^ args for the thing
|
||||||
-> Path Rel -- ^ log filename
|
-> Path Rel -- ^ log filename
|
||||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||||
-> m (Either ProcessError ())
|
-> IO (Either ProcessError ())
|
||||||
execLogged exe spath args lfile chdir env = do
|
execLogged exe spath args lfile chdir env = do
|
||||||
Settings {..} <- ask
|
ldir <- ghcupLogsDir
|
||||||
ldir <- liftIO ghcupLogsDir
|
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||||
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
|
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
|
||||||
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
|
|
||||||
closeFd
|
|
||||||
(action verbose)
|
|
||||||
where
|
where
|
||||||
action verbose fd = do
|
action fd = do
|
||||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||||
-- start the thread that logs to stdout
|
-- start the thread that logs to stdout in a region
|
||||||
pState <- newEmptyMVar
|
done <- newEmptyMVar
|
||||||
done <- newEmptyMVar
|
tid <-
|
||||||
void
|
forkIO
|
||||||
$ forkIO
|
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||||
$ flip EX.finally (putMVar done ())
|
$ flip finally (putMVar done ())
|
||||||
$ (if verbose
|
$ printToRegion fd stdoutRead 6
|
||||||
then tee fd stdoutRead
|
|
||||||
else printToRegion fd stdoutRead 6 pState
|
|
||||||
)
|
|
||||||
|
|
||||||
-- fork the subprocess
|
-- fork our subprocess
|
||||||
pid <- SPPB.forkProcess $ do
|
pid <- SPPB.forkProcess $ do
|
||||||
void $ dupTo stdoutWrite stdOutput
|
void $ dupTo stdoutWrite stdOutput
|
||||||
void $ dupTo stdoutWrite stdError
|
void $ dupTo stdoutWrite stdError
|
||||||
closeFd stdoutRead
|
|
||||||
closeFd stdoutWrite
|
closeFd stdoutWrite
|
||||||
|
closeFd stdoutRead
|
||||||
|
|
||||||
-- execute the action
|
-- execute the action
|
||||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||||
void $ SPPB.executeFile exe spath args env
|
SPPB.executeFile exe spath args env
|
||||||
|
|
||||||
closeFd stdoutWrite
|
closeFd stdoutWrite
|
||||||
|
|
||||||
-- wait for the subprocess to finish
|
-- wait for the subprocess to finish
|
||||||
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
|
e <- SPPB.getProcessStatus True True pid >>= \case
|
||||||
putMVar pState (either (const False) (const True) e)
|
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
|
||||||
|
i -> pure $ toProcessError exe args i
|
||||||
|
|
||||||
|
-- make sure the logging thread stops
|
||||||
|
case e of
|
||||||
|
Left _ -> EX.throwTo tid (StopThread False)
|
||||||
|
Right _ -> EX.throwTo tid (StopThread True)
|
||||||
|
takeMVar done
|
||||||
|
|
||||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
|
||||||
closeFd stdoutRead
|
closeFd stdoutRead
|
||||||
|
|
||||||
pure e
|
pure e
|
||||||
|
|
||||||
tee :: Fd -> Fd -> IO ()
|
|
||||||
tee fileFd fdIn = readTilEOF lineAction fdIn
|
|
||||||
|
|
||||||
where
|
|
||||||
lineAction :: ByteString -> IO ()
|
|
||||||
lineAction bs' = do
|
|
||||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
|
||||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
|
||||||
|
|
||||||
-- Reads fdIn and logs the output in a continous scrolling area
|
-- Reads fdIn and logs the output in a continous scrolling area
|
||||||
-- of 'size' terminal lines. Also writes to a log file.
|
-- of 'size' terminal lines. Also writes to a log file.
|
||||||
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
|
printToRegion fileFd fdIn size = do
|
||||||
printToRegion fileFd fdIn size pState = do
|
ref <- newIORef ([] :: [ByteString])
|
||||||
void $ displayConsoleRegions $ do
|
displayConsoleRegions $ do
|
||||||
rs <-
|
rs <- sequence . replicate size . openConsoleRegion $ Linear
|
||||||
liftIO
|
flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
|
||||||
. fmap Sq.fromList
|
|
||||||
. sequence
|
|
||||||
. replicate size
|
|
||||||
. openConsoleRegion
|
|
||||||
$ Linear
|
|
||||||
flip runStateT mempty
|
|
||||||
$ handle
|
$ handle
|
||||||
(\(ex :: SomeException) -> do
|
(\(StopThread b) -> do
|
||||||
ps <- liftIO $ takeMVar pState
|
when b (forM_ rs closeConsoleRegion)
|
||||||
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
|
EX.throw (StopThread b)
|
||||||
throw ex
|
|
||||||
)
|
)
|
||||||
$ readTilEOF (lineAction rs) fdIn
|
$ do
|
||||||
|
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
|
||||||
|
-- wait for explicit stop from the parent to signal what cleanup to run
|
||||||
|
forever (threadDelay 5000)
|
||||||
|
|
||||||
where
|
where
|
||||||
-- action to perform line by line
|
-- action to perform line by line
|
||||||
-- TODO: do this with vty for efficiency
|
lineAction ref rs bs' = do
|
||||||
lineAction :: (MonadMask m, MonadIO m)
|
modifyIORef' ref (swapRegs bs')
|
||||||
=> Seq ConsoleRegion
|
regs <- readIORef ref
|
||||||
-> ByteString
|
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||||
-> StateT (Seq ByteString) m ()
|
forM (zip regs rs) $ \(bs, r) -> do
|
||||||
lineAction rs = \bs' -> do
|
setConsoleRegion r $ do
|
||||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
w <- consoleWidth
|
||||||
modify (swapRegs bs')
|
return
|
||||||
regs <- get
|
. T.pack
|
||||||
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
|
. color Blue
|
||||||
w <- consoleWidth
|
. T.unpack
|
||||||
return
|
. decUTF8Safe
|
||||||
. T.pack
|
. trim w
|
||||||
. color Blue
|
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
||||||
. T.unpack
|
$ bs
|
||||||
. decUTF8Safe
|
|
||||||
. trim w
|
|
||||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
|
||||||
$ bs
|
|
||||||
|
|
||||||
swapRegs :: a -> Seq a -> Seq a
|
swapRegs bs regs | length regs < size = regs ++ [bs]
|
||||||
swapRegs bs = \regs -> if
|
| otherwise = tail regs ++ [bs]
|
||||||
| Sq.length regs < size -> regs |> bs
|
|
||||||
| otherwise -> Sq.drop 1 regs |> bs
|
|
||||||
|
|
||||||
-- trim output line to terminal width
|
-- trim output line to terminal width
|
||||||
trim :: Int -> ByteString -> ByteString
|
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
|
||||||
trim w = \bs -> if
|
| otherwise = bs
|
||||||
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
|
||||||
| otherwise -> bs
|
|
||||||
|
|
||||||
-- Consecutively read from Fd in 512 chunks until we hit
|
-- read an entire line from the file descriptor (removes the newline char)
|
||||||
-- newline or EOF.
|
readLine fd' = do
|
||||||
readLine :: MonadIO m
|
bs <- SPIB.fdRead fd' 1
|
||||||
=> Fd -- ^ input file descriptor
|
if
|
||||||
-> ByteString -- ^ rest buffer (read across newline)
|
| bs == "\n" -> pure ""
|
||||||
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
| bs == "" -> pure ""
|
||||||
readLine fd = \inBs -> go inBs
|
| otherwise -> fmap (bs <>) $ readLine fd'
|
||||||
where
|
|
||||||
go inBs = do
|
|
||||||
-- if buffer is not empty, process it first
|
|
||||||
mbs <- if BS.length inBs == 0
|
|
||||||
-- otherwise attempt read
|
|
||||||
then liftIO
|
|
||||||
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
|
|
||||||
$ fmap Just
|
|
||||||
$ SPIB.fdRead fd 512
|
|
||||||
else pure $ Just inBs
|
|
||||||
case mbs of
|
|
||||||
Nothing -> pure ("", "", True)
|
|
||||||
Just bs -> do
|
|
||||||
-- split on newline
|
|
||||||
let (line, rest) = BS.span (/= _lf) bs
|
|
||||||
if
|
|
||||||
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
|
|
||||||
-- if rest is empty, then there was no newline, process further
|
|
||||||
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
|
||||||
|
|
||||||
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
readTilEOF action' fd' = do
|
||||||
readTilEOF ~action' fd' = go mempty
|
bs <- readLine fd'
|
||||||
where
|
void $ action' bs
|
||||||
go bs' = do
|
readTilEOF action' fd'
|
||||||
(bs, rest, eof) <- readLine fd' bs'
|
|
||||||
if eof
|
|
||||||
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
|
||||||
else (void $ action' bs) >> go rest
|
|
||||||
|
|
||||||
|
|
||||||
-- | Capture the stdout and stderr of the given action, which
|
-- | Capture the stdout and stderr of the given action, which
|
||||||
@@ -300,12 +273,13 @@ captureOutStreams action = do
|
|||||||
done <- newEmptyMVar
|
done <- newEmptyMVar
|
||||||
_ <-
|
_ <-
|
||||||
forkIO
|
forkIO
|
||||||
|
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||||
$ flip EX.finally (putMVar done ())
|
$ flip finally (putMVar done ())
|
||||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||||
|
|
||||||
status <- SPPB.getProcessStatus True True pid
|
status <- SPPB.getProcessStatus True True pid
|
||||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
takeMVar done
|
||||||
|
|
||||||
case status of
|
case status of
|
||||||
-- readFd will take care of closing the fd
|
-- readFd will take care of closing the fd
|
||||||
@@ -325,13 +299,13 @@ captureOutStreams action = do
|
|||||||
void
|
void
|
||||||
$ forkIO
|
$ forkIO
|
||||||
$ hideError eofErrorType
|
$ hideError eofErrorType
|
||||||
$ flip EX.finally (putMVar doneOut ())
|
$ flip finally (putMVar doneOut ())
|
||||||
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
|
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
|
||||||
doneErr <- newEmptyMVar
|
doneErr <- newEmptyMVar
|
||||||
void
|
void
|
||||||
$ forkIO
|
$ forkIO
|
||||||
$ hideError eofErrorType
|
$ hideError eofErrorType
|
||||||
$ flip EX.finally (putMVar doneErr ())
|
$ flip finally (putMVar doneErr ())
|
||||||
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
|
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
|
||||||
takeMVar doneOut
|
takeMVar doneOut
|
||||||
takeMVar doneErr
|
takeMVar doneErr
|
||||||
@@ -384,6 +358,14 @@ toProcessError exe args mps = case mps of
|
|||||||
Nothing -> Left $ NoSuchPid exe args
|
Nothing -> Left $ NoSuchPid exe args
|
||||||
|
|
||||||
|
|
||||||
|
-- | Convert the String to a ByteString with the current
|
||||||
|
-- system encoding.
|
||||||
|
unsafePathToString :: Path b -> IO FilePath
|
||||||
|
unsafePathToString p = do
|
||||||
|
enc <- getLocaleEncoding
|
||||||
|
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
|
||||||
|
|
||||||
|
|
||||||
-- | Search for a file in the search paths.
|
-- | Search for a file in the search paths.
|
||||||
--
|
--
|
||||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||||
|
|||||||
@@ -1,16 +1,5 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.Logger
|
|
||||||
Description : logger definition
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
Here we define our main logger.
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.Logger where
|
module GHCup.Utils.Logger where
|
||||||
|
|
||||||
import GHCup.Utils
|
import GHCup.Utils
|
||||||
|
|||||||
@@ -1,15 +1,6 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.MegaParsec
|
|
||||||
Description : MegaParsec utilities
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.MegaParsec where
|
module GHCup.Utils.MegaParsec where
|
||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
|||||||
@@ -8,17 +8,6 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.Prelude
|
|
||||||
Description : MegaParsec utilities
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
GHCup specific prelude. Lots of Excepts functionality.
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.Prelude where
|
module GHCup.Utils.Prelude where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
@@ -176,11 +165,6 @@ liftIOException errType ex =
|
|||||||
. lift
|
. lift
|
||||||
|
|
||||||
|
|
||||||
-- | Uses safe-exceptions.
|
|
||||||
hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
|
|
||||||
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
|
|
||||||
|
|
||||||
|
|
||||||
hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
|
hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
|
||||||
hideErrorDef errs def =
|
hideErrorDef errs def =
|
||||||
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
|
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
|
||||||
|
|||||||
@@ -1,35 +1,25 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
{-|
|
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
|
||||||
Module : GHCup.Utils.String.QQ
|
--
|
||||||
Description : String quasi quoters
|
-- The "s" quoter contains a multi-line string with no interpolation at all,
|
||||||
Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
|
-- except that the leading newline is trimmed and carriage returns stripped.
|
||||||
License : GPL-3
|
--
|
||||||
Maintainer : hasufell@hasufell.de
|
-- @
|
||||||
Stability : experimental
|
-- {-\# LANGUAGE QuasiQuotes #-}
|
||||||
Portability : POSIX
|
-- import Data.Text (Text)
|
||||||
|
-- import Data.String.QQ
|
||||||
QuasiQuoter for non-interpolated strings, texts and bytestrings.
|
-- foo :: Text -- "String", "ByteString" etc also works
|
||||||
|
-- foo = [s|
|
||||||
The "s" quoter contains a multi-line string with no interpolation at all,
|
-- Well here is a
|
||||||
except that the leading newline is trimmed and carriage returns stripped.
|
-- multi-line string!
|
||||||
|
-- |]
|
||||||
@
|
-- @
|
||||||
{-\# LANGUAGE QuasiQuotes #-}
|
--
|
||||||
import Data.Text (Text)
|
-- Any instance of the IsString type is permitted.
|
||||||
import Data.String.QQ
|
--
|
||||||
foo :: Text -- "String", "ByteString" etc also works
|
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
|
||||||
foo = [s|
|
--
|
||||||
Well here is a
|
|
||||||
multi-line string!
|
|
||||||
|]
|
|
||||||
@
|
|
||||||
|
|
||||||
Any instance of the IsString type is permitted.
|
|
||||||
|
|
||||||
(For GHC versions 6, write "[$s||]" instead of "[s||]".)
|
|
||||||
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.String.QQ
|
module GHCup.Utils.String.QQ
|
||||||
( s
|
( s
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -7,15 +7,6 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Utils.Version.QQ
|
|
||||||
Description : Version quasi-quoters
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Utils.Version.QQ where
|
module GHCup.Utils.Version.QQ where
|
||||||
|
|
||||||
import Data.Data
|
import Data.Data
|
||||||
@@ -51,6 +42,7 @@ deriving instance Data VUnit
|
|||||||
|
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
deriving instance Lift (NonEmpty Word)
|
deriving instance Lift (NonEmpty Word)
|
||||||
|
instance Lift Text
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||||
|
|||||||
@@ -1,15 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
|
|
||||||
{-|
|
|
||||||
Module : GHCup.Version
|
|
||||||
Description : Static version information
|
|
||||||
Copyright : (c) Julian Ospald, 2020
|
|
||||||
License : GPL-3
|
|
||||||
Maintainer : hasufell@hasufell.de
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
-}
|
|
||||||
module GHCup.Version where
|
module GHCup.Version where
|
||||||
|
|
||||||
import GHCup.Utils.Version.QQ
|
import GHCup.Utils.Version.QQ
|
||||||
@@ -20,14 +11,12 @@ import URI.ByteString.QQ
|
|||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
-- | This reflects the API version of the YAML.
|
-- | This reflects the API version of the JSON.
|
||||||
ghcupURL :: URI
|
ghcupURL :: URI
|
||||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
|
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
|
||||||
|
|
||||||
-- | The current ghcup version.
|
|
||||||
ghcUpVer :: PVP
|
ghcUpVer :: PVP
|
||||||
ghcUpVer = [pver|0.1.8|]
|
ghcUpVer = [pver|0.1.5|]
|
||||||
|
|
||||||
-- | ghcup version as numeric string.
|
|
||||||
numericVer :: String
|
numericVer :: String
|
||||||
numericVer = T.unpack . prettyPVP $ ghcUpVer
|
numericVer = T.unpack . prettyPVP $ ghcUpVer
|
||||||
|
|||||||
@@ -101,7 +101,6 @@ body#idx p.other-help {
|
|||||||
|
|
||||||
.instructions div.command-button {
|
.instructions div.command-button {
|
||||||
display: flex;
|
display: flex;
|
||||||
align-items: center;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
.instructions div.command-button button {
|
.instructions div.command-button button {
|
||||||
@@ -112,7 +111,7 @@ body#idx p.other-help {
|
|||||||
border-style: solid;
|
border-style: solid;
|
||||||
border-radius: 3px;
|
border-radius: 3px;
|
||||||
|
|
||||||
margin-left: 0.5rem;
|
margin-left: 1rem;
|
||||||
margin-right: auto;
|
margin-right: auto;
|
||||||
margin-top: 25px;
|
margin-top: 25px;
|
||||||
margin-bottom: 25px;
|
margin-bottom: 25px;
|
||||||
@@ -135,21 +134,20 @@ hr {
|
|||||||
#platform-instructions-linux > div > pre,
|
#platform-instructions-linux > div > pre,
|
||||||
#platform-instructions-mac > div > pre,
|
#platform-instructions-mac > div > pre,
|
||||||
#platform-instructions-freebsd > div > pre,
|
#platform-instructions-freebsd > div > pre,
|
||||||
#platform-instructions-win32 > div > pre,
|
#platform-instructions-win32 > pre,
|
||||||
#platform-instructions-win64 > div > pre,
|
#platform-instructions-win64 > pre,
|
||||||
#platform-instructions-default > div > div > pre,
|
#platform-instructions-default > div > div > pre,
|
||||||
#platform-instructions-unknown > div > div > pre {
|
#platform-instructions-unknown > div > div > pre {
|
||||||
background-color: #515151;
|
background-color: #515151;
|
||||||
color: white;
|
color: white;
|
||||||
margin-left: auto;
|
margin-left: auto;
|
||||||
|
margin-right: auto;
|
||||||
padding-top: 1rem;
|
padding-top: 1rem;
|
||||||
padding-bottom: 1rem;
|
padding-bottom: 1rem;
|
||||||
padding-right: 1rem;
|
padding-right: 1rem;
|
||||||
text-align: center;
|
text-align: center;
|
||||||
border-radius: 3px;
|
border-radius: 3px;
|
||||||
box-shadow: inset 0px 0px 20px 0px #333333;
|
box-shadow: inset 0px 0px 20px 0px #333333;
|
||||||
font-size: 0.6em;
|
|
||||||
width: 40rem;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
#platform-instructions-win32 a.windows-download,
|
#platform-instructions-win32 a.windows-download,
|
||||||
|
|||||||
@@ -46,9 +46,6 @@
|
|||||||
<p>
|
<p>
|
||||||
To install Haskell, follow the instructions on
|
To install Haskell, follow the instructions on
|
||||||
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
|
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
|
||||||
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
|
|
||||||
</p>
|
|
||||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
|
||||||
</p>
|
</p>
|
||||||
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
|
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
|
||||||
</div>
|
</div>
|
||||||
@@ -58,9 +55,6 @@
|
|||||||
To install Haskell, follow the instructions on
|
To install Haskell, follow the instructions on
|
||||||
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
|
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
|
||||||
</p>
|
</p>
|
||||||
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
|
|
||||||
</p>
|
|
||||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
|
||||||
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
|
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
|
||||||
</div>
|
</div>
|
||||||
|
|
||||||
@@ -83,7 +77,7 @@
|
|||||||
|
|
||||||
<!-- duplicate the default cross-platform instructions -->
|
<!-- duplicate the default cross-platform instructions -->
|
||||||
<div>
|
<div>
|
||||||
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
<p>If you are running Linux, macOS or FreeBSD,<br/>run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
||||||
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
||||||
</div>
|
</div>
|
||||||
@@ -101,7 +95,7 @@
|
|||||||
|
|
||||||
<div id="platform-instructions-default" class="instructions">
|
<div id="platform-instructions-default" class="instructions">
|
||||||
<div>
|
<div>
|
||||||
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
|
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
|
||||||
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
||||||
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
||||||
@@ -146,7 +140,7 @@
|
|||||||
|
|
||||||
<div id="platform-instructions-default" class="instructions">
|
<div id="platform-instructions-default" class="instructions">
|
||||||
<div>
|
<div>
|
||||||
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
|
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
|
||||||
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||||
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
|
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
|
||||||
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
||||||
|
|||||||
Reference in New Issue
Block a user