Compare commits

..

7 Commits

130 changed files with 5510 additions and 51239 deletions

View File

@@ -1,23 +0,0 @@
freebsd_instance:
image_family: freebsd-13-1
task:
env:
GHC_VER: 9.2.4
CABAL_VER: 3.6.2.0
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
ARCH: 64
RUNNER_OS: FreeBSD
DISTRO: na
GITHUB_WORKSPACE: ${CIRRUS_WORKING_DIR}
JSON_VERSION: "0.0.7"
CIRRUS_CLONE_SUBMODULES: true
AWS_ACCESS_KEY_ID: ENCRYPTED[3e99c4ac040871f213abd616ec66952d954dc289cdd97772f88e58a74d08a2250133437780fe98b7aedf7ef1fb32f5eb]
AWS_SECRET_ACCESS_KEY: ENCRYPTED[5910cfd77a922ff7fc06eeb6a6b9f79d4867863e541f06eb2c4cfecae0613650e3e0588373fa8d9249d295d76cf9cb3b]
S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d]
install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake
script:
- bash .github/scripts/build.sh
- bash .github/scripts/test.sh
binaries_artifacts:
path: "out/*"

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,37 +0,0 @@
.
./cabal
./ghc
./ghc-8.10.7
./ghc-pkg
./ghc-pkg-8.10.7
./ghci
./ghci-8.10.7
./haddock
./haddock-8.10.7
./haskell-language-server-8.10.6
./haskell-language-server-8.10.6~1.6.1.0
./haskell-language-server-8.10.7
./haskell-language-server-8.10.7~1.6.1.0
./haskell-language-server-8.6.5
./haskell-language-server-8.6.5~1.6.1.0
./haskell-language-server-8.8.4
./haskell-language-server-8.8.4~1.6.1.0
./haskell-language-server-9.0.1
./haskell-language-server-9.0.1~1.6.1.0
./haskell-language-server-9.0.2
./haskell-language-server-9.0.2~1.6.1.0
./haskell-language-server-9.2.1
./haskell-language-server-9.2.1~1.6.1.0
./haskell-language-server-wrapper
./haskell-language-server-wrapper-1.6.1.0
./hp2ps
./hp2ps-8.10.7
./hpc
./hpc-8.10.7
./hsc2hs
./hsc2hs-8.10.7
./runghc
./runghc-8.10.7
./runhaskell
./runhaskell-8.10.7
./stack

View File

@@ -1,31 +0,0 @@
.
./cabal
./ghc
./ghc-8.10.7
./ghc-pkg
./ghc-pkg-8.10.7
./ghci
./ghci-8.10.7
./haddock
./haddock-8.10.7
./haskell-language-server-8.10.7
./haskell-language-server-8.10.7~1.6.1.0
./haskell-language-server-8.8.4
./haskell-language-server-8.8.4~1.6.1.0
./haskell-language-server-9.0.2
./haskell-language-server-9.0.2~1.6.1.0
./haskell-language-server-9.2.1
./haskell-language-server-9.2.1~1.6.1.0
./haskell-language-server-wrapper
./haskell-language-server-wrapper-1.6.1.0
./hp2ps
./hp2ps-8.10.7
./hpc
./hpc-8.10.7
./hsc2hs
./hsc2hs-8.10.7
./runghc
./runghc-8.10.7
./runhaskell
./runhaskell-8.10.7
./stack

View File

@@ -1,81 +0,0 @@
.
./cabal.exe
./cabal.shim
./ghc-8.10.7.exe
./ghc-8.10.7.shim
./ghc-pkg-8.10.7.exe
./ghc-pkg-8.10.7.shim
./ghc-pkg.exe
./ghc-pkg.shim
./ghc.exe
./ghc.shim
./ghci-8.10.7.exe
./ghci-8.10.7.shim
./ghci.exe
./ghci.shim
./ghcii-8.10.7.sh-8.10.7.exe
./ghcii-8.10.7.sh-8.10.7.shim
./ghcii-8.10.7.sh.exe
./ghcii-8.10.7.sh.shim
./ghcii.sh-8.10.7.exe
./ghcii.sh-8.10.7.shim
./ghcii.sh.exe
./ghcii.sh.shim
./haddock-8.10.7.exe
./haddock-8.10.7.shim
./haddock.exe
./haddock.shim
./haskell-language-server-8.10.6.exe
./haskell-language-server-8.10.6.shim
./haskell-language-server-8.10.6~1.6.1.0.exe
./haskell-language-server-8.10.6~1.6.1.0.shim
./haskell-language-server-8.10.7.exe
./haskell-language-server-8.10.7.shim
./haskell-language-server-8.10.7~1.6.1.0.exe
./haskell-language-server-8.10.7~1.6.1.0.shim
./haskell-language-server-8.6.5.exe
./haskell-language-server-8.6.5.shim
./haskell-language-server-8.6.5~1.6.1.0.exe
./haskell-language-server-8.6.5~1.6.1.0.shim
./haskell-language-server-8.8.4.exe
./haskell-language-server-8.8.4.shim
./haskell-language-server-8.8.4~1.6.1.0.exe
./haskell-language-server-8.8.4~1.6.1.0.shim
./haskell-language-server-9.0.1.exe
./haskell-language-server-9.0.1.shim
./haskell-language-server-9.0.1~1.6.1.0.exe
./haskell-language-server-9.0.1~1.6.1.0.shim
./haskell-language-server-9.0.2.exe
./haskell-language-server-9.0.2.shim
./haskell-language-server-9.0.2~1.6.1.0.exe
./haskell-language-server-9.0.2~1.6.1.0.shim
./haskell-language-server-9.2.1.exe
./haskell-language-server-9.2.1.shim
./haskell-language-server-9.2.1~1.6.1.0.exe
./haskell-language-server-9.2.1~1.6.1.0.shim
./haskell-language-server-wrapper-1.6.1.0.exe
./haskell-language-server-wrapper-1.6.1.0.shim
./haskell-language-server-wrapper.exe
./haskell-language-server-wrapper.shim
./hp2ps-8.10.7.exe
./hp2ps-8.10.7.shim
./hp2ps.exe
./hp2ps.shim
./hpc-8.10.7.exe
./hpc-8.10.7.shim
./hpc.exe
./hpc.shim
./hsc2hs-8.10.7.exe
./hsc2hs-8.10.7.shim
./hsc2hs.exe
./hsc2hs.shim
./runghc-8.10.7.exe
./runghc-8.10.7.shim
./runghc.exe
./runghc.shim
./runhaskell-8.10.7.exe
./runhaskell-8.10.7.shim
./runhaskell.exe
./runhaskell.shim
./stack.exe
./stack.shim

View File

@@ -1,16 +0,0 @@
#!/usr/bin/env bash
set -eux
. .github/scripts/prereq.sh
mkdir -p "$CI_PROJECT_DIR"/.local/bin
git describe --always
### build
./scripts/bootstrap/bootstrap-haskell
[ "$(ghc --numeric-version)" = "${BOOTSTRAP_HASKELL_GHC_VERSION}" ]

View File

@@ -1,76 +0,0 @@
#!/bin/sh
set -eux
. .github/scripts/prereq.sh
. .github/scripts/common.sh
# ensure ghcup
if ! command -v ghcup ; then
install_ghcup
fi
# ensure cabal-cache
if ! cabal-cache version ; then
download_cabal_cache "$HOME/.local/bin/cabal-cache"
fi
# ensure ghc
if [ "${RUNNER_OS}" != "FreeBSD" ] ; then
if [ "${DISTRO}" != "Debian" ] ; then # ! armv7 or aarch64 linux
if ! "ghc-${GHC_VER}" --numeric-version ; then
ghcup -v install ghc --set --force "$GHC_VER"
fi
if [ "$(cabal --numeric-version || true)" != "${CABAL_VER}" ] ; then
ghcup -v install cabal --force "$CABAL_VER"
fi
ghc --version
cabal --version
GHC="ghc-${GHC_VER}"
else
if [ "$(cabal --numeric-version || true)" != "${CABAL_VER}" ] ; then
ghcup -v install cabal --force "$CABAL_VER"
fi
cabal --version
GHC="ghc"
fi
else
ghc --version
cabal --version
GHC="ghc"
fi
git_describe
# build
ecabal update
if [ "${RUNNER_OS}" = "Linux" ] ; then
if [ "${ARCH}" = "32" ] ; then
build_with_cache -w "${GHC}" --ghc-options='-split-sections -optl-static' -ftui --enable-tests
elif [ "${ARCH}" = "64" ] ; then
build_with_cache -w "${GHC}" --ghc-options='-split-sections -optl-static' -ftui --enable-tests
else
build_with_cache -w "${GHC}" -ftui --enable-tests
fi
elif [ "${RUNNER_OS}" = "FreeBSD" ] ; then
build_with_cache -w "${GHC}" --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" --constraint="zip +disable-zstd" -ftui --enable-tests
elif [ "${RUNNER_OS}" = "Windows" ] ; then
build_with_cache -w "${GHC}" --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" --enable-tests
else
build_with_cache -w "${GHC}" --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui --enable-tests
fi
# set up artifacts
mkdir -p out
binary=$(cabal list-bin ghcup)
binary_test=$(cabal list-bin ghcup-test)
ver=$("${binary}" --numeric-version)
strip_binary "${binary}"
cp "${binary}" "out/${ARTIFACT}-${ver}"
cp "${binary_test}" "out/test-${ARTIFACT}-${ver}"
cp ./dist-newstyle/cache/plan.json "out/${ARTIFACT}.plan.json"

View File

@@ -1,179 +0,0 @@
#!/bin/sh
if [ "${RUNNER_OS}" = "Windows" ] ; then
ext=".exe"
else
ext=''
fi
ecabal() {
cabal "$@"
}
sync_from_retry() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
else
cabal_store_path="${CABAL_DIR}/store"
fi
sync_from || { sleep 9 ; rm -rf "${cabal_store_path:?}"/* ; sync_from || { sleep 20 ; rm -rf "${cabal_store_path:?}"/* ; sync_from ; } }
}
sync_from() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi
cabal-cache sync-from-archive \
--host-name-override=${S3_HOST} \
--host-port-override=443 \
--host-ssl-override=True \
--region us-west-2 \
$([ "${RUNNER_OS}" != "Windows" ] && echo --store-path="$cabal_store_path") \
--archive-uri "s3://ghcup-hs/${RUNNER_OS}-${ARCH}-${DISTRO}"
}
sync_to_retry() {
sync_to || { sleep 9 ; sync_to || { sleep 20 ; sync_to ; } }
}
sync_to() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi
cabal-cache sync-to-archive \
--host-name-override=${S3_HOST} \
--host-port-override=443 \
--host-ssl-override=True \
--region us-west-2 \
$([ "${RUNNER_OS}" != "Windows" ] && echo --store-path="$cabal_store_path") \
--archive-uri "s3://ghcup-hs/${RUNNER_OS}-${ARCH}-${DISTRO}"
}
raw_eghcup() {
"$GHCUP_BIN/ghcup${ext}" -v -c "$@"
}
eghcup() {
if [ "${OS}" = "Windows" ] ; then
"$GHCUP_BIN/ghcup${ext}" -c -s "file:/$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$@"
else
"$GHCUP_BIN/ghcup${ext}" -c -s "file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$@"
fi
}
sha_sum() {
if [ "${OS}" = "FreeBSD" ] ; then
sha256 "$@"
else
sha256sum "$@"
fi
}
git_describe() {
git config --global --get-all safe.directory | grep '^\*$' || git config --global --add safe.directory "*"
git describe --always
}
download_cabal_cache() {
(
set -e
dest="$HOME/.local/bin/cabal-cache"
url=""
exe=""
cd /tmp
case "${RUNNER_OS}" in
"Linux")
case "${DISTRO}" in
"Alpine")
case "${ARCH}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/i386-linux-alpine-cabal-cache-1.0.5.1
;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-linux-alpine-cabal-cache-1.0.5.1
;;
esac
;;
*)
case "${ARCH}" in
"64") url=https://github.com/haskell-works/cabal-cache/releases/download/v1.0.5.1/cabal-cache-x86_64-linux.gz
;;
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-linux-cabal-cache-1.0.5.1
;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/armv7-linux-cabal-cache-1.0.5.1
;;
esac
;;
esac
;;
"FreeBSD")
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-freebsd-cabal-cache-1.0.5.1
;;
"Windows")
exe=".exe"
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-mingw64-cabal-cache-1.0.5.1.exe
;;
"macOS")
case "${ARCH}" in
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-apple-darwin-cabal-cache-1.0.5.1
;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-apple-darwin-cabal-cache-1.0.5.1
;;
esac
;;
esac
if [ -n "${url}" ] ; then
case "${url##*.}" in
"gz")
curl -L -o - "${url}" | gunzip > cabal-cache${exe}
;;
*)
curl -o cabal-cache${exe} -L "${url}"
;;
esac
chmod +x cabal-cache${exe}
cp "cabal-cache${exe}" "${dest}${exe}"
fi
)
}
build_with_cache() {
ecabal configure "$@"
ecabal build --dependencies-only "$@" --dry-run
sync_from_retry
ecabal build --dependencies-only "$@" || sync_to_retry
sync_to_retry
ecabal build "$@"
sync_to_retry
}
install_ghcup() {
find "$GHCUP_INSTALL_BASE_PREFIX"
mkdir -p "$GHCUP_BIN"
mkdir -p "$GHCUP_BIN"/../cache
if [ "${RUNNER_OS}" = "FreeBSD" ] ; then
curl -o ghcup https://downloads.haskell.org/ghcup/tmp/x86_64-portbld-freebsd-ghcup-0.1.18.1
chmod +x ghcup
mv ghcup "$HOME/.local/bin/ghcup"
else
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
fi
}
strip_binary() {
(
set -e
binary=$1
if [ "${RUNNER_OS}" = "macOS" ] ; then
strip "${binary}"
else
if [ "${RUNNER_OS}" != "Windows" ] ; then
strip -s "${binary}"
fi
fi
)
}

View File

@@ -1,73 +0,0 @@
#!/usr/bin/env bash
set -eux
. .github/scripts/prereq.sh
. .github/scripts/common.sh
mkdir -p "$CI_PROJECT_DIR"/.local/bin
### build
if [ "${OS}" = "Windows" ] ; then
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
rm -rf "${GHCUP_DIR}"
mkdir -p "${GHCUP_BIN}"
ls -lah out
find out
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}"
echo "$PATH"
"$GHCUP_BIN/ghcup${ext}" --version
eghcup --version
sha_sum "$GHCUP_BIN/ghcup${ext}"
sha_sum "$(raw_eghcup --offline whereis ghcup)"
git_describe
eghcup install ghc "${GHC_VERSION}"
eghcup install cabal
ecabal update
if ! command -v cabal-cache ; then
download_cabal_cache "$HOME/.local/bin/cabal-cache"
fi
if ! cabal-cache version ; then
build_cabal_cache "$HOME/.local/bin"
fi
eghcup debug-info
(
cd /tmp
git clone --depth 1 --branch "${HLS_TARGET_VERSION}" \
https://github.com/haskell/haskell-language-server.git \
"haskell-language-server-${HLS_TARGET_VERSION}"
cd "haskell-language-server-${HLS_TARGET_VERSION}/"
ecabal configure -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)"
ecabal build --dependencies-only -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)" --dry-run
sync_from_retry
ecabal build --dependencies-only -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)" || sync_to
sync_to_retry
)
eghcup -v compile hls -j "$(nproc)" -g "${HLS_TARGET_VERSION}" --ghc "${GHC_VERSION}"
[ "$($(eghcup whereis hls "${HLS_TARGET_VERSION}") --numeric-version)" = "${HLS_TARGET_VERSION}" ] ||
[ "$($(eghcup whereis hls "${HLS_TARGET_VERSION}") --numeric-version | sed 's/.0$//')" = "${HLS_TARGET_VERSION}" ]
# nuke
eghcup nuke
[ ! -e "${GHCUP_DIR}" ]

View File

@@ -1,66 +0,0 @@
#!/bin/sh
mkdir -p "$HOME"/.local/bin
export OS="$RUNNER_OS"
export PATH="$HOME/.local/bin:$PATH"
: "${APT_GET:=apt-get}"
if [ "${RUNNER_OS}" = "Windows" ] ; then
# on windows use pwd to get unix style path
CI_PROJECT_DIR="$(pwd)"
export CI_PROJECT_DIR
export GHCUP_INSTALL_BASE_PREFIX="/c"
export GHCUP_BIN="$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin"
export PATH="$GHCUP_BIN:$PATH"
export CABAL_DIR="C:\\Users\\runneradmin\\AppData\\Roaming\\cabal"
else
export CI_PROJECT_DIR="${GITHUB_WORKSPACE}"
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export GHCUP_BIN="$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin"
export PATH="$GHCUP_BIN:$PATH"
export CABAL_DIR="$CI_PROJECT_DIR/cabal"
export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache"
fi
if [ "${RUNNER_OS}" = "Linux" ] ; then
if [ "${DISTRO}" = "Alpine" ] ; then
:
elif [ "${DISTRO}" = "Ubuntu" ] ; then
export DEBIAN_FRONTEND=noninteractive
export TZ=Asia/Singapore
if [ "${ARCH}" = "ARM64" ] || [ "${ARCH}" = "ARM" ] ; then
:
else
${APT_GET} install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
fi
elif [ "${DISTRO}" = "Debian" ] ; then
export DEBIAN_FRONTEND=noninteractive
export TZ=Asia/Singapore
${APT_GET} install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl ghc gzip
fi
elif [ "${RUNNER_OS}" = "macOS" ] ; then
if ! command -v brew ; then
[ -e "$HOME/.brew" ] ||
git clone --depth=1 https://github.com/Homebrew/brew "$HOME/.brew"
export PATH="$HOME/.brew/bin:$HOME/.brew/sbin:$PATH"
brew update
fi
if ! command -v git ; then
brew install git
fi
if ! command -v realpath ; then
brew install coreutils
fi
if [ "${ARCH}" = "ARM64" ] ; then
brew install llvm@11 autoconf automake
export PATH="$HOME/.brew/opt/llvm@11/bin:$PATH"
export CC="$HOME/.brew/opt/llvm@11/bin/clang"
export CXX="$HOME/.brew/opt/llvm@11/bin/clang++"
export LD=ld
export AR="$HOME/.brew/opt/llvm@11/bin/llvm-ar"
export RANLIB="$HOME/.brew/opt/llvm@11/bin/llvm-ranlib"
fi
fi

View File

@@ -1,263 +0,0 @@
#!/usr/bin/env bash
set -eux
. .github/scripts/prereq.sh
. .github/scripts/common.sh
if [ "${OS}" = "Windows" ] ; then
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
git_describe
rm -rf "${GHCUP_DIR}"
mkdir -p "${GHCUP_BIN}"
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
cp "out/test-${ARTIFACT}"-* "ghcup-test${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}"
chmod +x "ghcup-test${ext}"
"$GHCUP_BIN/ghcup${ext}" --version
eghcup --version
sha_sum "$GHCUP_BIN/ghcup${ext}"
sha_sum "$(raw_eghcup --offline whereis ghcup)"
### Haskell test suite
./ghcup-test${ext}
rm ghcup-test${ext}
### manual cli based testing
eghcup --numeric-version
eghcup install ghc ${GHC_VER}
eghcup unset ghc ${GHC_VER}
ls -lah "$(eghcup whereis -d ghc ${GHC_VER})"
[ "`$(eghcup whereis ghc ${GHC_VER}) --numeric-version`" = "${GHC_VER}" ]
[ "`eghcup run --ghc ${GHC_VER} -- ghc --numeric-version`" = "${GHC_VER}" ]
[ "`ghcup run --ghc ${GHC_VER} -- ghc -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" = "`$(ghcup whereis ghc ${GHC_VER}) -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" ]
eghcup set ghc ${GHC_VER}
eghcup install cabal ${CABAL_VER}
[ "`$(eghcup whereis cabal ${CABAL_VER}) --numeric-version`" = "${CABAL_VER}" ]
eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit 1 || echo yes
# make sure no cabal is set when running 'ghcup run' to check that PATH propagages properly
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
[ "`eghcup run --cabal ${CABAL_VER} -- cabal --numeric-version`" = "${CABAL_VER}" ]
eghcup set cabal ${CABAL_VER}
[ "`$(eghcup whereis cabal ${CABAL_VER}) --numeric-version`" = "${CABAL_VER}" ]
if [ "${OS}" != "FreeBSD" ] ; then
if [ "${ARCH}" = "64" ] && [ "${DISTRO}" != "Alpine" ] ; then
eghcup run --ghc 8.10.7 --cabal 3.4.1.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin"
if [ "${OS}" = "Windows" ] ; then
cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.windows" | sort > expected.txt
elif [ "${DISTRO}" = "Alpine" ] ; then
cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.alpine" | sort > expected.txt
else
cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort > expected.txt
fi
(cd ".bin" && find . | sort) > actual.txt
diff --strip-trailing-cr -w -u actual.txt expected.txt
rm actual.txt expected.txt
rm -rf .bin
fi
fi
cabal --version
eghcup debug-info
# also test etags
eghcup list
eghcup list -t ghc
eghcup list -t cabal
ghc_ver=$(ghc --numeric-version)
ghc --version
ghc-${ghc_ver} --version
if [ "${OS}" != "Windows" ] ; then
ghci --version
ghci-${ghc_ver} --version
fi
if [ "${OS}" = "macOS" ] && [ "${ARCH}" = "ARM64" ] ; then
# missing bindists
echo
elif [ "${OS}" = "FreeBSD" ] ; then
# not enough space
echo
else
# test installing new ghc doesn't mess with currently set GHC
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
if [ "${OS}" = "Linux" ] ; then
eghcup --downloader=wget prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
if [ "${ARCH}" = "64" ] ; then
if [ "${DISTRO}" = "Alpine" ] ; then
(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.alpine.files" | sort) > expected.txt
else
(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort) > expected.txt
fi
(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort) > actual.txt
# ignore docs
sed -i '/share\/doc/d' actual.txt
sed -i '/share\/doc/d' expected.txt
diff --strip-trailing-cr -w -u actual.txt expected.txt
rm actual.txt expected.txt
fi
elif [ "${OS}" = "Windows" ] ; then
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort) > expected.txt
(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort) > actual.txt
diff --strip-trailing-cr -w -u actual.txt expected.txt
rm actual.txt expected.txt
else
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup --offline set 8.10.3
eghcup set 8.10.3
[ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VER}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup unset ghc
"$GHCUP_BIN"/ghc --numeric-version && exit 1 || echo yes
eghcup set ${GHC_VER}
eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
ls -lah "$GHCUP_BIN"
if [ "${OS}" = "macOS" ] ; then
eghcup install hls
$(eghcup whereis hls) --version
eghcup install stack
$(eghcup whereis stack) --version
elif [ "${OS}" = "Linux" ] ; then
if [ "${ARCH}" = "64" ] && [ "${DISTRO}" != "Alpine" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup unset hls
"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit 1 || echo yes
eghcup install stack
stack --version
eghcup unset stack
"$GHCUP_BIN"/stack --version && exit 1 || echo yes
fi
fi
fi
# check that lazy loading works for 'whereis'
cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
eghcup whereis ghc $(ghc --numeric-version)
mv -f "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
eghcup rm $(ghc --numeric-version)
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
if [ "${OS}" = "Linux" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4
eghcup rm cabal 3.4.0.0-rc4
fi
fi
eghcup gc -c
# test etags
rm -f "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
raw_eghcup -s https://www.haskell.org/ghcup/data/ghcup-${JSON_VERSION}.yaml list
# snapshot yaml and etags file
etag=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
# invalidate access time timer, which is 5minutes, so we re-download
touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
# redownload same file with some newlines added
raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
# snapshot new yaml and etags file
etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
# compare
[ "${etag}" != "${etag2}" ]
[ "${sha}" != "${sha2}" ]
# invalidate access time timer, which is 5minutes, but don't expect a re-download
touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
# this time, we expect the same hash and etag
raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
[ "${etag2}" = "${etag3}" ]
[ "${sha2}" = "${sha3}" ]
# test isolated installs
if [ "${DISTRO}" != "Alpine" ] ; then
eghcup install ghc -i "$(pwd)/isolated" 8.10.5
[ "$(isolated/bin/ghc --numeric-version)" = "8.10.5" ]
! eghcup install ghc -i "$(pwd)/isolated" 8.10.5
if [ "${ARCH}" = "64" ] ; then
if [ "${OS}" = "Linux" ] || [ "${OS}" = "Windows" ] ; then
eghcup install cabal -i "$(pwd)/isolated" 3.4.0.0
[ "$(isolated/cabal --numeric-version)" = "3.4.0.0" ]
eghcup install stack -i "$(pwd)/isolated" 2.7.3
[ "$(isolated/stack --numeric-version)" = "2.7.3" ]
eghcup install hls -i "$(pwd)/isolated" 1.3.0
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] ||
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ]
# test that isolated installs don't clean up target directory
cat <<EOF > "${GHCUP_BIN}/gmake"
#!/bin/bash
exit 1
EOF
chmod +x "${GHCUP_BIN}/gmake"
mkdir isolated_tainted/
touch isolated_tainted/lol
! eghcup install ghc -i "$(pwd)/isolated_tainted" 8.10.5 --force
[ -e "$(pwd)/isolated_tainted/lol" ]
rm "${GHCUP_BIN}/gmake"
fi
fi
fi
eghcup upgrade
eghcup upgrade -f
# restore old ghcup, because we want to test nuke
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}"
# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
mkdir no_nuke/
mkdir no_nuke/bar
echo 'foo' > no_nuke/file
echo 'bar' > no_nuke/bar/file
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
# nuke
eghcup nuke
[ ! -e "${GHCUP_DIR}" ]
# make sure nuke doesn't resolve symlinks
[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]

View File

@@ -1,48 +0,0 @@
name: Bootstrap tests
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
jobs:
bootstrap:
name: bootstrap
runs-on: ${{ matrix.os }}
env:
BOOTSTRAP_HASKELL_CABAL_VERSION: 3.6.2.0
BOOTSTRAP_HASKELL_GHC_VERSION: 8.10.7
BOOTSTRAP_HASKELL_NONINTERACTIVE: yes
ARCH: 64
JSON_VERSION: "0.0.7"
APT_GET: "sudo apt-get"
strategy:
matrix:
include:
- os: ubuntu-latest
DISTRO: Ubuntu
- os: macOS-10.15
DISTRO: na
- os: windows-latest
DISTRO: na
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- if: runner.os != 'Windows'
name: Run bootstrap
run: sh ./.github/scripts/bootstrap.sh
env:
DISTRO: ${{ matrix.DISTRO }}
- if: runner.os == 'Windows'
name: Run bootstrap
run: ./scripts/bootstrap/bootstrap-haskell.ps1 -InstallDir ${GITHUB_WORKSPACE} -BootstrapUrl ${GITHUB_WORKSPACE}/bootstrap-haskell -InBash
shell: pwsh

View File

@@ -1,37 +0,0 @@
name: Cache eviction
on:
workflow_dispatch:
inputs:
key:
description: Which cache to evict
required: true
default: '/'
type: choice
options:
- FreeBSD-64-na
- Linux-32-Alpine
- Linux-64-Alpine
- Linux-64-Ubuntu
- Linux-ARM-Ubuntu
- Linux-ARM64-Ubuntu
- Windows-64-na
- macOS-64-na
- macOS-ARM64-na
- /
jobs:
evict:
runs-on: ubuntu-latest
steps:
- name: Remove from S3
uses: vitorsgomes/s3-rm-action@master
with:
args: --recursive
env:
AWS_S3_ENDPOINT: ${{ secrets.S3_HOST }}
AWS_S3_BUCKET: ghcup-hs
AWS_REGION: us-west-2
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
PATH_TO_DELETE: ${{ github.event.inputs.key }}

View File

@@ -1,68 +0,0 @@
name: Docker image builds
on:
workflow_dispatch:
schedule:
- cron: '0 0 * * *'
jobs:
docker-alpine:
runs-on: ubuntu-latest
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Set up QEMU
uses: docker/setup-qemu-action@v2
- name: Set up Docker Buildx
uses: docker/setup-buildx-action@v2
- name: Login to Docker Hub
uses: docker/login-action@v2
with:
username: ${{ secrets.DOCKERHUB_USERNAME }}
password: ${{ secrets.DOCKERHUB_TOKEN }}
- name: Build and push (alpine 32bit)
uses: docker/build-push-action@v3
with:
context: ./docker/alpine32
push: true
tags: hasufell/i386-alpine-haskell:3.12
platforms: linux/i386
- name: Build and push (alpine 64bit)
uses: docker/build-push-action@v3
with:
context: ./docker/alpine64
push: true
tags: hasufell/alpine-haskell:3.12
platforms: linux/amd64
docker-arm:
runs-on: [self-hosted, Linux, aarch64]
steps:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup
with:
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: Checkout
uses: actions/checkout@v3
- name: Set up Docker Buildx
uses: docker/setup-buildx-action@v2
- name: Login to Docker Hub
uses: docker/login-action@v2
with:
username: ${{ secrets.DOCKERHUB_USERNAME }}
password: ${{ secrets.DOCKERHUB_TOKEN }}
- name: Build and push (arm64v8)
uses: docker/build-push-action@v3
with:
context: ./docker/arm64v8/
push: true
tags: hasufell/arm64v8-ubuntu-haskell:focal
platforms: linux/arm64
- name: Build and push (arm32v7)
uses: docker/build-push-action@v3
with:
context: ./docker/arm32v7
push: true
tags: hasufell/arm32v7-ubuntu-haskell:focal
platforms: linux/arm

View File

@@ -1,26 +0,0 @@
name: Hlint
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
jobs:
hlint:
name: hlint
runs-on: ubuntu-latest
env:
JSON_VERSION: "0.0.7"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Run hlint
run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s -- -r lib/ test/

View File

@@ -1,33 +0,0 @@
name: MkDocs
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
jobs:
mkdocs:
name: mkdocs
runs-on: ubuntu-latest
env:
JSON_VERSION: "0.0.7"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Install mkdocs deps
run: |
sudo apt-get update -y
sudo apt-get install -y python3-pip
sudo pip3 install mkdocs
- name: Run mkdocs
run: |
mkdocs build

View File

@@ -1,428 +1,109 @@
name: Build and release name: Create Release
on: on:
push: push:
branches:
- master
tags: tags:
- 'v*' - 'v*'
pull_request:
branches:
- master
schedule:
- cron: '0 2 * * *'
jobs: jobs:
build-linux: draft_release:
name: Build linux binary name: Draft Release
runs-on: ubuntu-latest
outputs:
upload_url: ${{ steps.create_release.outputs.upload_url }}
steps:
- name: Create Release
id: create_release
uses: actions/create-release@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
tag_name: ${{ github.ref }}
release_name: Release ${{ github.ref }}
body: |
Changes in this Release
- First Change
- Second Change
draft: true
prerelease: false
release-mac:
name: Create Release
needs: draft_release
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.6.2.0 MACOSX_DEPLOYMENT_TARGET: 10.13
JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
strategy: strategy:
fail-fast: true
matrix: matrix:
include: os:
- os: ubuntu-latest - macOS-10.15
ARTIFACT: "i386-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 32
- os: ubuntu-latest
ARTIFACT: "x86_64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 64
steps: steps:
- name: Checkout code - name: Checkout code
uses: actions/checkout@v3 uses: actions/checkout@v2
- uses: haskell/actions/setup@v1.2
with: with:
submodules: 'true' ghc-version: 8.10.7
cabal-version: 3.6.2.0
- if: matrix.ARCH == '32' - name: create ~/.local/bin
name: Run build (32 bit linux) run: mkdir -p "$HOME/.local/bin"
uses: docker://hasufell/i386-alpine-haskell:3.12
with:
args: sh .github/scripts/build.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Alpine
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
- if: matrix.ARCH == '64'
name: Run build (64 bit linux)
uses: docker://hasufell/alpine-haskell:3.12
with:
args: sh .github/scripts/build.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Alpine
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
- if: always()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: artifacts
path: |
./out/*
build-arm:
name: Build ARM binary
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
strategy:
fail-fast: true
matrix:
include:
- os: [self-hosted, Linux, aarch64]
ARTIFACT: "armv7-linux-ghcup"
GHC_VER: 8.10.7
ARCH: ARM
- os: [self-hosted, Linux, aarch64]
ARTIFACT: "aarch64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: ARM64
steps:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux)
with:
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: git config
run: |
git config --global --get-all safe.directory | grep '^\*$' || git config --global --add safe.directory "*"
shell: bash shell: bash
- name: Checkout code - name: Add ~/.local/bin to PATH
uses: actions/checkout@v3 run: echo "$HOME/.local/bin" >> $GITHUB_PATH
with: shell: bash
submodules: 'true'
- if: matrix.ARCH == 'ARM' - name: Update cabal cache
uses: docker://hasufell/arm32v7-ubuntu-haskell:focal run: cabal update
name: Run build (armv7 linux) shell: bash
with:
args: sh .github/scripts/build.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Ubuntu
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
- if: matrix.ARCH == 'ARM64' - name: Install cabal dependencies
uses: docker://hasufell/arm64v8-ubuntu-haskell:focal run: cabal build --only-dependencies --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
name: Run build (aarch64 linux) shell: bash
with:
args: sh .github/scripts/build.sh - name: Build
run: cabal build --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
shell: bash
- name: Install
run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
shell: bash
- name: Strip
run: strip ~/.local/bin/ghcup
shell: bash
- name: Run tests
run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
shell: bash
- name: Install git
run: brew install git
- name: set HOME
run: echo "HOME=$HOME" >> $GITHUB_ENV
shell: bash
- name: Set ASSET_PATH
run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
shell: bash
- name: Upload Release Asset
id: upload-release-asset
uses: actions/upload-release-asset@v1
env: env:
ARTIFACT: ${{ matrix.ARTIFACT }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
ARCH: ${{ matrix.ARCH }} with:
GHC_VER: ${{ matrix.GHC_VER }} upload_url: ${{ needs.draft_release.outputs.upload_url }}
DISTRO: Ubuntu asset_path: ${{ env.ASSET_PATH }}
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }} asset_name: ghcup-${{ matrix.os }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }} asset_content_type: application/octet-stream
S3_HOST: ${{ env.S3_HOST }}
- if: always() - if: always()
name: Upload artifact uses: actions/upload-artifact@v2
uses: actions/upload-artifact@v3
with: with:
name: artifacts name: plan.json
path: | path: ./dist-newstyle/cache/plan.json
./out/*
build-macwin:
name: Build binary (Mac/Win)
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
MACOSX_DEPLOYMENT_TARGET: 10.13
JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
strategy:
fail-fast: false
matrix:
include:
- os: [self-hosted, macOS, aarch64]
ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VER: 9.2.5
ARCH: ARM64
- os: macOS-10.15
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.5
ARCH: 64
- os: windows-latest
ARTIFACT: "x86_64-mingw64-ghcup"
GHC_VER: 8.10.7
ARCH: 64
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Run build (windows/mac)
run: bash .github/scripts/build.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: na
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
HOMEBREW_CHANGE_ARCH_TO_ARM: 1
- if: always()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: artifacts
path: |
./out/*
test-linux:
name: Test linux
needs: "build-linux"
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
JSON_VERSION: "0.0.7"
strategy:
matrix:
include:
- os: ubuntu-latest
ARTIFACT: "i386-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 32
DISTRO: Alpine
- os: ubuntu-latest
ARTIFACT: "x86_64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 64
DISTRO: Alpine
- os: ubuntu-latest
ARTIFACT: "x86_64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 64
DISTRO: Ubuntu
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- if: matrix.ARCH == '32' && matrix.DISTRO == 'Alpine'
name: Run test (32 bit linux Alpine)
uses: docker://hasufell/i386-alpine-haskell:3.12
with:
args: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }}
- if: matrix.ARCH == '64' && matrix.DISTRO == 'Alpine'
name: Run test (64 bit linux Alpine)
uses: docker://hasufell/alpine-haskell:3.12
with:
args: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }}
- if: matrix.DISTRO != 'Alpine'
name: Run test (64 bit linux)
run: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }}
APT_GET: "sudo apt-get"
test-arm:
name: Test ARM
needs: "build-arm"
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
JSON_VERSION: "0.0.7"
strategy:
matrix:
include:
- os: [self-hosted, Linux, aarch64]
ARTIFACT: "armv7-linux-ghcup"
GHC_VER: 8.10.7
ARCH: ARM
DISTRO: Ubuntu
- os: [self-hosted, Linux, aarch64]
ARTIFACT: "aarch64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: ARM64
DISTRO: Ubuntu
steps:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux)
with:
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- if: matrix.ARCH == 'ARM'
uses: docker://hasufell/arm32v7-ubuntu-haskell:focal
name: Run build (armv7 linux)
with:
run: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Ubuntu
- if: matrix.ARCH == 'ARM64'
uses: docker://hasufell/arm64v8-ubuntu-haskell:focal
name: Run build (aarch64 linux)
with:
run: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Ubuntu
test-macwin:
name: Test Mac/Win
needs: "build-macwin"
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
MACOSX_DEPLOYMENT_TARGET: 10.13
JSON_VERSION: "0.0.7"
strategy:
matrix:
include:
- os: [self-hosted, macOS, aarch64]
ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VER: 9.2.5
ARCH: ARM64
DISTRO: na
- os: macOS-10.15
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.5
ARCH: 64
DISTRO: na
- os: windows-latest
ARTIFACT: "x86_64-mingw64-ghcup"
GHC_VER: 8.10.7
ARCH: 64
DISTRO: na
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run test (windows/mac)
run: bash .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }}
HOMEBREW_CHANGE_ARCH_TO_ARM: 1
hls:
name: hls
needs: build-linux
runs-on: ubuntu-latest
env:
GHC_VERSION: "8.10.7"
HLS_TARGET_VERSION: "1.8.0.0"
CABAL_VERSION: "3.6.2.0"
JSON_VERSION: "0.0.7"
ARTIFACT: "x86_64-linux-ghcup"
DISTRO: Ubuntu
ARCH: 64
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run hls build
run: sh .github/scripts/hls.sh
env:
APT_GET: "sudo apt-get"
release:
name: release
needs: ["test-linux", "test-arm", "test-macwin", "hls"]
runs-on: ubuntu-latest
if: startsWith(github.ref, 'refs/tags/v')
steps:
- name: Download artifacts
uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Release
uses: softprops/action-gh-release@v1
with:
draft: true
files: |
./out/*

View File

@@ -1,28 +0,0 @@
name: Shellcheck
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
jobs:
shellcheck:
name: shellcheck
runs-on: ubuntu-latest
env:
JSON_VERSION: "0.0.7"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Run shellcheck
uses: docker://koalaman/shellcheck-alpine
with:
args: shellcheck scripts/bootstrap/bootstrap-haskell

View File

@@ -13,7 +13,7 @@ variables:
# Sequential version number of all cached things. # Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache. # Bump to invalidate GitLab CI cache.
CACHE_REV: 1 CACHE_REV: 0
GIT_SUBMODULE_STRATEGY: recursive GIT_SUBMODULE_STRATEGY: recursive
@@ -125,10 +125,6 @@ variables:
- test/golden - test/golden
- dist-newstyle/cache/ - dist-newstyle/cache/
when: on_failure when: on_failure
cache:
key: ghcup-test-$CACHE_REV
paths:
- cabal-cache
# .test_ghcup_scoop: # .test_ghcup_scoop:
# script: # script:
@@ -140,10 +136,6 @@ variables:
- .debian - .debian
before_script: before_script:
- ./.gitlab/before_script/linux/install_deps.sh - ./.gitlab/before_script/linux/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:linux32: .test_ghcup_version:linux32:
extends: extends:
@@ -151,10 +143,6 @@ variables:
- .alpine:32bit - .alpine:32bit
before_script: before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh - ./.gitlab/before_script/linux/alpine/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:armv7: .test_ghcup_version:armv7:
extends: extends:
@@ -162,10 +150,6 @@ variables:
- .linux:armv7 - .linux:armv7
before_script: before_script:
- ./.gitlab/before_script/linux/install_deps.sh - ./.gitlab/before_script/linux/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:aarch64: .test_ghcup_version:aarch64:
extends: extends:
@@ -173,42 +157,45 @@ variables:
- .linux:aarch64 - .linux:aarch64
before_script: before_script:
- ./.gitlab/before_script/linux/install_deps.sh - ./.gitlab/before_script/linux/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:darwin: .test_ghcup_version:darwin:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
- .darwin - .darwin
- .root_cleanup
before_script: before_script:
- ./.gitlab/before_script/darwin/install_deps.sh - ./.gitlab/before_script/darwin/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:darwin:aarch64: .test_ghcup_version:darwin:aarch64:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
- .darwin:aarch64 - .darwin:aarch64
- .root_cleanup
cache: cache:
key: darwin-brew-$CACHE_REV key: darwin-brew-$CACHE_REV
paths: paths:
- brew_cache - .brew
key: ghcup-test-$CACHE_REV - .brew_cache
paths:
- cabal-cache
before_script: before_script:
# extract brew cache # Install brew locally in the project dir. Packages will also be installed here.
- ./.gitlab/script/ci.sh extract_brew_cache - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew'
- export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
# otherwise we seem to get intel binaries # otherwise we seem to get intel binaries
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
# make sure to not pollute the machine with temp files etc
- mkdir -p $CI_PROJECT_DIR/.brew_cache
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
- mkdir -p $CI_PROJECT_DIR/.brew_logs
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
- mkdir -p /private/tmp/.brew_tmp
- export HOMEBREW_TEMP=/private/tmp/.brew_tmp
# update and install packages # update and install packages
- /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils - brew update
# extract cabal cache - brew install llvm
- ./.gitlab/script/ci.sh extract_cabal_cache - brew install autoconf automake coreutils
script: | script: |
export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang
@@ -218,51 +205,40 @@ variables:
export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib
./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/before_script/darwin/install_deps.sh
./.gitlab/script/ghcup_version.sh ./.gitlab/script/ghcup_version.sh
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- ./.gitlab/script/ci.sh save_brew_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:freebsd12: .test_ghcup_version:freebsd12:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
- .freebsd12 - .freebsd12
- .root_cleanup
before_script: before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh - ./.gitlab/before_script/freebsd/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:freebsd13: .test_ghcup_version:freebsd13:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
- .freebsd13 - .freebsd13
- .root_cleanup
before_script: before_script:
- sudo pkg update - sudo pkg update
- sudo pkg install --yes compat12x-amd64 - sudo pkg install --yes compat12x-amd64
- sudo ln -s libncurses.so.6 /usr/local/lib/libncurses.so.6.2 - sudo ln -s libncurses.so.6 /usr/local/lib/libncurses.so.6.2
- ./.gitlab/before_script/freebsd/install_deps.sh - ./.gitlab/before_script/freebsd/install_deps.sh
- ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
.test_ghcup_version:windows: .test_ghcup_version:windows:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
- .windows - .windows
- .root_cleanup
before_script: before_script:
- set CABAL_DIR="$CI_PROJECT_DIR/cabal"
- bash ./.gitlab/before_script/windows/install_deps.sh - bash ./.gitlab/before_script/windows/install_deps.sh
- bash ./.gitlab/script/ci.sh extract_cabal_cache
after_script:
- bash ./.gitlab/script/ci.sh save_cabal_cache
- bash ./.gitlab/after_script.sh
# .test_ghcup_scoop:windows: # .test_ghcup_scoop:windows:
# extends: # extends:
# - .windows # - .windows
# - .test_ghcup_scoop # - .test_ghcup_scoop
# - .root_cleanup
.release_ghcup: .release_ghcup:
script: script:
@@ -282,12 +258,9 @@ variables:
test:linux:stack: test:linux:stack:
stage: test stage: test
before_script: before_script:
- ./.gitlab/script/ci.sh extract_stack_cache
- ./.gitlab/before_script/linux/install_deps_minimal.sh - ./.gitlab/before_script/linux/install_deps_minimal.sh
script: script:
- ./.gitlab/script/ghcup_stack.sh - ./.gitlab/script/ghcup_stack.sh
after_script:
- ./.gitlab/script/ci.sh save_stack_cache
extends: extends:
- .debian - .debian
needs: [] needs: []
@@ -317,7 +290,6 @@ test:windows:bootstrap_powershell_script:
- "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)" - "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)"
- "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)" - "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)"
- bash ./.gitlab/after_script.sh - bash ./.gitlab/after_script.sh
- bash ./.gitlab/script/ci.sh save_cabal_cache
variables: variables:
GHC_VERSION: "8.10.7" GHC_VERSION: "8.10.7"
CABAL_VERSION: "3.6.2.0" CABAL_VERSION: "3.6.2.0"
@@ -564,17 +536,28 @@ release:darwin:aarch64:
cache: cache:
key: darwin-brew-$CACHE_REV key: darwin-brew-$CACHE_REV
paths: paths:
- brew_cache - .brew
key: ghcup-test-$CACHE_REV - .brew_cache
paths:
- cabal-cache
before_script: before_script:
- ./.gitlab/script/ci.sh extract_brew_cache # Install brew locally in the project dir. Packages will also be installed here.
- ./.gitlab/script/ci.sh extract_cabal_cache - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew'
- export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
# otherwise we seem to get intel binaries # otherwise we seem to get intel binaries
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
# make sure to not pollute the machine with temp files etc
- mkdir -p $CI_PROJECT_DIR/.brew_cache
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
- mkdir -p $CI_PROJECT_DIR/.brew_logs
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
- mkdir -p /private/tmp/.brew_tmp
- export HOMEBREW_TEMP=/private/tmp/.brew_tmp
# update and install packages # update and install packages
- /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils - brew update
- brew install llvm
- brew install autoconf automake
script: | script: |
export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang
@@ -584,9 +567,6 @@ release:darwin:aarch64:
export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib
./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/before_script/darwin/install_deps.sh
./.gitlab/script/ghcup_release.sh ./.gitlab/script/ghcup_release.sh
after_script:
- ./.gitlab/script/ci.sh save_cabal_cache
- ./.gitlab/script/ci.sh save_brew_cache
variables: variables:
ARTIFACT: "aarch64-apple-darwin-ghcup" ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VERSION: "8.10.7" GHC_VERSION: "8.10.7"

View File

@@ -1,23 +1,11 @@
if [ "${OS}" = "WINDOWS" ] ; then if [ "${OS}" = "WINDOWS" ] ; then
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin"
export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp" export TMPDIR="$CI_PROJECT_DIR/tmp"
export CABAL_DIR="$CI_PROJECT_DIR/cabal"
export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache"
export STACK_ROOT="$CI_PROJECT_DIR/stack"
export STACK_CACHE="$CI_PROJECT_DIR/stack-cache"
export BREW_DIR="$CI_PROJECT_DIR/.brew_cache"
export BREW_CACHE="$CI_PROJECT_DIR/brew-cache"
else else
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin"
export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp" export TMPDIR="$CI_PROJECT_DIR/tmp"
export CABAL_DIR="$CI_PROJECT_DIR/cabal"
export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache"
export STACK_ROOT="$CI_PROJECT_DIR/stack"
export STACK_CACHE="$CI_PROJECT_DIR/stack-cache"
export BREW_DIR="$CI_PROJECT_DIR/.brew_cache"
export BREW_CACHE="$CI_PROJECT_DIR/brew-cache"
fi fi

View File

@@ -1,19 +0,0 @@
#!/usr/bin/env bash
set -Eeuxo pipefail
# Install brew locally in the project dir. Packages will also be installed here.
[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew
export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
# make sure to not pollute the machine with temp files etc
mkdir -p $CI_PROJECT_DIR/.brew_cache
export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
mkdir -p $CI_PROJECT_DIR/.brew_logs
export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
mkdir -p /private/tmp/.brew_tmp
export HOMEBREW_TEMP=/private/tmp/.brew_tmp
# update and install packages
brew update
brew install ${1+"$@"}

View File

@@ -1,70 +0,0 @@
#!/usr/bin/env bash
set -Eeuo pipefail
TOP="$( cd "$(dirname "$0")" ; pwd -P )"
. "${TOP}/../ghcup_env"
function save_cabal_cache () {
echo "Storing cabal cache from $CABAL_DIR to $CABAL_CACHE..."
rm -Rf "$CABAL_CACHE"
mkdir -p "$CABAL_CACHE"
if [ -d "$CABAL_DIR" ]; then
cp -Rf "$CABAL_DIR" "$CABAL_CACHE/"
fi
}
function extract_cabal_cache () {
if [ -d "$CABAL_CACHE" ]; then
echo "Extracting cabal cache from $CABAL_CACHE to $CABAL_DIR..."
mkdir -p "$CABAL_DIR"
cp -Rf "$CABAL_CACHE"/* "$CABAL_DIR"
fi
}
function save_stack_cache () {
echo "Storing stack cache from $STACK_ROOT to $STACK_CACHE..."
rm -Rf "$STACK_CACHE"
mkdir -p "$STACK_CACHE"
if [ -d "$STACK_ROOT" ]; then
cp -Rf "$STACK_DIR" "$STACK_CACHE"
fi
}
function extract_stack_cache () {
if [ -d "$STACK_CACHE" ]; then
echo "Extracting stack cache from $STACK_CACHE to $STACK_ROOT..."
mkdir -p "$STACK_ROOT"
cp -Rf "$STACK_CACHE"/* "$STACK_ROOT"
fi
}
function save_brew_cache () {
echo "Storing brew cache from $BREW_DIR to $BREW_CACHE..."
rm -Rf "$BREW_CACHE"
mkdir -p "$BREW_CACHE"
if [ -d "$BREW_DIR" ]; then
cp -Rf "$BREW_DIR" "$BREW_CACHE"
fi
}
function extract_brew_cache () {
if [ -d "$BREW_CACHE" ]; then
echo "Extracting stack cache from $BREW_CACHE to $BREW_DIR..."
mkdir -p "$BREW_DIR"
cp -Rf "$BREW_CACHE"/* "$BREW_DIR"
fi
}
case $1 in
extract_cabal_cache) extract_cabal_cache ;;
save_cabal_cache) save_cabal_cache ;;
extract_stack_cache) extract_stack_cache ;;
save_stack_cache) save_stack_cache ;;
extract_brew_cache) extract_brew_cache ;;
save_brew_cache) save_brew_cache ;;
*) echo "unknown mode $1" ; exit 11 ;;
esac

View File

@@ -6,10 +6,20 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always git describe --always
### build ### build
ecabal update
export BOOTSTRAP_HASKELL_NONINTERACTIVE=yes export BOOTSTRAP_HASKELL_NONINTERACTIVE=yes
export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION
export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION

View File

@@ -1,4 +1,4 @@
#!/usr/bin/env bash #!/bin/sh
set -eux set -eux
@@ -8,7 +8,6 @@ mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd) CI_PROJECT_DIR=$(pwd)
ecabal() { ecabal() {
cabal "$@" cabal "$@"
} }
@@ -35,8 +34,6 @@ git describe --always
### build ### build
rm -rf "${GHCUP_DIR}"/share
ecabal update ecabal update
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
@@ -97,23 +94,16 @@ rm -rf "${GHCUP_DIR}"
eghcup --numeric-version eghcup --numeric-version
eghcup install ghc ${GHC_VERSION} eghcup install ghc ${GHC_VERSION}
eghcup unset ghc ${GHC_VERSION} [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})" [ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ]
[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
[ "`ghcup run --ghc ${GHC_VERSION} -- ghc -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" = "`$(ghcup whereis ghc ${GHC_VERSION}) -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" ]
eghcup set ghc ${GHC_VERSION} eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION} eghcup install cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
eghcup unset cabal eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit 1 || echo yes "$GHCUP_BIN"/cabal --version && exit || echo yes
# make sure no cabal is set when running 'ghcup run' to check that PATH propagages properly
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
eghcup set cabal ${CABAL_VERSION} eghcup set cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] [ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ]
if [ "${OS}" != "FREEBSD" ] ; then if [ "${OS}" != "FREEBSD" ] ; then
if [ "${ARCH}" = "64" ] ; then if [ "${ARCH}" = "64" ] ; then
@@ -180,14 +170,12 @@ else
eghcup set ${GHC_VERSION} eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ] [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup unset ghc eghcup unset ghc
"$GHCUP_BIN"/ghc --numeric-version && exit 1 || echo yes "$GHCUP_BIN"/ghc --numeric-version && exit || echo yes
eghcup set ${GHC_VERSION} eghcup set ${GHC_VERSION}
eghcup --offline rm 8.10.3 eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ] [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
ls -lah "$GHCUP_BIN"
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls eghcup install hls
$(eghcup whereis hls) --version $(eghcup whereis hls) --version
@@ -199,12 +187,12 @@ else
eghcup install hls eghcup install hls
haskell-language-server-wrapper --version haskell-language-server-wrapper --version
eghcup unset hls eghcup unset hls
"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit 1 || echo yes "$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes
eghcup install stack eghcup install stack
stack --version stack --version
eghcup unset stack eghcup unset hls
"$GHCUP_BIN"/stack --version && exit 1 || echo yes "$GHCUP_BIN"/stack --version && exit || echo yes
fi fi
fi fi
fi fi
@@ -222,13 +210,11 @@ eghcup rm $(ghc --numeric-version)
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116 # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
if [ "${OS}" = "LINUX" ] ; then if [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then if [ "${ARCH}" = "64" ] ; then
eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4 eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
eghcup rm cabal 3.4.0.0-rc4 eghcup rm cabal 3.4.0.0-rc4
fi fi
fi fi
eghcup gc -c
sha_sum() { sha_sum() {
if [ "${OS}" = "FREEBSD" ] ; then if [ "${OS}" = "FREEBSD" ] ; then
sha256 "$@" sha256 "$@"
@@ -276,39 +262,13 @@ if [ "${ARCH}" = "64" ] ; then
eghcup install hls -i "$(pwd)/isolated" 1.3.0 eghcup install hls -i "$(pwd)/isolated" 1.3.0
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] || [ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] ||
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ] [ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ]
# test that isolated installs don't clean up target directory
cat <<EOF > "${GHCUP_BIN}/gmake"
#!/bin/bash
exit 1
EOF
chmod +x "${GHCUP_BIN}/gmake"
mkdir isolated_tainted/
touch isolated_tainted/lol
! eghcup install ghc -i "$(pwd)/isolated_tainted" 8.10.5 --force
[ -e "$(pwd)/isolated_tainted/lol" ]
rm "${GHCUP_BIN}/gmake"
fi fi
fi fi
eghcup upgrade eghcup upgrade
eghcup upgrade -f eghcup upgrade -f
# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
mkdir no_nuke/
mkdir no_nuke/bar
echo 'foo' > no_nuke/file
echo 'bar' > no_nuke/bar/file
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
# nuke # nuke
eghcup nuke eghcup nuke
[ ! -e "${GHCUP_DIR}" ] [ ! -e "${GHCUP_DIR}" ]
# make sure nuke doesn't resolve symlinks
[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]

View File

@@ -20,7 +20,6 @@
- ignore: {name: "Avoid lambda"} - ignore: {name: "Avoid lambda"}
- ignore: {name: "Use uncurry"} - ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"} - ignore: {name: "Use replicateM"}
- ignore: {name: "Use unless"}
- ignore: {name: "Redundant irrefutable pattern"} - ignore: {name: "Redundant irrefutable pattern"}

View File

@@ -1,58 +1,6 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.18.1 -- 2022-08-06 ## 0.1.17.6 -- ????-??-??
* fix sdist and unbreak hackage, wrt [#399](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/399)
## 0.1.18.0 -- 2022-07-30
* Fix tui set wrt [#266](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/266) by Arjun Kathuria
- Ask the user to install the tool via prompt when setting an non-installed version
* improvements to safe (un-)installations
- bindists that don't support `make DESTDIR=/some/tmp/dir install` are now unsupported
- installed GHC files are now recorded to avoid use of `removePathForcibly`
- internally uses a newtype wrapper for user-input paths and restrict destructive operations to validated paths
* Add `--disable-ld-override` for darwin bindists wrt #391
* Allow passing bindist configure args wrt #377
* use of `TMPDIR` is dropped... now uses an internal tmp dir `~/.ghcup/tmp`
* improvements to error handling and warnings
* Require --isolate to have an absolute directory, fixes #367
* Fix mingw PATH handling wrt #371
* Add --mingw-path switch to `ghcup run`
* Fix `ghcup run` on windows, fixes #375
* Improve `ghcup compile <hls|ghc>`
- short hashes now work
- print the long hash in addition to the detected version
* Improve `ghcup compile hls`
- add `--git-describe-version` switch as an alternative to `--overwrite-version`
- Allow to build HLS from hackage (now is the default)
- Allow to run 'cabal update' automatically before the HLS build
- Fix parser and completer for 'ghcup compile hls --version'
* Improve `ghcup compile ghc`
- Allow to build from arbitrary GHC source dists
## 0.1.17.10 -- 2022-05-12
* windows hotfix (hackage-only release)
## 0.1.17.9 -- 2022-05-12
* broken sdist (hackage-only release)
## 0.1.17.8 -- 2022-05-11
* Fix a serious (but hard to trigger) bug when combining `--isolate <DIR>` with `--force`, please make sure to upgrade or avoid `--force`
* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361)
* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353)
* Re-enable upgrade functionality for all configurations wrt [MR #250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250) and [VSCode haskell issue #601](https://github.com/haskell/vscode-haskell/issues/601)
* Fix `ghcup run --ghc 8.10` (for short versions) wrt [#360](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/360)
- this also introduces a `--quick` switch for `ghcup run`
## 0.1.17.7 -- 2022-04-21
* Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345)
## 0.1.17.6 -- 2022-03-18
* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242) * Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324) * Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
@@ -62,7 +10,6 @@
* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330) * Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)
* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed` * Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`
* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328) * Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)
* Fix max path issues on windows with `ghcup run`
## 0.1.17.5 -- 2022-02-26 ## 0.1.17.5 -- 2022-02-26

View File

@@ -6,7 +6,7 @@
[![Join the chat at https://gitter.im/haskell/ghcup](https://badges.gitter.im/haskell/ghcup.svg)](https://gitter.im/haskell/ghcup?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Join the chat at https://gitter.im/haskell/ghcup](https://badges.gitter.im/haskell/ghcup.svg)](https://gitter.im/haskell/ghcup?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
<a href="https://opencollective.com/ghcup#category-CONTRIBUTE"><img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" alt="Donate" width="150"></a> <a href="https://opencollective.com/ghcup#category-CONTRIBUTE"><img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" alt="Donate" width="150"></a>
GHCup is the main installer for the general purpose language [Haskell](https://www.haskell.org/). GHCup is an installer for the general purpose language [Haskell](https://www.haskell.org/).
Visit the [documentation](https://www.haskell.org/ghcup/) for installation instructions. Visit the [documentation](https://www.haskell.org/ghcup/) for installation instructions.

View File

@@ -13,11 +13,9 @@ import GHCup.Errors
import GHCup.Types.Optics ( getDirs ) import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude ( decUTF8Safe ) import GHCup.Utils.Logger
import GHCup.Prelude.File import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Prelude.Logger import GHCup.Utils.File
import GHCup.Prelude.Process
import GHCup.Prompts
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@@ -46,6 +44,7 @@ import Data.Vector ( Vector
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Directory ( canonicalizePath )
import System.FilePath import System.FilePath
import System.Exit import System.Exit
import System.IO.Unsafe import System.IO.Unsafe
@@ -53,8 +52,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy as L
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
import qualified Data.Vector as V import qualified Data.Vector as V
import System.Environment (getExecutablePath) import System.Environment (getExecutablePath)
@@ -101,7 +98,7 @@ keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt) [ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install') , (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del') , (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set') , (bSet, const "Set" , withIOAction ((liftIO .) . set'))
, (bChangelog, const "ChangeLog", withIOAction changelog') , (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions , ( bShowAllVersions
, \BrickSettings {..} -> , \BrickSettings {..} ->
@@ -440,9 +437,6 @@ install' _ (_, ListResult {..}) = do
, TarDirDoesNotExist , TarDirDoesNotExist
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
] ]
run (do run (do
@@ -452,19 +446,19 @@ install' _ (_, ListResult {..}) = do
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce) liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)
) )
>>= \case >>= \case
VRight (vi, Dirs{..}, Just ce) -> do VRight (vi, Dirs{..}, Just ce) -> do
@@ -489,12 +483,9 @@ install' _ (_, ListResult {..}) = do
<> "Also check the logs in ~/.ghcup/logs" <> "Also check the logs in ~/.ghcup/logs"
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
=> BrickState set' _ (_, ListResult {..}) = do
-> (Int, ListResult) settings <- readIORef settings'
-> m (Either String ())
set' bs input@(_, ListResult {..}) = do
settings <- liftIO $ readIORef settings'
let run = let run =
flip runReaderT settings flip runReaderT settings
@@ -510,28 +501,7 @@ set' bs input@(_, ListResult {..}) = do
) )
>>= \case >>= \case
VRight _ -> pure $ Right () VRight _ -> pure $ Right ()
VLeft e -> case e of VLeft e -> pure $ Left (prettyShow e)
(V (NotInstalled tool _)) -> do
promptAnswer <- getUserPromptResponse userPrompt
case promptAnswer of
PromptYes -> do
res <- install' bs input
case res of
(Left err) -> pure $ Left err
(Right _) -> do
logInfo "Setting now..."
set' bs input
PromptNo -> pure $ Left (prettyShow e)
where
userPrompt = L.toStrict . B.toLazyText . B.fromString $
"This Version of "
<> show tool
<> " you are trying to set is not installed.\n"
<> "Would you like to install it first? [Y/N]: "
_ -> pure $ Left (prettyShow e)
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
@@ -541,7 +511,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = runE @'[NotInstalled, UninstallFailed] let run = runE @'[NotInstalled]
run (do run (do
let vi = getVersionInfo lVer lTool dls let vi = getVersionInfo lVer lTool dls

View File

@@ -74,7 +74,6 @@ data Options = Options
optVerbose :: Maybe Bool optVerbose :: Maybe Bool
, optCache :: Maybe Bool , optCache :: Maybe Bool
, optMetaCache :: Maybe Integer , optMetaCache :: Maybe Integer
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
@@ -97,7 +96,7 @@ data Command
| Config ConfigCommand | Config ConfigCommand
| Whereis WhereisOptions WhereisCommand | Whereis WhereisOptions WhereisCommand
#ifndef DISABLE_UPGRADE #ifndef DISABLE_UPGRADE
| Upgrade UpgradeOpts Bool Bool | Upgrade UpgradeOpts Bool
#endif #endif
| ToolRequirements ToolReqOpts | ToolRequirements ToolReqOpts
| ChangeLog ChangeLogOptions | ChangeLog ChangeLogOptions
@@ -117,16 +116,6 @@ opts =
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)") <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)") <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal)) <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
<*> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> optional <*> optional
(option (option
(eitherReader parseUri) (eitherReader parseUri)
@@ -233,18 +222,18 @@ com =
(info (List <$> listOpts <**> helper) (info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools") (progDesc "Show available GHCs and other tools")
) )
#ifndef DISABLE_UPGRADE
<> command <> command
"upgrade" "upgrade"
(info (info
( (Upgrade <$> upgradeOptsP <*> switch ( (Upgrade <$> upgradeOptsP <*> switch
(short 'f' <> long "force" <> help "Force update") (short 'f' <> long "force" <> help "Force update")
<*> switch
(long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")
) )
<**> helper <**> helper
) )
(progDesc "Upgrade ghcup") (progDesc "Upgrade ghcup")
) )
#endif
<> command <> command
"compile" "compile"
( Compile ( Compile

View File

@@ -12,11 +12,9 @@ module GHCup.OptParse.ChangeLog where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Logger
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Prelude import GHCup.Utils.String.QQ
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import GHCup.Prelude.Process (exec)
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -36,6 +34,8 @@ import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import Data.Versions import Data.Versions
import URI.ByteString (serializeURIRef') import URI.ByteString (serializeURIRef')
import GHCup.Utils.Prelude
import GHCup.Utils.File (exec)
import Data.Char (toLower) import Data.Char (toLower)
@@ -58,7 +58,7 @@ data ChangeLogOptions = ChangeLogOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
changelogP :: Parser ChangeLogOptions changelogP :: Parser ChangeLogOptions
changelogP = changelogP =
(\x y -> ChangeLogOptions x y) (\x y -> ChangeLogOptions x y)
@@ -71,16 +71,15 @@ changelogP =
"cabal" -> Right Cabal "cabal" -> Right Cabal
"ghcup" -> Right GHCup "ghcup" -> Right GHCup
"stack" -> Right Stack "stack" -> Right Stack
"hls" -> Right HLS
e -> Left e e -> Left e
) )
) )
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)" "Open changelog for given tool (default: ghc)"
<> completer toolCompleter <> completer toolCompleter
) )
) )
<*> optional (toolVersionTagArgument Nothing Nothing) <*> optional (toolVersionArgument Nothing Nothing)
@@ -117,8 +116,7 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
ver' = maybe ver' = maybe
(Right Latest) (Right Latest)
(\case (\case
GHCVersion tv -> Left (_tvVersion tv) ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion
ToolVersion tv -> Left tv
ToolTag t -> Right t ToolTag t -> Right t
) )
clToolVer clToolVer

View File

@@ -16,10 +16,10 @@ import GHCup.Platform
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude import GHCup.Utils.File
import GHCup.Prelude.Process import GHCup.Utils.Logger
import GHCup.Prelude.Logger import GHCup.Utils.MegaParsec
import GHCup.Prelude.MegaParsec import GHCup.Utils.Prelude
import Control.DeepSeq import Control.DeepSeq
import Control.Concurrent import Control.Concurrent
@@ -52,6 +52,7 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import Safe import Safe
import System.Directory
import System.Process ( readProcess ) import System.Process ( readProcess )
import System.FilePath import System.FilePath
import Text.HTML.TagSoup hiding ( Tag ) import Text.HTML.TagSoup hiding ( Tag )
@@ -70,24 +71,20 @@ import Control.Exception (evaluate)
--[ Types ]-- --[ Types ]--
------------- -------------
data ToolVersion = GHCVersion GHCTargetVersion data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolVersion Version
| ToolTag Tag | ToolTag Tag
-- a superset of ToolVersion -- a superset of ToolVersion
data SetToolVersion = SetGHCVersion GHCTargetVersion data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolVersion Version
| SetToolTag Tag | SetToolTag Tag
| SetRecommended | SetRecommended
| SetNext | SetNext
prettyToolVer :: ToolVersion -> String prettyToolVer :: ToolVersion -> String
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
prettyToolVer (ToolTag t) = show t prettyToolVer (ToolTag t) = show t
toSetToolVer :: Maybe ToolVersion -> SetToolVersion toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer Nothing = SetRecommended toSetToolVer Nothing = SetRecommended
@@ -100,9 +97,10 @@ toSetToolVer Nothing = SetRecommended
-------------- --------------
toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion -- | same as toolVersionParser, except as an argument.
toolVersionTagArgument criteria tool = toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
argument (eitherReader (parser tool)) toolVersionArgument criteria tool =
argument (eitherReader toolVersionEither)
(metavar (mv tool) (metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) []) <> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool) <> foldMap (completer . versionCompleter criteria) tool)
@@ -111,19 +109,20 @@ toolVersionTagArgument criteria tool =
mv (Just HLS) = "HLS_VERSION|TAG" mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG" mv _ = "VERSION|TAG"
parser (Just GHC) = ghcVersionTagEither
parser Nothing = ghcVersionTagEither
parser _ = toolVersionTagEither
versionParser :: Parser GHCTargetVersion
versionParser = option
(eitherReader tVersionEither)
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack)) (eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148 -- https://github.com/pcapriotti/optparse-applicative/issues/148
@@ -228,19 +227,13 @@ absolutePathParser f = case isValid f && isAbsolute f of
False -> Left "Please enter a valid absolute filepath." False -> Left "Please enter a valid absolute filepath."
isolateParser :: FilePath -> Either String FilePath isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f && isAbsolute f of isolateParser f = case isValid f of
True -> Right $ normalise f True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir." False -> Left "Please enter a valid filepath for isolate dir."
-- this accepts cross prefix toolVersionEither :: String -> Either String ToolVersion
ghcVersionTagEither :: String -> Either String ToolVersion toolVersionEither s' =
ghcVersionTagEither s' = second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
-- this ignores cross prefix
toolVersionTagEither :: String -> Either String ToolVersion
toolVersionTagEither s' =
second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
tagEither :: String -> Either String Tag tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of tagEither s' = case fmap toLower s' of
@@ -252,14 +245,10 @@ tagEither s' = case fmap toLower s' of
other -> Left $ "Unknown tag " <> other other -> Left $ "Unknown tag " <> other
ghcVersionEither :: String -> Either String GHCTargetVersion tVersionEither :: String -> Either String GHCTargetVersion
ghcVersionEither = tVersionEither =
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
toolVersionEither :: String -> Either String Version
toolVersionEither =
first (const "Not a valid version") . MP.parse version' "" . T.pack
toolParser :: String -> Either String Tool toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc" = Right GHC toolParser s' | t == T.pack "ghc" = Right GHC
@@ -452,11 +441,9 @@ tagCompleter tool add = listIOCompleter $ do
pure $ nub $ (add ++) $ fmap tagToString allTags pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
versionCompleter' :: Maybe ListCriteria -> Tool -> (Version -> Bool) -> Completer versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter' criteria tool filter' = listIOCompleter $ do versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
@@ -485,7 +472,7 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
runEnv = flip runReaderT appState runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions return $ T.unpack . prettyVer . lVer <$> installedVersions
toolDlCompleter :: Tool -> Completer toolDlCompleter :: Tool -> Completer
@@ -677,7 +664,7 @@ fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool bimap mkTVer Just <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
@@ -689,18 +676,6 @@ fromVersion' (SetGHCVersion v) tool = do
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi') pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls
case pvp $ prettyVer v of -- need to be strict here
Left _ -> pure (mkTVer v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ ""
when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mempty v', Just vi')
Nothing -> pure (mkTVer v, vi)
fromVersion' (SetToolTag Latest) tool = do fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool

View File

@@ -12,15 +12,14 @@ module GHCup.OptParse.Compile where
import GHCup import GHCup
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
import GHCup.Errors import GHCup.Errors
import GHCup.Utils.File
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -32,8 +31,7 @@ import Control.Monad.Trans.Resource
import Data.Bifunctor import Data.Bifunctor
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Data.Versions ( Version, prettyVer, version, pvp ) import Data.Versions ( Version, prettyVer, version )
import qualified Data.Versions as V
import Data.Text ( Text ) import Data.Text ( Text )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
@@ -44,7 +42,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser ) import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask, displayException) import Control.Exception.Safe (MonadMask)
import System.FilePath (isPathSeparator) import System.FilePath (isPathSeparator)
import Text.Read (readEither) import Text.Read (readEither)
@@ -67,7 +65,7 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: GHC.GHCVer Version { targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version FilePath , bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe FilePath , buildConfig :: Maybe FilePath
@@ -81,13 +79,11 @@ data GHCCompileOptions = GHCCompileOptions
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
} }
data HLSCompileOptions = HLSCompileOptions data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: HLS.HLSVer { targetHLS :: Either Version GitBranch
, jobs :: Maybe Int , jobs :: Maybe Int
, setCompile :: Bool , setCompile :: Bool
, updateCabal :: Bool , ovewrwiteVer :: Maybe Version
, ovewrwiteVer :: Either Bool Version
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, cabalProject :: Maybe (Either FilePath URI) , cabalProject :: Maybe (Either FilePath URI)
, cabalProjectLocal :: Maybe URI , cabalProjectLocal :: Maybe URI
@@ -103,7 +99,7 @@ data HLSCompileOptions = HLSCompileOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
compileP :: Parser CompileCommand compileP :: Parser CompileCommand
compileP = subparser compileP = subparser
( command ( command
@@ -150,22 +146,20 @@ Examples:
compileHLSFooter = [s|Discussion: compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version. Compiles and installs the specified HLS version.
The --ghc arguments are necessary to specify which GHC version to build for/against. The last argument is a list of GHC versions to compile for.
These need to be available in PATH prior to compilation. These need to be available in PATH prior to compilation.
Examples: Examples:
# compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build # compile 1.4.0 for ghc 8.10.5 and 8.10.7
ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
# compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state # compile from master for ghc 8.10.7, linking everything dynamically
ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s') ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
# compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]
ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts = ghcCompileOpts =
GHCCompileOptions GHCCompileOptions
<$> ((GHC.SourceDist <$> option <$> ((Left <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
@@ -174,7 +168,7 @@ ghcCompileOpts =
<> (completer $ versionCompleter Nothing GHC) <> (completer $ versionCompleter Nothing GHC)
) )
) <|> ) <|>
(GHC.GitDist <$> (GitBranch <$> option (Right <$> (GitBranch <$> option
str str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from" "The git commit/branch/ref to build from"
@@ -183,18 +177,7 @@ ghcCompileOpts =
short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)" short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
<> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"]) <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
)) ))
)) )))
<|>
(
GHC.RemoteDist <$> (option
(eitherReader uriParser)
(long "remote-source-dist" <> metavar "URI" <> help
"URI (https/http/file) to a GHC source distribution"
<> completer fileUri
)
)
)
)
<*> option <*> option
(eitherReader (eitherReader
(\x -> (\x ->
@@ -250,7 +233,7 @@ ghcCompileOpts =
"Build cross-compiler for this platform" "Build cross-compiler for this platform"
) )
) )
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)")) <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install")) <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
<*> optional <*> optional
(option (option
@@ -286,46 +269,24 @@ ghcCompileOpts =
hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts :: Parser HLSCompileOptions
hlsCompileOpts = hlsCompileOpts =
HLSCompileOptions HLSCompileOptions
<$> ((HLS.HackageDist <$> option <$> ((Left <$> option
(eitherReader (eitherReader
((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The version to compile (pulled from hackage)" "The tool version to compile"
<> (completer $ versionCompleter' Nothing HLS (either (const False) (const True) . V.pvp . V.prettyVer))
)
)
<|>
(HLS.GitDist <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
<> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
))
))
<|>
(HLS.SourceDist <$> (option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(long "source-dist" <> metavar "VERSION" <> help
"The version to compile (pulled from packaged git sources)"
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter Nothing HLS)
) )
) <|>
(Right <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
<> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
)) ))
<|> )))
(
HLS.RemoteDist <$> (option
(eitherReader uriParser)
(long "remote-source-dist" <> metavar "URI" <> help
"URI (https/http/file) to a HLS source distribution"
<> completer fileUri
)
)
)
)
<*> optional <*> optional
(option (option
(eitherReader (readEither @Int)) (eitherReader (readEither @Int))
@@ -335,10 +296,8 @@ hlsCompileOpts =
) )
) )
<*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install")) <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
<*> switch (long "cabal-update" <> help "Run 'cabal update' before the build") <*> optional
<*> (option
(
(Right <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
@@ -347,14 +306,6 @@ hlsCompileOpts =
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter Nothing HLS)
) )
) )
<|>
(Left <$> (switch
(long "git-describe-version"
<> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
)
)
)
)
<*> optional <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)
@@ -401,7 +352,7 @@ hlsCompileOpts =
) )
) )
<*> some ( <*> some (
option (eitherReader ghcVersionTagEither) option (eitherReader toolVersionEither)
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)" ( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> completer (versionCompleter Nothing GHC)) <> completer (versionCompleter Nothing GHC))
@@ -437,8 +388,6 @@ type GHCEffects = '[ AlreadyInstalled
, ProcessError , ProcessError
, CopyError , CopyError
, BuildFailed , BuildFailed
, UninstallFailed
, MergeFileTreeError
] ]
type HLSEffects = '[ AlreadyInstalled type HLSEffects = '[ AlreadyInstalled
, BuildFailed , BuildFailed
@@ -457,8 +406,6 @@ type HLSEffects = '[ AlreadyInstalled
, NotInstalled , NotInstalled
, DirNotEmpty , DirNotEmpty
, ArchiveResult , ArchiveResult
, UninstallFailed
, MergeFileTreeError
] ]
@@ -507,7 +454,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
(CompileHLS HLSCompileOptions { .. }) -> do (CompileHLS HLSCompileOptions { .. }) -> do
runCompileHLS runAppState (do runCompileHLS runAppState (do
case targetHLS of case targetHLS of
HLS.SourceDist targetVer -> do Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
@@ -515,17 +462,16 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure () Right _ -> pure ()
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ compileHLS targetVer <- liftE $ compileHLS
targetHLS targetHLS
ghcs ghcs
jobs jobs
ovewrwiteVer ovewrwiteVer
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
cabalProject cabalProject
cabalProjectLocal cabalProjectLocal
updateCabal
patches patches
cabalArgs cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -546,7 +492,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case keepDirs settings of case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " "Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <> <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9 pure $ ExitFailure 9
@@ -559,7 +505,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
(CompileGHC GHCCompileOptions {..}) -> (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do runCompileGHC runAppState (do
case targetGhc of case targetGhc of
GHC.SourceDist targetVer -> do Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
@@ -567,12 +513,9 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure () Right _ -> pure ()
targetVer <- liftE $ compileGHC targetVer <- liftE $ compileGHC
((\case (first (GHCTargetVersion crossTarget) targetGhc)
GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
ovewrwiteVer ovewrwiteVer
bootstrapGhc bootstrapGhc
jobs jobs
@@ -581,7 +524,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
addConfArgs addConfArgs
buildFlavour buildFlavour
hadrian hadrian
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
@@ -598,17 +541,17 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall" "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $ runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty." "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " "Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <> <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9 pure $ ExitFailure 9

View File

@@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExplicitForAll #-}
module GHCup.OptParse.Config where module GHCup.OptParse.Config where
@@ -14,9 +15,9 @@ module GHCup.OptParse.Config where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude import GHCup.Utils.Prelude
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
import GHCup.OptParse.Common import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
@@ -131,8 +132,7 @@ updateSettings UserSettings{..} Settings{..} =
urlSource' = fromMaybe urlSource uUrlSource urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'

View File

@@ -17,10 +17,9 @@ import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Version import GHCup.Version
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Prelude import GHCup.Utils.Logger
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -37,6 +36,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
import GHCup.Utils.File
import Language.Haskell.TH import Language.Haskell.TH

View File

@@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -56,26 +56,26 @@ data GCOptions = GCOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
gcP :: Parser GCOptions gcP :: Parser GCOptions
gcP = gcP =
GCOptions GCOptions
<$> <$>
switch switch
(short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
<*> <*>
switch switch
(short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
<*> <*>
switch switch
(short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
<*> <*>
switch switch
(short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
<*> <*>
switch switch
(short 'c' <> long "cache" <> help "GC the GHCup cache") (short 'c' <> long "cache" <> help "GC the GHCup cache")
<*> <*>
switch switch
(short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
@@ -98,7 +98,7 @@ gcFooter = [s|Discussion:
--------------------------- ---------------------------
type GCEffects = '[ NotInstalled, UninstallFailed ] type GCEffects = '[ NotInstalled ]
runGC :: MonadUnliftIO m runGC :: MonadUnliftIO m
@@ -129,7 +129,7 @@ gc :: ( Monad m
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
gc GCOptions{..} runAppState runLogger = runGC runAppState (do gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC (liftE rmOldGHC) when gcOldGHC rmOldGHC
lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir lift $ when gcShareDir rmShareDir
liftE $ when gcHLSNoGHC rmHLSNoGHC liftE $ when gcHLSNoGHC rmHLSNoGHC

View File

@@ -7,7 +7,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.OptParse.Install where module GHCup.OptParse.Install where
@@ -19,10 +18,8 @@ import GHCup.OptParse.Common
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Utils.Dirs import GHCup.Utils.Logger
import GHCup.Prelude import GHCup.Utils.String.QQ
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import Codec.Archive import Codec.Archive
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
@@ -33,6 +30,7 @@ import Control.Monad.Trans.Resource
import Data.Either import Data.Either
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
@@ -66,11 +64,11 @@ data InstallCommand = InstallGHC InstallOptions
data InstallOptions = InstallOptions data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI , instBindist :: Maybe URI
, instSet :: Bool , instSet :: Bool
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, forceInstall :: Bool , forceInstall :: Bool
, addConfArgs :: [T.Text]
} }
@@ -170,13 +168,23 @@ Examples:
ghcup install ghc 8.10.2 ghcup install ghc 8.10.2
# install GHC head fedora bindist # install GHC head fedora bindist
ghcup install ghc -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head|] ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
installOpts :: Maybe Tool -> Parser InstallOptions installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool = installOpts tool =
(\(u, v) b is f -> InstallOptions v u b is f) (\p (u, v) b is f -> InstallOptions v p u b is f)
<$> ( ( (,) <$> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> ( ( (,)
<$> optional <$> optional
(option (option
(eitherReader uriParser) (eitherReader uriParser)
@@ -185,7 +193,7 @@ installOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool)) <> completer (toolDlCompleter (fromMaybe GHC tool))
) )
) )
<*> (Just <$> toolVersionTagArgument Nothing tool) <*> (Just <$> toolVersionArgument Nothing tool)
) )
<|> pure (Nothing, Nothing) <|> pure (Nothing, Nothing)
) )
@@ -202,14 +210,13 @@ installOpts tool =
) )
) )
<*> switch <*> switch
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)") (short 'f' <> long "force" <> help "Force install")
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
where where
setDefault = case tool of setDefault = case tool of
Nothing -> False Nothing -> False
Just GHC -> False Just GHC -> False
Just _ -> True Just _ -> True
@@ -250,50 +257,116 @@ type InstallEffects = '[ AlreadyInstalled
, NoToolVersionSet , NoToolVersionSet
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, UninstallFailed
, MergeFileTreeError , (AlreadyInstalled, ())
, InstallSetError , (UnknownArchive, ())
, (ArchiveResult, ())
, (FileDoesNotExistError, ())
, (CopyError, ())
, (NotInstalled, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (NotInstalled, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())
, (GPGError, ())
, (DownloadFailed, ())
, (TarDirDoesNotExist, ())
, (NextVerNotFound, ())
, (NoToolVersionSet, ())
, (FileAlreadyExistsError, ())
, (ProcessError, ())
, (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled)
, (ArchiveResult, NotInstalled)
, (FileDoesNotExistError, NotInstalled)
, (CopyError, NotInstalled)
, (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (NotInstalled, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
, (GPGError, NotInstalled)
, (DownloadFailed, NotInstalled)
, (TarDirDoesNotExist, NotInstalled)
, (NextVerNotFound, NotInstalled)
, (NoToolVersionSet, NotInstalled)
, (FileAlreadyExistsError, NotInstalled)
, (ProcessError, NotInstalled)
, ((), NotInstalled)
] ]
runInstTool :: AppState runInstTool :: AppState
-> Maybe PlatformRequest
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a -> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallEffects a) -> IO (VEither InstallEffects a)
runInstTool appstate' = runInstTool appstate' mInstPlatform =
flip runReaderT appstate' flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT . runResourceT
. runE . runE
@InstallEffects @InstallEffects
type InstallGHCEffects = '[ AlreadyInstalled type InstallGHCEffects = '[ TagNotFound
, ArchiveResult
, BuildFailed
, CopyError
, DigestError
, DirNotEmpty
, DownloadFailed
, FileAlreadyExistsError
, FileDoesNotExistError
, GPGError
, MergeFileTreeError
, NextVerNotFound , NextVerNotFound
, NoDownload
, NoToolVersionSet , NoToolVersionSet
, NotInstalled , BuildFailed
, ProcessError , DirNotEmpty
, TagNotFound , AlreadyInstalled
, TarDirDoesNotExist
, UninstallFailed , (AlreadyInstalled, NotInstalled)
, UnknownArchive , (UnknownArchive, NotInstalled)
, InstallSetError , (ArchiveResult, NotInstalled)
, (FileDoesNotExistError, NotInstalled)
, (CopyError, NotInstalled)
, (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
, (GPGError, NotInstalled)
, (DownloadFailed, NotInstalled)
, (TarDirDoesNotExist, NotInstalled)
, (NextVerNotFound, NotInstalled)
, (NoToolVersionSet, NotInstalled)
, (FileAlreadyExistsError, NotInstalled)
, (ProcessError, NotInstalled)
, (AlreadyInstalled, ())
, (UnknownArchive, ())
, (ArchiveResult, ())
, (FileDoesNotExistError, ())
, (CopyError, ())
, (NotInstalled, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())
, (GPGError, ())
, (DownloadFailed, ())
, (TarDirDoesNotExist, ())
, (NextVerNotFound, ())
, (NoToolVersionSet, ())
, (FileAlreadyExistsError, ())
, (ProcessError, ())
, ((), NotInstalled)
] ]
runInstGHC :: AppState runInstGHC :: AppState
-> Maybe PlatformRequest
-> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a -> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallGHCEffects a) -> IO (VEither InstallGHCEffects a)
runInstGHC appstate' = runInstGHC appstate' mInstPlatform =
flip runReaderT appstate' flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT . runResourceT
. runE . runE
@InstallGHCEffects @InstallGHCEffects
@@ -318,27 +391,25 @@ install installCommand settings getAppState' runLogger = case installCommand of
installGHC InstallOptions{..} = do installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstGHC s' $ do Nothing -> runInstGHC s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin void $ liftE $ sequenceE (installGHCBin
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
addConfArgs
) )
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} $ do runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist void $ liftE $ sequenceE (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
addConfArgs
) )
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case
@@ -348,41 +419,43 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $ runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty." "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V (DirNotEmpty fp)) -> do VLeft (V (DirNotEmpty fp, ())) -> do
runLogger $ logError $ runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty." "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err) Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do VLeft err@(V (BuildFailed tmpdir _, ())) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err) Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3 pure $ ExitFailure 3
@@ -390,23 +463,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
installCabal InstallOptions{..} = do installCabal InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBin void $ liftE $ sequenceE (installCabalBin
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist void $ liftE $ sequenceE (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi pure vi
) )
>>= \case >>= \case
@@ -415,48 +488,50 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4
installHLS :: InstallOptions -> IO ExitCode installHLS :: InstallOptions -> IO ExitCode
installHLS InstallOptions{..} = do installHLS InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
liftE $ runBothE' (installHLSBin void $ liftE $ sequenceE (installHLSBin
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy -- TODO: support legacy
liftE $ runBothE' (installHLSBindist void $ liftE $ sequenceE (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case
@@ -465,47 +540,57 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4
installStack :: InstallOptions -> IO ExitCode installStack :: InstallOptions -> IO ExitCode
installStack InstallOptions{..} = do installStack InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBin void $ liftE $ sequenceE (installStackBin
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist void $ liftE $ sequenceE (installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
(maybe GHCupInternal IsolateDir isolateDir) isolateDir
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi pure vi
) )
>>= \case >>= \case
@@ -514,22 +599,25 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $ T.pack $ prettyShow e runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
logError $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4

View File

@@ -11,7 +11,7 @@ module GHCup.OptParse.List where
import GHCup import GHCup
import GHCup.Prelude import GHCup.Utils.Prelude
import GHCup.Types import GHCup.Types
import GHCup.OptParse.Common import GHCup.OptParse.Common

View File

@@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.Logger import GHCup.Utils.Logger
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
--------------------------- ---------------------------
type NukeEffects = '[ NotInstalled, UninstallFailed ] type NukeEffects = '[ NotInstalled ]
runNuke :: AppState runNuke :: AppState

View File

@@ -14,10 +14,9 @@ module GHCup.OptParse.Prefetch where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.File import GHCup.Utils.Logger
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -34,6 +33,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
import GHCup.Utils.Prelude
import GHCup.Download (getDownloadsF) import GHCup.Download (getDownloadsF)
@@ -74,44 +74,44 @@ data PrefetchGHCOptions = PrefetchGHCOptions {
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
prefetchP :: Parser PrefetchCommand prefetchP :: Parser PrefetchCommand
prefetchP = subparser prefetchP = subparser
( command ( command
"ghc" "ghc"
(info (info
(PrefetchGHC (PrefetchGHC
<$> (PrefetchGHCOptions <$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionTagArgument Nothing (Just GHC)) ) <*> optional (toolVersionArgument Nothing (Just GHC)) )
( progDesc "Download GHC assets for installation") ( progDesc "Download GHC assets for installation")
) )
<> <>
command command
"cabal" "cabal"
(info (info
(PrefetchCabal (PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation") ( progDesc "Download cabal assets for installation")
) )
<> <>
command command
"hls" "hls"
(info (info
(PrefetchHLS (PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation") ( progDesc "Download HLS assets for installation")
) )
<> <>
command command
"stack" "stack"
(info (info
(PrefetchStack (PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )) <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation") ( progDesc "Download stack assets for installation")
) )
<> <>

View File

@@ -18,9 +18,9 @@ import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -71,7 +71,7 @@ data RmOptions = RmOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
rmParser :: Parser (Either RmCommand RmOptions) rmParser :: Parser (Either RmCommand RmOptions)
rmParser = rmParser =
(Left <$> subparser (Left <$> subparser
@@ -103,7 +103,7 @@ rmParser =
rmOpts :: Maybe Tool -> Parser RmOptions rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool
@@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
--------------------------- ---------------------------
type RmEffects = '[ NotInstalled, UninstallFailed ] type RmEffects = '[ NotInstalled ]
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a)) runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))

View File

@@ -5,24 +5,19 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Run where module GHCup.OptParse.Run where
import GHCup import GHCup
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Prelude
import GHCup.Utils.File
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics ( getDirs )
import GHCup.Prelude import GHCup.Utils.Logger
import GHCup.Prelude.File import GHCup.Utils.String.QQ
#ifdef IS_WINDOWS
import GHCup.Prelude.Process
import GHCup.Prelude.Process.Windows ( execNoMinGW )
#endif
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import Control.Exception.Safe ( MonadMask, MonadCatch ) import Control.Exception.Safe ( MonadMask, MonadCatch )
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
@@ -37,6 +32,7 @@ import Data.List ( intercalate )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Directory
import System.FilePath import System.FilePath
import System.Environment import System.Environment
import System.Exit import System.Exit
@@ -47,7 +43,6 @@ import qualified Data.Text as T
#ifndef IS_WINDOWS #ifndef IS_WINDOWS
import qualified System.Posix.Process as SPP import qualified System.Posix.Process as SPP
#endif #endif
import Data.Versions ( prettyVer, Version )
@@ -61,13 +56,11 @@ import Data.Versions ( prettyVer, Version )
data RunOptions = RunOptions data RunOptions = RunOptions
{ runAppendPATH :: Bool { runAppendPATH :: Bool
, runInstTool' :: Bool , runInstTool' :: Bool
, runMinGWPath :: Bool
, runGHCVer :: Maybe ToolVersion , runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion , runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion , runHLSVer :: Maybe ToolVersion
, runStackVer :: Maybe ToolVersion , runStackVer :: Maybe ToolVersion
, runBinDir :: Maybe FilePath , runBinDir :: Maybe FilePath
, runQuick :: Bool
, runCOMMAND :: [String] , runCOMMAND :: [String]
} }
@@ -77,8 +70,8 @@ data RunOptions = RunOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
runOpts :: Parser RunOptions runOpts :: Parser RunOptions
runOpts = runOpts =
RunOptions RunOptions
@@ -86,11 +79,9 @@ runOpts =
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)") (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
<*> switch <*> switch
(short 'i' <> long "install" <> help "Install the tool, if missing") (short 'i' <> long "install" <> help "Install the tool, if missing")
<*> switch
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
<*> optional <*> optional
(option (option
(eitherReader ghcVersionTagEither) (eitherReader toolVersionEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> (completer $ versionCompleter Nothing GHC) <> (completer $ versionCompleter Nothing GHC)
@@ -98,7 +89,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
<> completer (tagCompleter Cabal []) <> completer (tagCompleter Cabal [])
<> (completer $ versionCompleter Nothing Cabal) <> (completer $ versionCompleter Nothing Cabal)
@@ -106,7 +97,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
<> completer (tagCompleter HLS []) <> completer (tagCompleter HLS [])
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter Nothing HLS)
@@ -114,7 +105,7 @@ runOpts =
) )
<*> optional <*> optional
(option (option
(eitherReader toolVersionTagEither) (eitherReader toolVersionEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version" (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
<> completer (tagCompleter Stack []) <> completer (tagCompleter Stack [])
<> (completer $ versionCompleter Nothing Stack) <> (completer $ versionCompleter Nothing Stack)
@@ -130,8 +121,6 @@ runOpts =
<> completer (bashCompleter "directory") <> completer (bashCompleter "directory")
) )
) )
<*> switch
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits.")) <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
@@ -184,8 +173,6 @@ type RunEffects = '[ AlreadyInstalled
, NoToolVersionSet , NoToolVersionSet
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, UninstallFailed
, MergeFileTreeError
] ]
runLeanRUN :: (MonadUnliftIO m, MonadIO m) runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@@ -200,16 +187,14 @@ runLeanRUN leanAppstate =
@RunEffects @RunEffects
runRUN :: MonadUnliftIO m runRUN :: MonadUnliftIO m
=> IO AppState => (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither RunEffects a) -> m (VEither RunEffects a)
runRUN appState action' = do runRUN runAppState =
s' <- liftIO appState runAppState
flip runReaderT s'
. runResourceT . runResourceT
. runE . runE
@RunEffects @RunEffects
$ action'
@@ -219,7 +204,7 @@ runRUN appState action' = do
run :: forall m . run :: forall m.
( MonadFail m ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
@@ -227,219 +212,155 @@ run :: forall m .
, MonadUnliftIO m , MonadUnliftIO m
) )
=> RunOptions => RunOptions
-> IO AppState -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> LeanAppState -> LeanAppState
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
run RunOptions{..} runAppState leanAppstate runLogger = do run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
r <- if not runQuick toolchain <- Excepts resolveToolchain
then runRUN runAppState $ do tmp <- case runBinDir of
toolchain <- liftE resolveToolchainFull Just bindir -> do
liftIO $ createDirRecursive' bindir
-- oh dear liftIO $ canonicalizePath bindir
r <- lift ask Nothing -> do
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain d <- liftIO $ predictableTmpDir toolchain
liftIO $ createDirRecursive' d
liftE $ installToolChainFull toolchain tmp liftIO $ canonicalizePath d
pure tmp Excepts $ installToolChain toolchain tmp
else runLeanRUN leanAppstate $ do pure tmp
toolchain <- resolveToolchain ) >>= \case
tmp <- lift $ createTmpDir toolchain VRight tmp -> do
liftE $ installToolChain toolchain tmp case runCOMMAND of
pure tmp [] -> do
case r of liftIO $ putStr tmp
VRight tmp -> do pure ExitSuccess
case runCOMMAND of (cmd:args) -> do
[] -> do newEnv <- liftIO $ addToPath tmp
liftIO $ putStr tmp
pure ExitSuccess
(cmd:args) -> do
newEnv <- liftIO $ addToPath tmp
#ifndef IS_WINDOWS #ifndef IS_WINDOWS
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess pure ExitSuccess
#else #else
r' <- if runMinGWPath r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) case r' of
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv) VRight _ -> pure ExitSuccess
case r' of VLeft e -> do
VRight _ -> pure ExitSuccess runLogger $ logError $ T.pack $ prettyShow e
VLeft e -> do pure $ ExitFailure 28
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 28
#endif #endif
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 27 pure $ ExitFailure 27
where where
isToolTag :: ToolVersion -> Bool
isToolTag (ToolTag _) = True
isToolTag _ = False
-- TODO: doesn't work for cross -- TODO: doesn't work for cross
resolveToolchainFull :: ( MonadFail m resolveToolchain
, MonadThrow m | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
, MonadIO m
, MonadCatch m
)
=> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] (ResourceT (ReaderT AppState m)) Toolchain
resolveToolchainFull = do
ghcVer <- forM runGHCVer $ \ver -> do ghcVer <- forM runGHCVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) GHC (v, _) <- liftE $ fromVersion (Just ver) GHC
pure v pure v
cabalVer <- forM runCabalVer $ \ver -> do cabalVer <- forM runCabalVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Cabal (v, _) <- liftE $ fromVersion (Just ver) Cabal
pure (_tvVersion v) pure v
hlsVer <- forM runHLSVer $ \ver -> do hlsVer <- forM runHLSVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) HLS (v, _) <- liftE $ fromVersion (Just ver) HLS
pure (_tvVersion v) pure v
stackVer <- forM runStackVer $ \ver -> do stackVer <- forM runStackVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) Stack (v, _) <- liftE $ fromVersion (Just ver) Stack
pure (_tvVersion v) pure v
pure Toolchain{..} pure Toolchain{..}
| otherwise = runLeanRUN leanAppstate $ do
resolveToolchain = do
ghcVer <- case runGHCVer of ghcVer <- case runGHCVer of
Just (GHCVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Just (ToolVersion v) -> pure $ Just (mkTVer v)
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
cabalVer <- case runCabalVer of cabalVer <- case runCabalVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
hlsVer <- case runHLSVer of hlsVer <- case runHLSVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
stackVer <- case runStackVer of stackVer <- case runStackVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
_ -> fail "Internal error" _ -> fail "Internal error"
pure Toolchain{..} pure Toolchain{..}
installToolChainFull :: ( MonadFail m installToolChain Toolchain{..} tmp
, MonadThrow m | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
, MonadIO m forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
, MonadCatch m isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
) case mt of
=> Toolchain Just (GHC, v) -> do
-> FilePath unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
-> Excepts (_tvVersion v)
'[ TagNotFound Nothing
, NextVerNotFound False
, NoToolVersionSet setTool GHC v tmp
, UnknownArchive Just (Cabal, v) -> do
, TarDirDoesNotExist unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
, ProcessError (_tvVersion v)
, NotInstalled Nothing
, NoDownload False
, GPGError setTool Cabal v tmp
, DownloadFailed Just (Stack, v) -> do
, DirNotEmpty unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
, DigestError (_tvVersion v)
, BuildFailed Nothing
, ArchiveResult False
, AlreadyInstalled setTool Stack v tmp
, FileAlreadyExistsError Just (HLS, v) -> do
, CopyError unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
, UninstallFailed (_tvVersion v)
, MergeFileTreeError Nothing
] (ResourceT (ReaderT AppState m)) () False
installToolChainFull Toolchain{..} tmp = do setTool HLS v tmp
case ghcVer of _ -> pure ()
Just v -> do | otherwise = runLeanRUN leanAppstate $ do
isInstalled <- lift $ checkIfToolInstalled' GHC v forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin case mt of
(_tvVersion v) Just (GHC, v) -> setTool GHC v tmp
GHCupInternal Just (Cabal, v) -> setTool Cabal v tmp
False Just (Stack, v) -> setTool Stack v tmp
[] Just (HLS, v) -> setTool HLS v tmp
setGHC' v tmp _ -> pure ()
_ -> pure ()
case cabalVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
v
GHCupInternal
False
setCabal' v tmp
_ -> pure ()
case stackVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
v
GHCupInternal
False
setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
v
GHCupInternal
False
setHLS' v tmp
_ -> pure ()
installToolChain :: ( MonadFail m setTool tool v tmp =
, MonadThrow m case tool of
, MonadIO m GHC -> do
, MonadCatch m
)
=> Toolchain
-> FilePath
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
installToolChain Toolchain{..} tmp = do
case ghcVer of
Just v -> setGHC' v tmp
_ -> pure ()
case cabalVer of
Just v -> setCabal' v tmp
_ -> pure ()
case stackVer of
Just v -> setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> setHLS' v tmp
_ -> pure ()
setGHC' v tmp = do
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp) void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
void $ liftE $ setGHC v SetGHCOnly (Just tmp) void $ liftE $ setGHC v SetGHCOnly (Just tmp)
setCabal' v tmp = do Cabal -> do
bin <- liftE $ whereIsTool Cabal (mkTVer v) bin <- liftE $ whereIsTool Cabal v
cbin <- liftIO $ canonicalizePath bin cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt)) lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
setStack' v tmp = do Stack -> do
bin <- liftE $ whereIsTool Stack (mkTVer v) bin <- liftE $ whereIsTool Stack v
cbin <- liftIO $ canonicalizePath bin cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt)) lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
setHLS' v tmp = do HLS -> do
Dirs {..} <- getDirs Dirs {..} <- getDirs
legacy <- isLegacyHLS v let v' = _tvVersion v
legacy <- isLegacyHLS v'
if legacy if legacy
then do then do
-- TODO: factor this out -- TODO: factor this out
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v)) hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper) cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw) lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>)) hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
forM_ hlsBins $ \bin -> forM_ hlsBins $ \bin ->
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin) lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
liftE $ setHLS v SetHLSOnly (Just tmp) liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
else do else do
liftE $ setHLS v SetHLS_XYZ (Just tmp) liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)
liftE $ setHLS v SetHLSOnly (Just tmp) liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
GHCup -> pure ()
addToPath path = do addToPath path = do
cEnv <- Map.fromList <$> getEnvironment cEnv <- Map.fromList <$> getEnvironment
let paths = ["PATH", "Path"] let paths = ["PATH", "Path"]
@@ -451,38 +372,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
liftIO $ setEnv pathVar newPath liftIO $ setEnv pathVar newPath
return envWithNewPath return envWithNewPath
createTmpDir :: ( MonadUnliftIO m predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =
, MonadCatch m liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))
, MonadThrow m
, MonadMask m
, MonadIO m
)
=> Toolchain
-> ReaderT LeanAppState m FilePath
createTmpDir toolchain =
case runBinDir of
Just bindir -> do
liftIO $ createDirRecursive' bindir
liftIO $ canonicalizePath bindir
Nothing -> do
d <- predictableTmpDir toolchain
liftIO $ createDirRecursive' d
liftIO $ canonicalizePath d
predictableTmpDir :: Monad m
=> Toolchain
-> ReaderT LeanAppState m FilePath
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
Dirs { tmpDir } <- getDirs
pure (fromGHCupPath tmpDir </> "ghcup-none")
predictableTmpDir Toolchain{..} = do predictableTmpDir Toolchain{..} = do
Dirs { tmpDir } <- getDirs tmp <- getTemporaryDirectory
pure $ fromGHCupPath tmpDir pure $ tmp
</> ("ghcup-" <> intercalate "_" </> ("ghcup-" <> intercalate "_"
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer ( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . tVerToText) hlsVer
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer
) )
) )
@@ -496,7 +395,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
data Toolchain = Toolchain data Toolchain = Toolchain
{ ghcVer :: Maybe GHCTargetVersion { ghcVer :: Maybe GHCTargetVersion
, cabalVer :: Maybe Version , cabalVer :: Maybe GHCTargetVersion
, hlsVer :: Maybe Version , hlsVer :: Maybe GHCTargetVersion
, stackVer :: Maybe Version , stackVer :: Maybe GHCTargetVersion
} deriving Show }

View File

@@ -17,8 +17,8 @@ import GHCup.OptParse.Common
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -74,7 +74,7 @@ data SetOptions = SetOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
setParser :: Parser (Either SetCommand SetOptions) setParser :: Parser (Either SetCommand SetOptions)
setParser = setParser =
(Left <$> subparser (Left <$> subparser
@@ -82,7 +82,7 @@ setParser =
"ghc" "ghc"
( SetGHC ( SetGHC
<$> info <$> info
(setOpts GHC <**> helper) (setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version" ( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter) <> footerDoc (Just $ text setGHCFooter)
) )
@@ -91,7 +91,7 @@ setParser =
"cabal" "cabal"
( SetCabal ( SetCabal
<$> info <$> info
(setOpts Cabal <**> helper) (setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version" ( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter) <> footerDoc (Just $ text setCabalFooter)
) )
@@ -100,7 +100,7 @@ setParser =
"hls" "hls"
( SetHLS ( SetHLS
<$> info <$> info
(setOpts HLS <**> helper) (setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version" ( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter) <> footerDoc (Just $ text setHLSFooter)
) )
@@ -109,14 +109,14 @@ setParser =
"stack" "stack"
( SetStack ( SetStack
<$> info <$> info
(setOpts Stack <**> helper) (setOpts (Just Stack) <**> helper)
( progDesc "Set stack version" ( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter) <> footerDoc (Just $ text setStackFooter)
) )
) )
) )
) )
<|> (Right <$> setOpts GHC) <|> (Right <$> setOpts Nothing)
where where
setGHCFooter :: String setGHCFooter :: String
setGHCFooter = [s|Discussion: setGHCFooter = [s|Discussion:
@@ -137,25 +137,22 @@ setParser =
Sets the the current haskell-language-server version.|] Sets the the current haskell-language-server version.|]
setOpts :: Tool -> Parser SetOptions setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$> setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$> (fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool)) optional (setVersionArgument (Just ListInstalled) tool))
setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool = setVersionArgument criteria tool =
argument (eitherReader setEither) argument (eitherReader setEither)
(metavar "VERSION|TAG|next" (metavar "VERSION|TAG|next"
<> completer (tagCompleter tool ["next"]) <> completer (tagCompleter (fromMaybe GHC tool) ["next"])
<> (completer . versionCompleter criteria) tool) <> foldMap (completer . versionCompleter criteria) tool)
where where
setEither s' = setEither s' =
parseSet s' parseSet s'
<|> second SetToolTag (tagEither s') <|> second SetToolTag (tagEither s')
<|> se s' <|> second SetToolVersion (tVersionEither s')
se s' = case tool of
GHC -> second SetGHCVersion (ghcVersionEither s')
_ -> second SetToolVersion (toolVersionEither s')
parseSet s' = case fmap toLower s' of parseSet s' = case fmap toLower s' of
"next" -> Right SetNext "next" -> Right SetNext
other -> Left $ "Unknown tag/version " <> other other -> Left $ "Unknown tag/version " <> other
@@ -264,9 +261,9 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
(Right sopts) -> do (Right sopts) -> do
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts setGHC' sopts
(Left (SetGHC sopts)) -> setGHC' sopts (Left (SetGHC sopts)) -> setGHC' sopts
(Left (SetCabal sopts)) -> setCabal' sopts (Left (SetCabal sopts)) -> setCabal' sopts
(Left (SetHLS sopts)) -> setHLS' sopts (Left (SetHLS sopts)) -> setHLS' sopts
(Left (SetStack sopts)) -> setStack' sopts (Left (SetStack sopts)) -> setStack' sopts
where where
@@ -274,7 +271,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setGHC' SetOptions{ sToolVer } = setGHC' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
_ -> runSetGHC runAppState (do _ -> runSetGHC runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly Nothing liftE $ setGHC v SetGHCOnly Nothing
@@ -294,17 +291,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setCabal' SetOptions{ sToolVer } = setCabal' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v)) (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal runAppState (do _ -> runSetCabal runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v) liftE $ setCabal (_tvVersion v)
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version" "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
@@ -314,17 +311,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setHLS' SetOptions{ sToolVer } = setHLS' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v)) (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)
_ -> runSetHLS runAppState (do _ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version" "HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
@@ -335,17 +332,17 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode -> m ExitCode
setStack' SetOptions{ sToolVer } = setStack' SetOptions{ sToolVer } =
case sToolVer of case sToolVer of
(SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v)) (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetStack runAppState (do _ -> runSetStack runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v) liftE $ setStack (_tvVersion v)
pure v pure v
) )
>>= \case >>= \case
VRight v -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ logInfo $ $ logInfo $
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version" "Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e

View File

@@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -30,7 +30,7 @@ import qualified Data.Text.IO as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Platform import GHCup.Platform
import GHCup.Prelude import GHCup.Utils.Prelude
import GHCup.Requirements import GHCup.Requirements
import System.IO import System.IO

View File

@@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.Logger import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )

View File

@@ -14,8 +14,7 @@ module GHCup.OptParse.Upgrade where
import GHCup import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Prelude.File import GHCup.Utils.Logger
import GHCup.Prelude.Logger
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -60,16 +59,15 @@ data UpgradeOpts = UpgradeInplace
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
upgradeOptsP :: Parser UpgradeOpts upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP = upgradeOptsP =
flag' flag'
UpgradeInplace UpgradeInplace
(short 'i' <> long "inplace" <> help (short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place" "Upgrade ghcup in-place (wherever it's at)"
) )
<|> <|> ( UpgradeAt
( UpgradeAt
<$> option <$> option
str str
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
@@ -94,7 +92,6 @@ type UpgradeEffects = '[ DigestError
, FileDoesNotExistError , FileDoesNotExistError
, CopyError , CopyError
, DownloadFailed , DownloadFailed
, ToolShadowed
] ]
@@ -123,19 +120,18 @@ upgrade :: ( Monad m
) )
=> UpgradeOpts => UpgradeOpts
-> Bool -> Bool
-> Bool
-> Dirs -> Dirs
-> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do upgrade uOpts force' Dirs{..} runAppState runLogger = do
target <- case uOpts of target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p (UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt)) UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
runUpgrade runAppState (do runUpgrade runAppState (do
v' <- liftE $ upgradeGHCup target force' fatal v' <- liftE $ upgradeGHCup target force'
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (v', dls) pure (v', dls)
) >>= \case ) >>= \case

View File

@@ -17,9 +17,8 @@ import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Types import GHCup.Types
import GHCup.Utils import GHCup.Utils.Logger
import GHCup.Prelude.Logger import GHCup.Utils.String.QQ
import GHCup.Prelude.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -32,7 +31,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Environment
import System.Exit import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -76,14 +74,14 @@ data WhereisOptions = WhereisOptions {
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
whereisP :: Parser WhereisCommand whereisP :: Parser WhereisCommand
whereisP = subparser whereisP = subparser
(commandGroup "Tools locations:" <> (commandGroup "Tools locations:" <>
command command
"ghc" "ghc"
(WhereisTool GHC <$> info (WhereisTool GHC <$> info
( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper ) ( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
( progDesc "Get GHC location" ( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter )) <> footerDoc (Just $ text whereisGHCFooter ))
) )
@@ -91,7 +89,7 @@ whereisP = subparser
command command
"cabal" "cabal"
(WhereisTool Cabal <$> info (WhereisTool Cabal <$> info
( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ) ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )
( progDesc "Get cabal location" ( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter )) <> footerDoc (Just $ text whereisCabalFooter ))
) )
@@ -99,7 +97,7 @@ whereisP = subparser
command command
"hls" "hls"
(WhereisTool HLS <$> info (WhereisTool HLS <$> info
( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ) ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )
( progDesc "Get HLS location" ( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter )) <> footerDoc (Just $ text whereisHLSFooter ))
) )
@@ -107,7 +105,7 @@ whereisP = subparser
command command
"stack" "stack"
(WhereisTool Stack <$> info (WhereisTool Stack <$> info
( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ) ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location" ( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter )) <> footerDoc (Just $ text whereisStackFooter ))
) )
@@ -269,30 +267,9 @@ whereis :: ( Monad m
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
Dirs{ .. } <- runReaderT getDirs leanAppstate Dirs{ .. } <- runReaderT getDirs leanAppstate
case (whereisCommand, whereisOptions) of case (whereisCommand, whereisOptions) of
(WhereisTool GHCup _, WhereisOptions{..}) -> do
loc <- liftIO (getExecutablePath >>= canonicalizePath )
if directory
then liftIO $ putStr $ takeDirectory loc
else liftIO $ putStr loc
pure ExitSuccess
(WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) -> (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do runLeanWhereIs leanAppstate (do
loc <- liftE $ whereIsTool tool (mkTVer v) loc <- liftE $ whereIsTool tool v
if directory if directory
then pure $ takeDirectory loc then pure $ takeDirectory loc
else pure loc else pure loc
@@ -322,7 +299,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure $ ExitFailure 30 pure $ ExitFailure 30
(WhereisBaseDir, _) -> do (WhereisBaseDir, _) -> do
liftIO $ putStr $ fromGHCupPath baseDir liftIO $ putStr baseDir
pure ExitSuccess pure ExitSuccess
(WhereisBinDir, _) -> do (WhereisBinDir, _) -> do
@@ -330,13 +307,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure ExitSuccess pure ExitSuccess
(WhereisCacheDir, _) -> do (WhereisCacheDir, _) -> do
liftIO $ putStr $ fromGHCupPath cacheDir liftIO $ putStr cacheDir
pure ExitSuccess pure ExitSuccess
(WhereisLogsDir, _) -> do (WhereisLogsDir, _) -> do
liftIO $ putStr $ fromGHCupPath logsDir liftIO $ putStr logsDir
pure ExitSuccess pure ExitSuccess
(WhereisConfDir, _) -> do (WhereisConfDir, _) -> do
liftIO $ putStr $ fromGHCupPath confDir liftIO $ putStr confDir
pure ExitSuccess pure ExitSuccess

View File

@@ -14,8 +14,6 @@ module Main where
import BrickMain ( brickMain ) import BrickMain ( brickMain )
#endif #endif
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
import GHCup.OptParse import GHCup.OptParse
import GHCup.Download import GHCup.Download
@@ -24,9 +22,9 @@ import GHCup.Platform
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Types.Optics hiding ( toolRequirements )
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude import GHCup.Utils.Logger
import GHCup.Prelude.Logger import GHCup.Utils.Prelude
import GHCup.Prelude.String.QQ import GHCup.Utils.String.QQ
import GHCup.Version import GHCup.Version
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -87,7 +85,6 @@ toSettings options = do
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@@ -144,7 +141,9 @@ main = do
) )
let listCommands = infoOption let listCommands = infoOption
("install set rm install-cabal list" ("install set rm install-cabal list"
#ifndef DISABLE_UPGRADE
<> " upgrade" <> " upgrade"
#endif
<> " compile debug-info tool-requirements changelog" <> " compile debug-info tool-requirements changelog"
) )
( long "list-commands" ( long "list-commands"
@@ -158,10 +157,11 @@ main = do
versions. It maintains a self-contained ~/.ghcup directory. versions. It maintains a self-contained ~/.ghcup directory.
ENV variables: ENV variables:
* TMPDIR: where ghcup does the work (unpacking, building, ...)
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
* GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
Report bugs at <https://github.com/haskell/ghcup-hs/issues>|] Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
customExecParser customExecParser
(prefs showHelpOnError) (prefs showHelpOnError)
@@ -199,14 +199,14 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
let appState = do let appState = do
pfreq <- case platformOverride settings of pfreq <- (
Just pfreq' -> return pfreq' runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
Nothing -> (runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest) >>= \case ) >>= \case
VRight r -> pure r VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
(logError $ T.pack $ prettyShow e) (logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
ghcupInfo <- ghcupInfo <-
( flip runReaderT leanAppstate ( flip runReaderT leanAppstate
@@ -222,7 +222,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
race_ (liftIO $ runReaderT cleanupTrash s') race_ (liftIO $ runReaderT cleanupTrash s')
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually")) (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of case optCommand of
Nuke -> pure () Nuke -> pure ()
@@ -239,16 +239,20 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
| Just False <- optVerbose -> pure () | Just False <- optVerbose -> pure ()
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
newTools <- lift checkForUpdates newTools <- lift checkForUpdates
forM_ newTools $ \newTool@(t, l) -> do forM_ newTools $ \newTool@(t, l) -> do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283 -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
alreadyInstalling' <- alreadyInstalling optCommand newTool alreadyInstalling' <- alreadyInstalling optCommand newTool
when (not alreadyInstalling') $ when (not alreadyInstalling') $
case t of case t of
#ifdef DISABLE_UPGRADE
GHCup -> pure ()
#else
GHCup -> runLogger $ GHCup -> runLogger $
logWarn ("New GHCup version available: " logWarn ("New GHCup version available: "
<> prettyVer l <> prettyVer l
<> ". To upgrade, run 'ghcup upgrade'") <> ". To upgrade, run 'ghcup upgrade'")
#endif
_ -> runLogger $ _ -> runLogger $
logWarn ("New " logWarn ("New "
<> T.pack (prettyShow t) <> T.pack (prettyShow t)
@@ -280,7 +284,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
runAppState action' = do runAppState action' = do
s' <- liftIO appState s' <- liftIO appState
runReaderT action' s' runReaderT action' s'
----------------- -----------------
-- Run command -- -- Run command --
@@ -292,24 +296,26 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
s' <- appState s' <- appState
liftIO $ brickMain s' >> pure ExitSuccess liftIO $ brickMain s' >> pure ExitSuccess
#endif #endif
Install installCommand -> install installCommand settings appState runLogger Install installCommand -> install installCommand settings appState runLogger
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
Set setCommand -> set setCommand runAppState runLeanAppState runLogger Set setCommand -> set setCommand runAppState runLeanAppState runLogger
UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger
List lo -> list lo no_color runAppState List lo -> list lo no_color runAppState
Rm rmCommand -> rm rmCommand runAppState runLogger Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings keybindings runLogger Config configCommand -> config configCommand settings keybindings runLogger
Whereis whereisOptions Whereis whereisOptions
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger #ifndef DISABLE_UPGRADE
ToolRequirements topts -> toolRequirements topts runAppState runLogger Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger #endif
Nuke -> nuke appState runLogger ToolRequirements topts -> toolRequirements topts runAppState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger Nuke -> nuke appState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand runAppState leanAppstate runLogger
case res of case res of
ExitSuccess -> pure () ExitSuccess -> pure ()
@@ -340,16 +346,16 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
(GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion over) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver })) #ifndef DISABLE_UPGRADE
(HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True
alreadyInstalling (Upgrade {}) (GHCup, _) = pure True #endif
alreadyInstalling _ _ = pure False alreadyInstalling _ _ = pure False
cmp' :: ( HasLog env cmp' :: ( HasLog env

View File

@@ -15,7 +15,7 @@ source-repository-package
constraints: http-io-streams -brotli, constraints: http-io-streams -brotli,
any.Cabal ==3.6.2.0, any.Cabal ==3.6.2.0,
any.aeson >= 2.0.1.0, any.aeson >= 2.0.1.0
package libarchive package libarchive
flags: -system-libarchive flags: -system-libarchive
@@ -29,9 +29,6 @@ package cabal-plan
package aeson package aeson
flags: +ordered-keymap flags: +ordered-keymap
package streamly
flags: +use-unliftio
allow-newer: base, ghc-prim, template-haskell, language-c allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-8.10.7 with-compiler: ghc-8.10.7

View File

@@ -15,7 +15,7 @@ constraints: any.Cabal ==3.6.2.0,
any.aeson-pretty ==0.8.9, any.aeson-pretty ==0.8.9,
aeson-pretty +lib-only, aeson-pretty +lib-only,
any.alex ==3.2.7.1, any.alex ==3.2.7.1,
any.ansi-terminal ==0.11.3, any.ansi-terminal ==0.11.1,
ansi-terminal -example, ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9, any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example, ansi-wl-pprint -example,
@@ -33,7 +33,7 @@ constraints: any.Cabal ==3.6.2.0,
any.base-orphans ==0.8.6, any.base-orphans ==0.8.6,
any.base16-bytestring ==1.0.2.0, any.base16-bytestring ==1.0.2.0,
any.base64-bytestring ==1.2.1.0, any.base64-bytestring ==1.2.1.0,
any.bifunctors ==5.5.12, any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged, bifunctors +semigroups +tagged,
any.binary ==0.8.8.0, any.binary ==0.8.8.0,
any.blaze-builder ==0.4.2.2, any.blaze-builder ==0.4.2.2,
@@ -80,9 +80,9 @@ constraints: any.Cabal ==3.6.2.0,
dlist -werror, dlist -werror,
any.exceptions ==0.10.4, any.exceptions ==0.10.4,
any.filepath ==1.4.2.1, any.filepath ==1.4.2.1,
any.free ==5.1.8, any.free ==5.1.7,
any.fusion-plugin-types ==0.1.0, any.fusion-plugin-types ==0.1.0,
any.generic-arbitrary ==0.2.2, any.generic-arbitrary ==0.2.0,
any.ghc ==8.10.7, any.ghc ==8.10.7,
any.ghc-boot ==8.10.7, any.ghc-boot ==8.10.7,
any.ghc-boot-th ==8.10.7, any.ghc-boot-th ==8.10.7,
@@ -100,12 +100,12 @@ constraints: any.Cabal ==3.6.2.0,
any.hpc ==0.6.1.0, any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8, any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree, hsc2hs -in-ghc-tree,
any.hspec ==2.9.7, any.hspec ==2.9.4,
any.hspec-core ==2.9.7, any.hspec-core ==2.9.4,
any.hspec-discover ==2.9.7, any.hspec-discover ==2.9.4,
any.hspec-expectations ==0.8.2, any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0, any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.1, any.http-io-streams ==0.1.6.0,
http-io-streams -brotli +fast-xor, http-io-streams -brotli +fast-xor,
any.indexed-profunctors ==0.1.1, any.indexed-profunctors ==0.1.1,
any.indexed-traversable ==0.1.2, any.indexed-traversable ==0.1.2,
@@ -115,7 +115,7 @@ constraints: any.Cabal ==3.6.2.0,
integer-logarithms -check-bounds +integer-gmp, integer-logarithms -check-bounds +integer-gmp,
any.io-streams ==1.5.2.1, any.io-streams ==1.5.2.1,
io-streams +network -nointeractivetests +zlib, io-streams +network -nointeractivetests +zlib,
any.language-c ==0.9.1, any.language-c ==0.9.0.1,
language-c -allwarnings +iecfpextension +usebytestrings, language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.3.2, any.libarchive ==3.0.3.2,
libarchive -cross -low-memory +no-exe -system-libarchive, libarchive -cross -low-memory +no-exe -system-libarchive,
@@ -123,21 +123,22 @@ constraints: any.Cabal ==3.6.2.0,
libyaml-streamly -no-unicode -system-libyaml, libyaml-streamly -no-unicode -system-libyaml,
any.lockfree-queue ==0.2.3.1, any.lockfree-queue ==0.2.3.1,
any.lzma-static ==5.2.5.4, any.lzma-static ==5.2.5.4,
any.megaparsec ==9.2.1, any.megaparsec ==9.2.0,
megaparsec -dev, megaparsec -dev,
any.microlens ==0.4.12.0, any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.2, any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10, any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.network ==3.1.2.7, any.network ==3.1.2.7,
network -devel, network -devel,
any.network-uri ==2.6.4.1, any.network-uri ==2.6.4.1,
any.openssl-streams ==1.2.3.0, any.openssl-streams ==1.2.3.0,
any.optics ==0.4.2, any.optics ==0.4,
any.optics-core ==0.4.1, any.optics-core ==0.4,
optics-core -explicit-generic-labels, optics-core -explicit-generic-labels,
any.optics-extra ==0.4.2.1, any.optics-extra ==0.4,
any.optics-th ==0.4.1, any.optics-th ==0.4,
any.optparse-applicative ==0.17.0.0, any.optparse-applicative ==0.17.0.0,
optparse-applicative +process, optparse-applicative +process,
any.os-release ==1.0.2.1, any.os-release ==1.0.2.1,
@@ -149,23 +150,23 @@ constraints: any.Cabal ==3.6.2.0,
any.polyparse ==1.13, any.polyparse ==1.13,
any.pretty ==1.1.3.6, any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0, any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.4.0, any.primitive ==0.7.3.0,
any.process ==1.6.13.2, any.process ==1.6.13.2,
any.profunctors ==5.6.2, any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0, any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0, any.quickcheck-io ==0.2.0,
any.random ==1.2.1.1, any.random ==1.2.1,
any.recursion-schemes ==5.2.2.2, any.recursion-schemes ==5.2.2.2,
recursion-schemes +template-haskell, recursion-schemes +template-haskell,
any.regex-base ==0.94.0.2, any.regex-base ==0.94.0.2,
any.regex-posix ==0.96.0.1, any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib, regex-posix -_regex-posix-clib,
any.resourcet ==1.2.5, any.resourcet ==1.2.4.3,
any.retry ==0.8.1.2, any.retry ==0.8.1.2,
retry -lib-werror, retry -lib-werror,
any.rts ==1.0.1, any.rts ==1.0.1,
any.safe ==0.3.19, any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.3, any.safe-exceptions ==0.1.7.2,
any.scientific ==0.3.7.0, any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple, scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1, any.semialign ==1.2.0.1,
@@ -178,7 +179,7 @@ constraints: any.Cabal ==3.6.2.0,
splitmix -optimised-mixer, splitmix -optimised-mixer,
any.stm ==2.5.0.1, any.stm ==2.5.0.1,
any.streamly ==0.8.2, any.streamly ==0.8.2,
streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc +use-unliftio, streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc -use-unliftio,
any.strict ==0.4.0.1, any.strict ==0.4.0.1,
strict +assoc, strict +assoc,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
@@ -212,11 +213,11 @@ constraints: any.Cabal ==3.6.2.0,
any.unicode-data ==0.3.0, any.unicode-data ==0.3.0,
unicode-data -ucd2haskell, unicode-data -ucd2haskell,
any.unix ==2.7.2.2, any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.7, any.unix-bytestring ==0.3.7.6,
any.unix-compat ==0.6, any.unix-compat ==0.5.4,
unix-compat -old-time, unix-compat -old-time,
any.unliftio-core ==0.2.0.1, any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1, any.unordered-containers ==0.2.17.0,
unordered-containers -debug, unordered-containers -debug,
any.uri-bytestring ==0.3.3.1, any.uri-bytestring ==0.3.3.1,
uri-bytestring -lib-werror, uri-bytestring -lib-werror,
@@ -232,7 +233,7 @@ constraints: any.Cabal ==3.6.2.0,
any.xor ==0.0.1.1, any.xor ==0.0.1.1,
any.yaml-streamly ==0.12.1, any.yaml-streamly ==0.12.1,
yaml-streamly +no-examples +no-exe, yaml-streamly +no-examples +no-exe,
any.zlib ==0.6.3.0, any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5 any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2022-06-04T19:47:01Z index-state: hackage.haskell.org 2022-03-15T16:43:02Z

View File

@@ -15,7 +15,7 @@ source-repository-package
constraints: http-io-streams -brotli, constraints: http-io-streams -brotli,
any.Cabal ==3.6.2.0, any.Cabal ==3.6.2.0,
any.aeson >= 2.0.1.0, any.aeson >= 2.0.1.0
package libarchive package libarchive
flags: -system-libarchive flags: -system-libarchive
@@ -29,9 +29,6 @@ package cabal-plan
package aeson package aeson
flags: +ordered-keymap flags: +ordered-keymap
package streamly
flags: +use-unliftio
allow-newer: base, ghc-prim, template-haskell, language-c allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-9.0.2 with-compiler: ghc-9.0.2

View File

@@ -15,7 +15,7 @@ constraints: any.Cabal ==3.6.2.0,
any.aeson-pretty ==0.8.9, any.aeson-pretty ==0.8.9,
aeson-pretty +lib-only, aeson-pretty +lib-only,
any.alex ==3.2.7.1, any.alex ==3.2.7.1,
any.ansi-terminal ==0.11.3, any.ansi-terminal ==0.11.1,
ansi-terminal -example, ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9, any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example, ansi-wl-pprint -example,
@@ -33,7 +33,7 @@ constraints: any.Cabal ==3.6.2.0,
any.base-orphans ==0.8.6, any.base-orphans ==0.8.6,
any.base16-bytestring ==1.0.2.0, any.base16-bytestring ==1.0.2.0,
any.base64-bytestring ==1.2.1.0, any.base64-bytestring ==1.2.1.0,
any.bifunctors ==5.5.12, any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged, bifunctors +semigroups +tagged,
any.binary ==0.8.8.0, any.binary ==0.8.8.0,
any.blaze-builder ==0.4.2.2, any.blaze-builder ==0.4.2.2,
@@ -80,9 +80,9 @@ constraints: any.Cabal ==3.6.2.0,
dlist -werror, dlist -werror,
any.exceptions ==0.10.4, any.exceptions ==0.10.4,
any.filepath ==1.4.2.1, any.filepath ==1.4.2.1,
any.free ==5.1.8, any.free ==5.1.7,
any.fusion-plugin-types ==0.1.0, any.fusion-plugin-types ==0.1.0,
any.generic-arbitrary ==0.2.2, any.generic-arbitrary ==0.2.0,
any.ghc ==9.0.2, any.ghc ==9.0.2,
any.ghc-bignum ==1.1, any.ghc-bignum ==1.1,
any.ghc-boot ==9.0.2, any.ghc-boot ==9.0.2,
@@ -101,12 +101,12 @@ constraints: any.Cabal ==3.6.2.0,
any.hpc ==0.6.1.0, any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8, any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree, hsc2hs -in-ghc-tree,
any.hspec ==2.9.7, any.hspec ==2.9.4,
any.hspec-core ==2.9.7, any.hspec-core ==2.9.4,
any.hspec-discover ==2.9.7, any.hspec-discover ==2.9.4,
any.hspec-expectations ==0.8.2, any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0, any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.1, any.http-io-streams ==0.1.6.0,
http-io-streams -brotli +fast-xor, http-io-streams -brotli +fast-xor,
any.indexed-profunctors ==0.1.1, any.indexed-profunctors ==0.1.1,
any.indexed-traversable ==0.1.2, any.indexed-traversable ==0.1.2,
@@ -115,7 +115,7 @@ constraints: any.Cabal ==3.6.2.0,
integer-logarithms -check-bounds +integer-gmp, integer-logarithms -check-bounds +integer-gmp,
any.io-streams ==1.5.2.1, any.io-streams ==1.5.2.1,
io-streams +network -nointeractivetests +zlib, io-streams +network -nointeractivetests +zlib,
any.language-c ==0.9.1, any.language-c ==0.9.0.1,
language-c -allwarnings +iecfpextension +usebytestrings, language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.3.2, any.libarchive ==3.0.3.2,
libarchive -cross -low-memory +no-exe -system-libarchive, libarchive -cross -low-memory +no-exe -system-libarchive,
@@ -123,21 +123,22 @@ constraints: any.Cabal ==3.6.2.0,
libyaml-streamly -no-unicode -system-libyaml, libyaml-streamly -no-unicode -system-libyaml,
any.lockfree-queue ==0.2.3.1, any.lockfree-queue ==0.2.3.1,
any.lzma-static ==5.2.5.4, any.lzma-static ==5.2.5.4,
any.megaparsec ==9.2.1, any.megaparsec ==9.2.0,
megaparsec -dev, megaparsec -dev,
any.microlens ==0.4.12.0, any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.2, any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10, any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.network ==3.1.2.7, any.network ==3.1.2.7,
network -devel, network -devel,
any.network-uri ==2.6.4.1, any.network-uri ==2.6.4.1,
any.openssl-streams ==1.2.3.0, any.openssl-streams ==1.2.3.0,
any.optics ==0.4.2, any.optics ==0.4,
any.optics-core ==0.4.1, any.optics-core ==0.4,
optics-core -explicit-generic-labels, optics-core -explicit-generic-labels,
any.optics-extra ==0.4.2.1, any.optics-extra ==0.4,
any.optics-th ==0.4.1, any.optics-th ==0.4,
any.optparse-applicative ==0.17.0.0, any.optparse-applicative ==0.17.0.0,
optparse-applicative +process, optparse-applicative +process,
any.os-release ==1.0.2.1, any.os-release ==1.0.2.1,
@@ -149,23 +150,23 @@ constraints: any.Cabal ==3.6.2.0,
any.polyparse ==1.13, any.polyparse ==1.13,
any.pretty ==1.1.3.6, any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0, any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.4.0, any.primitive ==0.7.3.0,
any.process ==1.6.13.2, any.process ==1.6.13.2,
any.profunctors ==5.6.2, any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0, any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0, any.quickcheck-io ==0.2.0,
any.random ==1.2.1.1, any.random ==1.2.1,
any.recursion-schemes ==5.2.2.2, any.recursion-schemes ==5.2.2.2,
recursion-schemes +template-haskell, recursion-schemes +template-haskell,
any.regex-base ==0.94.0.2, any.regex-base ==0.94.0.2,
any.regex-posix ==0.96.0.1, any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib, regex-posix -_regex-posix-clib,
any.resourcet ==1.2.5, any.resourcet ==1.2.4.3,
any.retry ==0.8.1.2, any.retry ==0.8.1.2,
retry -lib-werror, retry -lib-werror,
any.rts ==1.0.2, any.rts ==1.0.2,
any.safe ==0.3.19, any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.3, any.safe-exceptions ==0.1.7.2,
any.scientific ==0.3.7.0, any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple, scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1, any.semialign ==1.2.0.1,
@@ -178,7 +179,7 @@ constraints: any.Cabal ==3.6.2.0,
splitmix -optimised-mixer, splitmix -optimised-mixer,
any.stm ==2.5.0.0, any.stm ==2.5.0.0,
any.streamly ==0.8.2, any.streamly ==0.8.2,
streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc +use-unliftio, streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc -use-unliftio,
any.strict ==0.4.0.1, any.strict ==0.4.0.1,
strict +assoc, strict +assoc,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
@@ -212,11 +213,11 @@ constraints: any.Cabal ==3.6.2.0,
any.unicode-data ==0.3.0, any.unicode-data ==0.3.0,
unicode-data -ucd2haskell, unicode-data -ucd2haskell,
any.unix ==2.7.2.2, any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.7, any.unix-bytestring ==0.3.7.6,
any.unix-compat ==0.6, any.unix-compat ==0.5.4,
unix-compat -old-time, unix-compat -old-time,
any.unliftio-core ==0.2.0.1, any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1, any.unordered-containers ==0.2.17.0,
unordered-containers -debug, unordered-containers -debug,
any.uri-bytestring ==0.3.3.1, any.uri-bytestring ==0.3.3.1,
uri-bytestring -lib-werror, uri-bytestring -lib-werror,
@@ -232,7 +233,7 @@ constraints: any.Cabal ==3.6.2.0,
any.xor ==0.0.1.1, any.xor ==0.0.1.1,
any.yaml-streamly ==0.12.1, any.yaml-streamly ==0.12.1,
yaml-streamly +no-examples +no-exe, yaml-streamly +no-examples +no-exe,
any.zlib ==0.6.3.0, any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5 any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2022-06-04T19:47:01Z index-state: hackage.haskell.org 2022-03-15T16:43:02Z

View File

@@ -1,37 +0,0 @@
packages: ./ghcup.cabal
optional-packages: ./vendored/*/*.cabal
optimization: 2
package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size.git
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
constraints: http-io-streams -brotli,
any.Cabal ==3.6.2.0,
any.aeson >= 2.0.1.0,
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
package aeson
flags: +ordered-keymap
package streamly
flags: +use-unliftio
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-9.2.3

View File

@@ -1,233 +0,0 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.6.2.0,
Cabal -bundled-binary-generic,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7.2,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.OneTuple ==0.3.1,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.aeson ==2.0.3.0,
aeson -cffi +ordered-keymap,
any.aeson-pretty ==0.8.9,
aeson-pretty +lib-only,
any.alex ==3.2.7.1,
any.ansi-terminal ==0.11.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.assoc ==1.0.2,
any.async ==2.2.4,
async -bench,
any.atomic-primops ==0.8.4,
atomic-primops -debug,
any.attoparsec ==0.14.4,
attoparsec -developer,
any.base ==4.16.2.0,
any.base-compat ==0.12.1,
any.base-compat-batteries ==0.12.1,
any.base-orphans ==0.8.6,
any.base16-bytestring ==1.0.2.0,
any.base64-bytestring ==1.2.1.0,
any.bifunctors ==5.5.12,
bifunctors +semigroups +tagged,
any.binary ==0.8.9.0,
any.blaze-builder ==0.4.2.2,
any.brick ==0.64.2,
brick -demos,
any.bytestring ==0.11.3.1,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-plan ==0.7.2.1,
cabal-plan -_ -exe -license-report,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.chs-cabal ==0.1.1.1,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.3,
clock -llvm,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
any.cryptohash-sha1 ==0.11.101.0,
any.cryptohash-sha256 ==0.11.102.1,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.2,
any.data-fix ==0.3.2,
any.deepseq ==1.4.6.1,
any.directory ==1.3.7.0,
any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.exceptions ==0.10.4,
any.filepath ==1.4.2.2,
any.free ==5.1.8,
any.fusion-plugin-types ==0.1.0,
any.generic-arbitrary ==0.2.2,
any.ghc-bignum ==1.2,
any.ghc-boot-th ==9.2.3,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.8.0,
any.happy ==1.20.0,
any.hashable ==1.4.0.2,
hashable +containers +integer-gmp -random-initial-seed,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.2.1,
any.heaps ==0.4,
any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree,
any.hspec ==2.9.2,
any.hspec-core ==2.9.2,
any.hspec-discover ==2.9.2,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.1,
http-io-streams -brotli +fast-xor,
any.indexed-profunctors ==0.1.1,
any.indexed-traversable ==0.1.2,
any.indexed-traversable-instances ==0.1.1,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.io-streams ==1.5.2.1,
io-streams +network -nointeractivetests +zlib,
any.language-c ==0.9.1,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.3.2,
libarchive -cross -low-memory +no-exe -system-libarchive,
any.libyaml-streamly ==0.2.1,
libyaml-streamly -no-unicode -system-libyaml,
any.lockfree-queue ==0.2.3.1,
any.lzma-static ==5.2.5.4,
any.megaparsec ==9.2.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.2,
any.microlens-th ==0.4.3.10,
any.mtl ==2.2.2,
any.network ==3.1.2.7,
network -devel,
any.network-uri ==2.6.4.1,
any.openssl-streams ==1.2.3.0,
any.optics ==0.4.2,
any.optics-core ==0.4.1,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4.2.1,
any.optics-th ==0.4.1,
any.optparse-applicative ==0.17.0.0,
optparse-applicative +process,
any.os-release ==1.0.2.1,
os-release -devel,
any.parallel ==3.2.2.0,
any.parsec ==3.1.15.0,
any.parser-combinators ==1.3.0,
parser-combinators -dev,
any.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.4.0,
any.process ==1.6.14.0,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0,
any.random ==1.2.1.1,
any.recursion-schemes ==5.2.2.2,
recursion-schemes +template-haskell,
any.regex-base ==0.94.0.2,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.5,
any.retry ==0.8.1.2,
retry -lib-werror,
any.rts ==1.0.2,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.3,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.4,
splitmix -optimised-mixer,
any.stm ==2.5.0.2,
any.streamly ==0.8.2,
streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc +use-unliftio,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tagsoup ==0.14.8,
any.template-haskell ==2.18.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.5,
any.text ==1.2.5.0,
any.text-short ==0.1.5,
text-short -asserts,
any.text-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.3.0,
any.th-compat ==0.1.3,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.19,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6.1,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7.1,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.unicode-data ==0.3.0,
unicode-data -ucd2haskell,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.7,
any.unix-compat ==0.6,
unix-compat -old-time,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1,
unordered-containers -debug,
any.uri-bytestring ==0.3.3.1,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.2,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.1,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.versions ==5.0.3,
any.vty ==5.33,
any.witherable ==0.4.2,
any.word-wrap ==0.5,
any.word8 ==0.1.3,
any.xor ==0.0.1.1,
any.yaml-streamly ==0.12.1,
yaml-streamly +no-examples +no-exe,
any.zlib ==0.6.3.0,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2022-06-04T19:47:01Z

View File

@@ -5,6 +5,7 @@ optional-packages: ./vendored/*/*.cabal
optimization: 2 optimization: 2
package ghcup package ghcup
tests: True
flags: +tui flags: +tui
source-repository-package source-repository-package
@@ -14,7 +15,7 @@ source-repository-package
constraints: http-io-streams -brotli, constraints: http-io-streams -brotli,
any.Cabal ==3.6.2.0, any.Cabal ==3.6.2.0,
any.aeson >= 2.0.1.0, any.aeson >= 2.0.1.0
package libarchive package libarchive
flags: -system-libarchive flags: -system-libarchive
@@ -28,7 +29,4 @@ package cabal-plan
package aeson package aeson
flags: +ordered-keymap flags: +ordered-keymap
package streamly
flags: +use-unliftio
allow-newer: base, ghc-prim, template-haskell, language-c allow-newer: base, ghc-prim, template-haskell, language-c

View File

@@ -1,7 +0,0 @@
#include "dirutils.h"
unsigned int
__posixdir_d_type(struct dirent* d)
{
return(d -> d_type);
}

View File

@@ -1,16 +0,0 @@
#ifndef POSIXPATHS_CBITS_DIRUTILS_H
#define POSIXPATHS_CBITS_DIRUTILS_H
#include <HsFFI.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
extern unsigned int
__posixdir_d_type(struct dirent* d)
;
#endif

View File

@@ -75,14 +75,3 @@ url-source:
# AddSource: # AddSource:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
# This is a way to override platform detection, e.g. when you're running
# a Ubuntu derivate based on 18.04, you could do:
#
# platform-override:
# arch: A_64
# platform:
# contents: Ubuntu
# tag: Linux
# version: '18.04'
platform-override: null

View File

@@ -1,71 +0,0 @@
FROM i386/alpine:3.12
ENV LANG C.UTF-8
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
coreutils \
bsd-compat-headers \
gmp-dev \
ncurses-dev \
libffi-dev \
make \
xz \
tar \
perl \
bash \
diffutils \
git \
gzip \
gnupg && \
apk add --no-cache \
zlib \
zlib-dev \
zlib-static \
bzip2 \
bzip2-dev \
bzip2-static \
gmp \
gmp-dev \
openssl-dev \
openssl-libs-static \
xz \
xz-dev \
ncurses-static
ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/i386-linux-ghcup-$GHCUP_VERSION && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS.sig && \
gpg --verify SHA256SUMS.sig SHA256SUMS && \
sha256sum -c --ignore-missing SHA256SUMS && \
mv i386-linux-ghcup-$GHCUP_VERSION /usr/bin/ghcup && \
chmod +x /usr/bin/ghcup && \
rm -rf SHA256SUMS SHA256SUMS.sig
ARG GHC=8.10.7
ARG CABAL_INSTALL=3.6.2.0
ARG STACK=2.9.1
ENV GHCUP_CURL_OPTS="--silent"
ENV NO_COLOR=1
# install haskell toolchain
RUN ghcup config set gpg-setting GPGStrict && \
ghcup --verbose install ghc --isolate=/usr --force ${GHC} && \
ghcup --verbose install cabal --isolate=/usr/bin --force ${CABAL_INSTALL} && \
find "/usr/lib/ghc-${GHC}/" \( -name "*_p.a" -o -name "*.p_hi" \) -type f -delete && \
rm -r "/usr/share/doc/ghc-${GHC}" && \
rm -rf /tmp/ghcup* && \
ghcup gc -p -s -c -t
ENV PATH /root/.cabal/bin:/root/.ghcup:/root/.local/bin:$PATH

View File

@@ -1,71 +0,0 @@
FROM alpine:3.12
ENV LANG C.UTF-8
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
coreutils \
bsd-compat-headers \
gmp-dev \
ncurses-dev \
libffi-dev \
make \
xz \
tar \
perl \
bash \
diffutils \
git \
gzip \
gnupg && \
apk add --no-cache \
zlib \
zlib-dev \
zlib-static \
bzip2 \
bzip2-dev \
bzip2-static \
gmp \
gmp-dev \
openssl-dev \
openssl-libs-static \
xz \
xz-dev \
ncurses-static
ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS.sig && \
gpg --verify SHA256SUMS.sig SHA256SUMS && \
sha256sum -c --ignore-missing SHA256SUMS && \
mv x86_64-linux-ghcup-$GHCUP_VERSION /usr/bin/ghcup && \
chmod +x /usr/bin/ghcup && \
rm -rf SHA256SUMS SHA256SUMS.sig
ARG GHC=8.10.7
ARG CABAL_INSTALL=3.6.2.0
ARG STACK=2.9.1
ENV GHCUP_CURL_OPTS="--silent"
ENV NO_COLOR=1
# install haskell toolchain
RUN ghcup config set gpg-setting GPGStrict && \
ghcup --verbose install ghc --isolate=/usr --force ${GHC} && \
ghcup --verbose install cabal --isolate=/usr/bin --force ${CABAL_INSTALL} && \
find "/usr/lib/ghc-${GHC}/" \( -name "*_p.a" -o -name "*.p_hi" \) -type f -delete && \
rm -r "/usr/share/doc/ghc-${GHC}" && \
rm -rf /tmp/ghcup* && \
ghcup gc -p -s -c -t
ENV PATH /root/.cabal/bin:/root/.ghcup:/root/.local/bin:$PATH

View File

@@ -1,64 +0,0 @@
FROM arm32v7/ubuntu:focal
ENV LANG C.UTF-8
ENV DEBIAN_FRONTEND=noninteractive
ENV TZ=Asia/Singapore
COPY update_opt.sh /usr/bin/update_opt.sh
RUN chmod +x /usr/bin/update_opt.sh
RUN apt-get update && \
apt-get install -y --no-install-recommends \
ca-certificates \
curl \
dirmngr \
g++ \
git \
gnupg \
libsqlite3-dev \
libtinfo-dev \
libgmp-dev \
make \
netbase \
openssh-client \
xz-utils \
zlib1g-dev \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip patchelf tree \
llvm-9 clang-9 && \
rm -rf /var/lib/apt/lists/*
RUN update_opt.sh 9 1
ARG GHCUP_VERSION=0.1.17.8
ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/armv7-linux-ghcup-$GHCUP_VERSION && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS.sig && \
gpg --verify SHA256SUMS.sig SHA256SUMS && \
sha256sum -c --ignore-missing SHA256SUMS && \
mv armv7-linux-ghcup-$GHCUP_VERSION /usr/bin/ghcup && \
chmod +x /usr/bin/ghcup && \
rm -rf SHA256SUMS SHA256SUMS.sig
ARG GHC=8.10.7
ARG CABAL_INSTALL=3.6.2.0
ARG STACK=2.9.1
ENV GHCUP_CURL_OPTS="--silent"
ENV NO_COLOR=1
# install haskell toolchain
RUN ghcup config set gpg-setting GPGStrict && \
ghcup --verbose install ghc --isolate=/usr --force ${GHC} && \
ghcup --verbose install cabal --isolate=/usr/bin --force ${CABAL_INSTALL} && \
find "/usr/lib/ghc-${GHC}/" \( -name "*_p.a" -o -name "*.p_hi" \) -type f -delete && \
rm -r "/usr/share/doc/ghc-${GHC}" && \
rm -rf /tmp/ghcup* && \
ghcup gc -p -s -c -t
ENV PATH /root/.cabal/bin:/root/.ghcup/bin:/root/.local/bin:$PATH
CMD ["ghci"]

View File

@@ -1,36 +0,0 @@
#!/bin/bash
# update_alternatives.sh
update_alternatives() {
local version=${1}
local priority=${2}
local master=${3}
local slaves=${4}
local path=${5}
local cmdln
cmdln="--verbose --install ${path}${master} ${master} ${path}${master}-${version} ${priority}"
for slave in ${slaves}; do
cmdln="${cmdln} --slave ${path}${slave} ${slave} ${path}${slave}-${version}"
done
update-alternatives ${cmdln}
}
if [[ ${#} -ne 2 ]]; then
echo usage: "${0}" clang_version priority
exit 1
fi
version=${1}
priority=${2}
path="/usr/bin/"
master="llvm-config"
slaves="llvm-addr2line llvm-ar llvm-as llvm-bcanalyzer llvm-bitcode-strip llvm-cat llvm-cfi-verify llvm-cov llvm-c-test llvm-cvtres llvm-cxxdump llvm-cxxfilt llvm-cxxmap llvm-debuginfod llvm-debuginfod-find llvm-diff llvm-dis llvm-dlltool llvm-dwarfdump llvm-dwarfutil llvm-dwp llvm-exegesis llvm-extract llvm-gsymutil llvm-ifs llvm-install-name-tool llvm-jitlink llvm-jitlink-executor llvm-lib llvm-libtool-darwin llvm-link llvm-lipo llvm-lto llvm-lto2 llvm-mc llvm-mca llvm-ml llvm-modextract llvm-mt llvm-nm llvm-objcopy llvm-objdump llvm-omp-device-info llvm-opt-report llvm-otool llvm-pdbutil llvm-PerfectShuffle llvm-profdata llvm-profgen llvm-ranlib llvm-rc llvm-readelf llvm-readobj llvm-reduce llvm-remark-size-diff llvm-rtdyld llvm-sim llvm-size llvm-split llvm-stress llvm-strings llvm-strip llvm-symbolizer llvm-tapi-diff llvm-tblgen llvm-tli-checker llvm-undname llvm-windres llvm-xray"
update_alternatives "${version}" "${priority}" "${master}" "${slaves}" "${path}"
master="clang"
slaves="analyze-build asan_symbolize bugpoint c-index-test clang++ clang-apply-replacements clang-change-namespace clang-check clang-cl clang-cpp clangd clang-doc clang-extdef-mapping clang-format clang-format-diff clang-include-fixer clang-linker-wrapper clang-move clang-nvlink-wrapper clang-offload-bundler clang-offload-packager clang-offload-wrapper clang-pseudo clang-query clang-refactor clang-rename clang-reorder-fields clang-repl clang-scan-deps clang-tidy count diagtool dsymutil FileCheck find-all-symbols git-clang-format hmaptool hwasan_symbolize intercept-build ld64.lld ld.lld llc lld lldb lldb-argdumper lldb-instr lldb-server lldb-vscode lld-link lli lli-child-target modularize not obj2yaml opt pp-trace run-clang-tidy sancov sanstats scan-build scan-build-py scan-view split-file UnicodeNameMappingGenerator verify-uselistorder wasm-ld yaml2obj yaml-bench"
update_alternatives "${version}" "${priority}" "${master}" "${slaves}" "${path}"

View File

@@ -1,64 +0,0 @@
FROM arm64v8/ubuntu:focal
ENV LANG C.UTF-8
ENV DEBIAN_FRONTEND=noninteractive
ENV TZ=Asia/Singapore
COPY update_opt.sh /usr/bin/update_opt.sh
RUN chmod +x /usr/bin/update_opt.sh
RUN apt-get update && \
apt-get install -y --no-install-recommends \
ca-certificates \
curl \
dirmngr \
g++ \
git \
gnupg \
libsqlite3-dev \
libtinfo-dev \
libgmp-dev \
make \
netbase \
openssh-client \
xz-utils \
zlib1g-dev \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip patchelf tree \
llvm-9 clang-9 && \
rm -rf /var/lib/apt/lists/*
RUN update_opt.sh 9 1
ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/aarch64-linux-ghcup-$GHCUP_VERSION && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS && \
curl -sSfL -O https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/SHA256SUMS.sig && \
gpg --verify SHA256SUMS.sig SHA256SUMS && \
sha256sum -c --ignore-missing SHA256SUMS && \
mv aarch64-linux-ghcup-$GHCUP_VERSION /usr/bin/ghcup && \
chmod +x /usr/bin/ghcup && \
rm -rf SHA256SUMS SHA256SUMS.sig
ARG GHC=8.10.7
ARG CABAL_INSTALL=3.6.2.0
ARG STACK=2.9.1
ENV GHCUP_CURL_OPTS="--silent"
ENV NO_COLOR=1
# install haskell toolchain
RUN ghcup config set gpg-setting GPGStrict && \
ghcup --verbose install ghc --isolate=/usr --force ${GHC} && \
ghcup --verbose install cabal --isolate=/usr/bin --force ${CABAL_INSTALL} && \
find "/usr/lib/ghc-${GHC}/" \( -name "*_p.a" -o -name "*.p_hi" \) -type f -delete && \
rm -r "/usr/share/doc/ghc-${GHC}" && \
rm -rf /tmp/ghcup* && \
ghcup gc -p -s -c -t
ENV PATH /root/.cabal/bin:/root/.ghcup/bin:/root/.local/bin:$PATH
CMD ["ghci"]

View File

@@ -1,36 +0,0 @@
#!/bin/bash
# update_alternatives.sh
update_alternatives() {
local version=${1}
local priority=${2}
local master=${3}
local slaves=${4}
local path=${5}
local cmdln
cmdln="--verbose --install ${path}${master} ${master} ${path}${master}-${version} ${priority}"
for slave in ${slaves}; do
cmdln="${cmdln} --slave ${path}${slave} ${slave} ${path}${slave}-${version}"
done
update-alternatives ${cmdln}
}
if [[ ${#} -ne 2 ]]; then
echo usage: "${0}" clang_version priority
exit 1
fi
version=${1}
priority=${2}
path="/usr/bin/"
master="llvm-config"
slaves="llvm-addr2line llvm-ar llvm-as llvm-bcanalyzer llvm-bitcode-strip llvm-cat llvm-cfi-verify llvm-cov llvm-c-test llvm-cvtres llvm-cxxdump llvm-cxxfilt llvm-cxxmap llvm-debuginfod llvm-debuginfod-find llvm-diff llvm-dis llvm-dlltool llvm-dwarfdump llvm-dwarfutil llvm-dwp llvm-exegesis llvm-extract llvm-gsymutil llvm-ifs llvm-install-name-tool llvm-jitlink llvm-jitlink-executor llvm-lib llvm-libtool-darwin llvm-link llvm-lipo llvm-lto llvm-lto2 llvm-mc llvm-mca llvm-ml llvm-modextract llvm-mt llvm-nm llvm-objcopy llvm-objdump llvm-omp-device-info llvm-opt-report llvm-otool llvm-pdbutil llvm-PerfectShuffle llvm-profdata llvm-profgen llvm-ranlib llvm-rc llvm-readelf llvm-readobj llvm-reduce llvm-remark-size-diff llvm-rtdyld llvm-sim llvm-size llvm-split llvm-stress llvm-strings llvm-strip llvm-symbolizer llvm-tapi-diff llvm-tblgen llvm-tli-checker llvm-undname llvm-windres llvm-xray"
update_alternatives "${version}" "${priority}" "${master}" "${slaves}" "${path}"
master="clang"
slaves="analyze-build asan_symbolize bugpoint c-index-test clang++ clang-apply-replacements clang-change-namespace clang-check clang-cl clang-cpp clangd clang-doc clang-extdef-mapping clang-format clang-format-diff clang-include-fixer clang-linker-wrapper clang-move clang-nvlink-wrapper clang-offload-bundler clang-offload-packager clang-offload-wrapper clang-pseudo clang-query clang-refactor clang-rename clang-reorder-fields clang-repl clang-scan-deps clang-tidy count diagtool dsymutil FileCheck find-all-symbols git-clang-format hmaptool hwasan_symbolize intercept-build ld64.lld ld.lld llc lld lldb lldb-argdumper lldb-instr lldb-server lldb-vscode lld-link lli lli-child-target modularize not obj2yaml opt pp-trace run-clang-tidy sancov sanstats scan-build scan-build-py scan-view split-file UnicodeNameMappingGenerator verify-uselistorder wasm-ld yaml2obj yaml-bench"
update_alternatives "${version}" "${priority}" "${master}" "${slaves}" "${path}"

View File

@@ -42,8 +42,8 @@ All you wanted to know about GHCup.
## How to help ## How to help
* if you want to contribute code or documentation, check out the [issue tracker](https://github.com/haskell/ghcup-hs/issues) and the [Development guide](./dev.md) * if you want to contribute code or documentation, check out the [issue tracker](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues) and the [Development guide](./dev.md)
* if you want to propose features or write user feedback, feel free to [open a ticket](https://github.com/haskell/ghcup-hs/issues/new) * if you want to propose features or write user feedback, feel free to [open a ticket](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/new?issue)
* if you want to donate to the project, visit our [opencollective](https://opencollective.com/ghcup#category-CONTRIBUTE) page * if you want to donate to the project, visit our [opencollective](https://opencollective.com/ghcup#category-CONTRIBUTE) page
## Design goals ## Design goals
@@ -74,15 +74,12 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
## Known users ## Known users
* CI: * Github actions:
- [Github actions/virtual-environments](https://github.com/actions/virtual-environments) - [actions/virtual-environments](https://github.com/actions/virtual-environments)
- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup) - [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
* mirrors: * mirrors:
- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup) - [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
* tools: * tools:
- [vscode-haskell](https://github.com/haskell/vscode-haskell)
- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
- [vabal](https://github.com/Franciman/vabal) - [vabal](https://github.com/Franciman/vabal)
## Known problems ## Known problems
@@ -155,11 +152,6 @@ Windows 7 and Powershell 2.0 aren't well supported at the moment, also see:
## FAQ ## FAQ
### Is ghcup really the main installer?
This is based on the Haskell survey results from 2022, which show that more
than half of survey participants use GHCup: https://taylor.fausak.me/2022/11/18/haskell-survey-results/
### Why reimplement stack? ### Why reimplement stack?
GHCup is not a reimplementation of stack. The only common part is automatic installation of GHC, GHCup is not a reimplementation of stack. The only common part is automatic installation of GHC,

View File

@@ -69,9 +69,9 @@ Head over to: [https://github.com/haskell/ghcup-metadata#adding-a-new-ghc-versio
### Adding a new CLI command ### Adding a new CLI command
An example illustration on how to deal with [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative) can be seen here: [https://github.com/haskell/ghcup-hs/commit/c19dd5ee8b2edbaf0336af143f1c75b6f4843e26](https://github.com/haskell/ghcup-hs/commit/c19dd5ee8b2edbaf0336af143f1c75b6f4843e26) An example illustration on how to deal with [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative) can be seen here: [https://gitlab.haskell.org/haskell/ghcup-hs/-/commit/c19dd5ee8b2edbaf0336af143f1c75b6f4843e26](https://gitlab.haskell.org/haskell/ghcup-hs/-/commit/c19dd5ee8b2edbaf0336af143f1c75b6f4843e26)
Every subcommand now lives in its own module under [GHCup.OptParse.MyCommand](https://github.com/haskell/ghcup-hs/tree/master/app/ghcup/GHCup/OptParse). Every subcommand now lives in its own module under [GHCup.OptParse.MyCommand](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/app/ghcup/GHCup/OptParse).
## Major refactors ## Major refactors

View File

@@ -1,10 +1,10 @@
# User Guide # User Guide
This is a more in-depth guide specific to GHCup. `ghcup --help` is your friend. `ghcup --help` is your friend.
## Basic usage ## Basic usage
For the simple, interactive, text-based user interface (TUI) (not available on windows), run: For the simple interactive TUI (not available on windows), run:
```sh ```sh
ghcup tui ghcup tui
@@ -43,6 +43,13 @@ All of the following are valid arguments to `ghcup install ghc`:
If the argument is omitted, the default is `recommended`. If the argument is omitted, the default is `recommended`.
## Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml).
Partial configuration is fine. Command line options always override the config file settings.
## Manpages ## Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc. For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
@@ -50,71 +57,13 @@ For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man`
## Shell-completion ## Shell-completion
Shell completions are in [scripts/shell-completions](https://github.com/haskell/ghcup-hs/tree/master/scripts/shell-completions) directory of this repository. Shell completions are in [scripts/shell-completions](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/scripts/shell-completions) directory of this repository.
For bash: install `shell-completions/bash` For bash: install `shell-completions/bash`
as e.g. `/etc/bash_completion.d/ghcup` (depending on distro) as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros). (`/usr/share/bash-completion/bash_completion` on some distros).
## Portability
`ghcup` is very portable. There are a few exceptions though:
1. `ghcup tui` is only available on non-windows platforms
2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
# Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml).
Partial configuration is fine. Command line options always override the config file settings.
## Overriding distro detection
If you're running e.g. an Ubuntu derivate based on 18.04 and ghcup is picking bindists that
don't work well, you could do this in `config.yaml`:
```yml
platform-override:
arch: A_64
platform:
contents: Ubuntu
tag: Linux
version: '18.04'
```
## Env variables
This is the complete list of env variables that change GHCup behavior:
* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup
On windows, there's additionally:
* `GHCUP_MSYS2`: Has to point to the root of an existing MSYS2 installation (when installed by GHCup, that's e.g. `C:\ghcup\msys64`). GHCup bootstrap takes care of this usually.
### XDG support
To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
Then you can control the locations via XDG environment variables as such:
* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
**Note that `ghcup` makes some assumptions about structure of files in `XDG_BIN_HOME`. So if you have other tools
installing e.g. stack/cabal/ghc into it, this will likely clash. In that case consider disabling XDG support.**
## Caching ## Caching
GHCup has a few caching mechanisms to avoid redownloads. All cached files end up in `~/.ghcup/cache` by default. GHCup has a few caching mechanisms to avoid redownloads. All cached files end up in `~/.ghcup/cache` by default.
@@ -134,254 +83,18 @@ have a 5 minutes cache per default depending on the last access time of the file
If you experience problems, consider clearing the cache via `ghcup gc --cache`. If you experience problems, consider clearing the cache via `ghcup gc --cache`.
## Metadata ## Compiling GHC from source
The metadata are the files that describe tool versions, where to download them etc. and
can be viewed here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata)
### Mirrors
GHCup allows to use custom mirrors/download-info hosted by yourself or 3rd parties.
To use a mirror, set the following option in `~/.ghcup/config.yaml`:
```yml
url-source:
# Accepts file/http/https scheme
OwnSource: "https://some-url/ghcup-0.0.6.yaml"
```
See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
for more options.
Alternatively you can do it via a cli switch:
```sh
ghcup --url-source=https://some-url/ghcup-0.0.6.yaml list
```
#### Known mirrors
1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
### (Pre-)Release channels
A release channel is basically just a metadata file location. You can add additional release
channels that complement the default one, such as the **prerelease channel** like so:
```sh
ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
```
This will result in `~/.ghcup/config.yaml` to contain this record:
```yml
url-source:
AddSource:
- Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
```
You can add as many channels as you like. They are combined under *Last*, so versions from the prerelease channel
here overwrite the default ones, if any.
To remove the channel, delete the entire `url-source` section or set it back to the default:
```yml
url-source:
GHCupURL: []
```
If you want to combine your release channel with a mirror, you'd do it like so:
```yml
url-source:
OwnSource:
# base metadata
- "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
# prerelease channel
- "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
```
## Stack integration
Stack manages GHC versions internally by default. In order to make it use ghcup installed
GHC versions there are two strategies.
### Strategy 1: System GHC (works on all stack versions)
You can instruct stack to use "system" GHC versions (whatever is in PATH). To do so,
run the following commands:
```sh
stack config set install-ghc false --global
stack config set system-ghc true --global
```
### Strategy 2: Stack hooks (new, recommended)
Since stack 2.9.1 you can customize the installation logic of GHC completely, see [https://docs.haskellstack.org/en/stable/yaml_configuration/#ghc-installation-customisation](https://docs.haskellstack.org/en/stable/yaml_configuration/#ghc-installation-customisation).
We can use this to simply invoke ghcup whenever stack is trying to install/discover a GHC versions. This
is done via placing a shell script at `~/.stack/hooks/ghc-install.sh` and making it executable.
The ghcup bootstrap script asks you during installation whether you want to install this shell script. You can also
install/update it manually like so:
```sh
mkdir -p ~/.stack/hooks/
curl https://raw.githubusercontent.com/haskell/ghcup-hs/master/scripts/hooks/stack/ghc-install.sh \
> ~/.stack/hooks/ghc-install.sh
chmod +x ~/.stack/hooks/ghc-install.sh
# hooks are only run when 'system-ghc: false'
stack config set system-ghc false --global
```
By default, when the hook fails for whatever reason, stack will fall back to its own installation logic. To disable
this, run `stack config set install-ghc false --global`.
### Windows
On windows, you may find the following config options useful too:
`skip-msys`, `extra-path`, `extra-include-dirs`, `extra-lib-dirs`.
Also check out: [https://docs.haskellstack.org/en/stable/yaml_configuration](https://docs.haskellstack.org/en/stable/yaml_configuration)
# More on installation
## Customisation of the installation scripts
The scripts offered to install GHCup are available here:
* [bootstrap-haskell](https://github.com/haskell/ghcup-hs/blob/master/scripts/bootstrap/bootstrap-haskell#L7)
for Unix-like operating systems
* [bootstrap-haskell.ps1](https://github.com/haskell/ghcup-hs/blob/master/scripts/bootstrap/bootstrap-haskell.ps1)
for Windows (PowerShell). This will, in turn, run the final bootstrap script
(by default, that for the Unix-like operating systems).
The effect of the scripts can be customised by setting one or more
`BOOTSTRAP_HASKELL_*` environment variables (as set out in the first script)
and, in the case of Windows, by specifying parameters (as set out in the
PowerShell script).
For example, you can toggle:
* non-interactive installation
* a more verbose installation
* whether to install only GHCup (and, on Windows, MSYS2)
* not to trigger the upgrade of GHCup
* whether to install the latest version of HLS
* whether to install the latest version of Stack
* whether to respect the XDG Base Directory Specification
* whether to adjust (prepend) the PATH in `bashrc`
* on Windows, whether to adjust MINGW paths in `cabal.config`
You can also specify:
* the GHC version to install
* the Cabal version to install
* which downloader to use (the default is `curl`)
* the base URL for the download of the GHCup binary distribution
On Windows, you can also use the parameters to:
* toggle whether to overwrite a previous installation
* specify the GHCup installation root directory
* specify the Cabal root directory
* specify the directory of an existing installation of MSYS2 (for example,
the one supplied by Stack)
* specify the URL of the final bootstrap script
* toggle whether to run the final bootstrap script via `bash` (instead of in a
new MSYS2 shell)
## Installing custom bindists
There are a couple of good use cases to install custom bindists:
1. manually built bindists (e.g. with patches)
- example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
2. GHC head CI bindists
- example specifying a branch (`master`): `ghcup install ghc -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head`
- example specifying a job id (`1129565`): `ghcup install ghc -u ' https://gitlab.haskell.org/api/v4/projects/1/jobs/1129565/artifacts/ghc-x86_64-linux-alpine3_12-validate+fully_static.tar.xz' mr7847`
3. DWARF bindists
- example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected).
## Compiling from source
### GHC
Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help` Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`
for a list of all available options. for a list of all available options.
If you need to overwrite the existing `build.mk`, check the default files If you need to overwrite the existing `build.mk`, check the default files
in [data/build_mk](https://github.com/haskell/ghcup-hs/tree/master/data/build_mk), copy them somewhere, adjust them and in [data/build_mk](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/data/build_mk), copy them somewhere, adjust them and
pass `--config path/to/build.mk` to `ghcup compile ghc`. pass `--config path/to/build.mk` to `ghcup compile ghc`.
Common `build.mk` options are explained [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/using#build-configuration). Common `build.mk` options are explained [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/using#build-configuration).
Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation). Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation).
### HLS
There are 3 main ways to compile HLS from source.
1. from hackage (should have up to date version bounds)
- `ghcup compile hls --version 1.7.0.0 --ghc 9.2.3`
2. from git (allows to build latest sources and PRs)
- `ghcup compile hls --git-ref master --ghc 9.2.3`
- `ghcup compile hls --git-ref a32db0b --ghc 9.2.3`
- `ghcup compile hls --git-ref 1.7.0.0 --ghc 9.2.3`
3. from source distribution that's packaged during release from the corresponding git sources
- `ghcup compile hls --source-dist 1.7.0.0 --ghc 9.2.3`
All these use `cabal v2-install` under the hood, so all build components are cached.
You can pass arbitrary arguments to cabal, e.g. set the index state like so:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 -- --index-state=2022-06-12T00:00:00Z --allow-newer
```
You can pass `--ghc <ver>` multiple times to install for many GHCs at once.
When building from git sources, ghcup will auto-detect the HLS version that the git commit corresponds to
from the `haskell-language-server.cabal` file. This version might not have been updated since the last release.
If you want to avoid overwriting the existing installed HLS version, you can instruct ghcup to use `git describe`
to set the HLS version instead:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 --git-describe-version
```
You can also set the version explicitly:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 --overwrite-version 1.7.0.0-p1
```
To instruct cabal to run `cabal update` before building, run `ghcup compile hls --version 1.7.0.0 --ghc 9.2.3 --cabal-update`
As always, check `ghcup compile hls --help`.
#### Updating HLS for a new GHC version
First try to build from hackage with some tricks:
```sh
ghcup compile hls --version 1.7.0.0 --ghc 9.2.4 --cabal-update -- --allow-newer --index-state=2022-06-12T00:00:00Z
```
This augments the currently installed 1.7.0.0 official bindists in ghcup with new GHC versions support.
If that fails (since `--allow-newer` is quite brutal), you can install from HLS master branch (which may contain new fixes) like so:
```
ghcup compile hls --git-ref master --git-describe-version --ghc 8.10.7 --ghc 9.2.4 --cabal-update
```
This however will create a new HLS version in ghcup, e.g. `1.7.0.0-105-gdc682ba1`, for both 8.10.7 and 9.2.4. If you want to switch back to the official bindists, run `ghcup set hls 1.7.0.0`.
### Cross support ### Cross support
ghcup can compile and install a cross GHC for any target. However, this ghcup can compile and install a cross GHC for any target. However, this
@@ -393,9 +106,75 @@ For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args. libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information. See `ghcup compile ghc --help` for further information.
## Isolated installs ## XDG support
**Before using isolated installs, make sure to have at least GHCup version 0.1.17.8!** To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
Then you can control the locations via XDG environment variables as such:
* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
**Note that `ghcup` makes some assumptions about structure of files in `XDG_BIN_HOME`. So if you have other tools
installing e.g. stack/cabal/ghc into it, this will likely clash. In that case consider disabling XDG support.**
## Env variables
This is the complete list of env variables that change GHCup behavior:
* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup
## Installing custom bindists
There are a couple of good use cases to install custom bindists:
1. manually built bindists (e.g. with patches)
- example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
2. GHC head CI bindists
- example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
3. DWARF bindists
- example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected).
## Mirrors
GHCup allows to use custom mirrors/download-info hosted by yourself or 3rd parties.
To use a mirror, set the following option in `~/.ghcup/config.yaml`:
```yml
url-source:
# Accepts file/http/https scheme
OwnSource: "https://some-url/ghcup-0.0.6.yaml"
```
See [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml)
for more options.
Alternatively you can do it via a cli switch:
```sh
ghcup --url-source=https://some-url/ghcup-0.0.6.yaml list
```
### Known mirrors
1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
## Isolated installs
Ghcup also enables you to install a tool (GHC, Cabal, HLS, Stack) at an isolated location of your choosing. Ghcup also enables you to install a tool (GHC, Cabal, HLS, Stack) at an isolated location of your choosing.
These installs, as the name suggests, are separate from your main installs and DO NOT conflict with them. These installs, as the name suggests, are separate from your main installs and DO NOT conflict with them.
@@ -409,43 +188,41 @@ You need to use the `--isolate` or `-i` flag followed by the directory path.
Examples: Examples:
1. install an isolated GHC version at location /home/user/isolated_dir/ghc/ 1. install an isolated GHC version at location /home/user/isolated_dir/ghc/
- `ghcup install ghc 8.10.5 --isolate /home/user/isolated_dir/ghc` - `ghcup install ghc 8.10.5 --isolate /home/user/isolated_dir/ghc`
2. isolated install Cabal at a location you desire 2. isolated install Cabal at a location you desire
- `ghcup install cabal --isolate /home/username/my_isolated_dir/` - `ghcup install cabal --isolate /home/username/my_isolated_dir/`
3. do an isolated install with a custom bindist 3. do an isolated install with a custom bindist
- `ghcup install ghc --isolate /home/username/my_isolated_dir/ -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head` - `ghcup install ghc --isolate /home/username/my_isolated_dir/ -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
4. isolated install HLS 4. isolated install HLS
- `ghcup install hls --isolate /home/username/dir/hls/` - `ghcup install hls --isolate /home/username/dir/hls/`
5. you can even compile ghc to an isolated location. 5. you can even compile ghc to an isolated location.
- `ghcup compile ghc -j 4 -v 9.0.1 -b 8.10.5 -i /home/username/my/dir/ghc` - `ghcup compile ghc -j 4 -v 9.0.1 -b 8.10.5 -i /home/username/my/dir/ghc`
## Continuous integration ## Continuous integration
On Windows, GHCup can be installed automatically on a CI runner On windows, ghcup can be installed automatically on a CI runner non-interactively like so:
non-interactively, as below. The paramaters to the PowerShell script are
specified positionally, after `-ArgumentList`:
```ps ```ps
$ErrorActionPreference = 'Stop';Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;try { Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\" } catch { Write-Error $_ } Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
``` ```
`$ErrorActionPreference = 'Stop'` here acts like `set -e` and stops execution if ghcup installation fails.
On linux/darwin/freebsd, run the following on your runner: On linux/darwin/freebsd, run the following on your runner:
```sh ```sh
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
``` ```
This will just install `ghcup` and on Windows additionally MSYS2. This will just install `ghcup` and on windows additionally `msys2`.
See the installation scripts referred to above for the full list of environment For the full list of env variables and parameters to tweak the script behavior, see:
variables and, in the case of Windows, parameters to tweak the script behavior.
* [bootstrap-haskell for linux/darwin/freebsd](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell#L7)
* [bootstrap-haskell.ps1 for windows](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell.ps1#L17)
### github workflows ### github workflows
@@ -457,11 +234,10 @@ GHCup itself is also pre-installed on all platforms, but may use non-standard in
GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
this is cryptographically secure. this is cryptographically secure.
First, obtain the gpg keys: First, obtain the gpg key:
```sh ```sh
gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
``` ```
Then verify the gpg key in one of these ways: Then verify the gpg key in one of these ways:
@@ -480,10 +256,10 @@ gpg-setting: GPGLax # GPGStrict | GPGLax | GPGNone
In `GPGStrict` mode, ghcup will fail if verification fails. In `GPGLax` mode it will just print a warning. In `GPGStrict` mode, ghcup will fail if verification fails. In `GPGLax` mode it will just print a warning.
You can also pass the mode via `ghcup --gpg <strict|lax|none>`. You can also pass the mode via `ghcup --gpg <strict|lax|none>`.
## Tips and tricks
# Tips and tricks ### Execute command with certain GHC in PATH
## ghcup run
If you don't want to explicitly switch the active GHC all the time and are using If you don't want to explicitly switch the active GHC all the time and are using
tools that rely on the plain `ghc` binary, GHCup provides an easy way to execute tools that rely on the plain `ghc` binary, GHCup provides an easy way to execute
@@ -494,34 +270,3 @@ ghcup run --ghc 8.10.7 --cabal latest --hls latest --stack latest --install -- c
``` ```
This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version. This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version.
# Troubleshooting
## Script immediately exits on windows
There are two possible reasons:
1. your company blocks the script (some have a whitelist)... ask your administrator
2. your Antivirus or Windows Defender interfere with the installation. Disable them temporarily.
## C compiler cannot create executables
### Darwin
You need to update your XCode command line tools, e.g. [like this](https://stackoverflow.com/questions/34617452/how-to-update-xcode-from-command-line).
## Certificate authority errors (curl)
If your certificates are outdated or improperly configured, curl may be unable
to download ghcup.
There are two known workarounds:
1. Tell curl to ignore certificate errors (dangerous): `curl -k https://raw.githubusercontent.com/haskell/ghcup-hs/master/scripts/bootstrap/bootstrap-haskell | GHCUP_CURL_OPTS="-k" sh`
2. Try to use wget instead: `wget -O /dev/stdout https://raw.githubusercontent.com/haskell/ghcup-hs/master/scripts/bootstrap/bootstrap-haskell | BOOTSTRAP_HASKELL_DOWNLOADER=wget sh`
On windows, you can disable curl like so:
```pwsh
Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;try { Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true,$false,$false,$false,$false,$false,$false,"","","","",$true } catch { Write-Error $_ }
```

View File

@@ -13,11 +13,10 @@ hide:
<h1>GHCup</h1> <h1>GHCup</h1>
</section> </section>
<p class="ghcup-intro">GHCup is the main installer for the general purpose language <a href="https://www.haskell.org">Haskell</a>.</p> <p class="ghcup-intro">GHCup is an installer for the general purpose language <a href="https://www.haskell.org">Haskell</a>.</p>
<div class="text-center main-buttons"> <div class="text-center main-buttons">
<a href="install/" class="btn btn-primary" role="button">Installation</a> <a href="install/" class="btn btn-primary" role="button">Getting Started</a>
<a href="steps/" class="btn btn-primary" role="button">First steps</a>
<a href="guide/" class="btn btn-primary" role="button">User Guide</a> <a href="guide/" class="btn btn-primary" role="button">User Guide</a>
</div> </div>
@@ -35,7 +34,7 @@ hide:
<span> <span>
</span> </span>
<div class="footer"> <div class="footer">
<a href="https://github.com/haskell/ghcup-hs/blob/master/scripts/bootstrap/bootstrap-haskell" target="_blank">What does this do?</a> <b>&nbsp;&middot;&nbsp;</b> <a href="https://www.haskell.org/ghcup/install/#manual-install">I don't like curl | sh</a> <div class="show-all-platforms"><b>&nbsp;&middot;&nbsp;</b> <a class="show-all-platforms-button" href="#">Show all platforms</a></div></p> <a href="https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell" target="_blank">What does this do?</a> <b>&nbsp;&middot;&nbsp;</b> <a href="https://www.haskell.org/ghcup/install/#manual-install">I don't like curl | sh</a> <div class="show-all-platforms"><b>&nbsp;&middot;&nbsp;</b> <a class="show-all-platforms-button" href="#">Show all platforms</a></div></p>
</div> </div>
</div> </div>
@@ -45,19 +44,19 @@ hide:
<div class="command-button"> <div class="command-button">
<pre> <pre>
<span class="ghcup-command" id="ghcup-command-windows">Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072; try { Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true } catch { Write-Error $_ } <span class="ghcup-command" id="ghcup-command-windows">Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true
</span> </span>
</pre> </pre>
<button class="btn" onclick="copyToClipboardWin()" id="ghcup-windows-button"><i class="fa fa-copy"></i></button> <button class="btn" onclick="copyToClipboardWin()" id="ghcup-windows-button"><i class="fa fa-copy"></i></button>
</div> </div>
<div class="footer"> <div class="footer">
<a href="https://github.com/haskell/ghcup-hs/blob/master/scripts/bootstrap/bootstrap-haskell.ps1" target="_blank">What does this do?</a> <b>&nbsp;&middot;&nbsp;</b> <a href="https://www.haskell.org/ghcup/install/#manual-install">I don't like curl | sh</a> <div class="show-all-platforms"><b>&nbsp;&middot;&nbsp;</b> <a class="show-all-platforms-button" href="#">Show all platforms</a></div></p> <a href="https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell.ps1" target="_blank">What does this do?</a> <b>&nbsp;&middot;&nbsp;</b> <a href="https://www.haskell.org/ghcup/install/#manual-install">I don't like curl | sh</a> <div class="show-all-platforms"><b>&nbsp;&middot;&nbsp;</b> <a class="show-all-platforms-button" href="#">Show all platforms</a></div></p>
</div> </div>
</div> </div>
</section> </section>
<p id="help" class="ghcup-help"> <p id="help" class="ghcup-help">
Need help? Check the <a href="guide/#troubleshooting">Troubleshooting section</a> or ask on Need help? Ask on
<span> <span>
<a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup"> <a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup">
<img src="irc.svg" alt="" /> <img src="irc.svg" alt="" />
@@ -77,7 +76,7 @@ hide:
</span> </span>
or or
<span> <span>
<a href="https://github.com/haskell/ghcup-hs/issues"> <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">
report a bug report a bug
<img src="Octicons-bug.svg" alt="" /> <img src="Octicons-bug.svg" alt="" />
</a> </a>

View File

@@ -1,10 +1,10 @@
# Installation # Getting started
GHCup makes it easy to install specific versions of GHC on GNU/Linux, GHCup makes it easy to install specific versions of GHC on GNU/Linux,
macOS (aka Darwin), FreeBSD and Windows and can also bootstrap a fresh [Haskell developer environment](./install/#supported-tools) from scratch. macOS (aka Darwin), FreeBSD and Windows and can also bootstrap a fresh [Haskell developer environment](./install/#supported-tools) from scratch.
It follows the UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be). It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
## How to install ## Installation
The following commands will download the `ghcup` binary into `~/.ghcup/bin` (or `C:\ghcup\bin` on windows) and then The following commands will download the `ghcup` binary into `~/.ghcup/bin` (or `C:\ghcup\bin` on windows) and then
run it to interactively install the [Haskell Toolchain](#supported-tools). These commands should be run as **non-root/non-admin run it to interactively install the [Haskell Toolchain](#supported-tools). These commands should be run as **non-root/non-admin
@@ -19,12 +19,10 @@ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
For Windows, run this in a PowerShell session: For Windows, run this in a PowerShell session:
```psh ```psh
Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072; try { Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true } catch { Write-Error $_ } Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true
``` ```
There's also a [youtube video](https://www.youtube.com/watch?v=bB4fmQiUYPw) explaining installation on windows. If you want to know what these scripts do, check out the [source code at the repository](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/scripts/bootstrap). Advanced users may want to perform a [manual installation](#manual-install) and GPG verify the binaries.
If you want to know what these scripts do, check out the [source code at the repository](https://github.com/haskell/ghcup-hs/tree/master/scripts/bootstrap). Advanced users may want to perform a [manual installation](#manual-install) and GPG verify the binaries.
### Which versions get installed? ### Which versions get installed?
@@ -34,150 +32,105 @@ GHCup has two main channels for every tool: **recommended** and **latest**. By d
Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information. Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information.
## System requirements ## First steps
### Linux Debian 1. To get started with creating a Haskell project, follow the [Getting Started with Haskell and Cabal](https://cabal.readthedocs.io/en/stable/getting-started.html) guide
2. To learn Haskell, try any of those:
The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5` - A beginner friendly [4-lectures course](https://github.com/haskell-beginners-2022/course-plan) with exercises (by [Kowainik](https://kowainik.github.io/))
- An in-depth university [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises (by [Brent Yorgey](https://byorgey.wordpress.com/))
### Linux Ubuntu 3. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
### Linux Fedora
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
### Linux CentOS
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
### Linux Alpine
The following distro packages are required: `binutils-gold curl gcc g++ gmp-dev libc-dev libffi-dev make musl-dev ncurses-dev perl tar xz`
### Linux VoidLinux
The following distro packages are required: `gcc gmp curl coreutils xz ncurses make ncurses-libtinfo-libs perl tar`
### Linux (generic)
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.
### Darwin
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.
On Darwin M1 you might also need a working llvm installed (e.g. via brew) and have the toolchain exposed in PATH.
### FreeBSD
The following distro packages are required: `curl gcc gmp gmake ncurses perl5 libffi libiconv`
### Windows
On Windows, msys2 should already have been set up during the installation, so most users should just proceed. If you are installing manually, make sure to have a working mingw64 toolchain and shell.
## Next steps
1. Follow the [First steps guide](../steps) on how to build a "Hello world" program, use `ghc`, run an interactive REPL and create a Haskell project
2. To understand the difference and overlap of `stack` and `cabal`, read on [here](https://gist.github.com/merijn/8152d561fb8b011f9313c48d876ceb07)
3. To learn Haskell proper check out the links at [How to learn Haskell proper](../steps#how-to-learn-haskell-proper)
4. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
## Uninstallation ## Uninstallation
On linux, just run `ghcup nuke`, then make sure any ghcup added lines in your `~/.bashrc` (or similar) are removed. On linux, just run `ghcup nuke`, then make sure any ghcup added lines in your `~/.bashrc` (or similar) are removed.
On windows, right click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop and select *Run with PowerShell*. On windows, double-click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop.
## Supported tools ## Supported tools
GHCup supports the following tools, which are also known as the **Haskell Toolchain**: GHCup supports the following tools, which are also known as the **Haskell Toolchain**:
<details> <summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary> <details>
<summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary>
<table> <table>
<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead> <thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>9.4.3</td><td><span style="color:blue">latest</span>, base-4.17.0.0</td></tr>
<tr><td>9.4.2</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.1</td><td>base-4.17.0.0</td></tr>
<tr><td>9.2.5</td><td><span style="color:green">recommended</span>, base-4.16.4.0</td></tr>
<tr><td>9.2.4</td><td>base-4.16.3.0</td></tr>
<tr><td>9.2.3</td><td>base-4.16.2.0</td></tr>
<tr><td>9.2.2</td><td>base-4.16.1.0</td></tr>
<tr><td>9.2.1</td><td>base-4.16.0.0</td></tr>
<tr><td>9.0.2</td><td>base-4.15.1.0</td></tr>
<tr><td>9.0.1</td><td>base-4.15.0.0</td></tr>
<tr><td>8.10.7</td><td>base-4.14.3.0</td></tr>
<tr><td>8.10.6</td><td>base-4.14.3.0</td></tr>
<tr><td>8.10.5</td><td>base-4.14.2.0</td></tr>
<tr><td>8.10.4</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.3</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.2</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.1</td><td>base-4.14.0.0</td></tr>
<tr><td>8.8.4</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.3</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.2</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.1</td><td>base-4.13.0.0</td></tr>
<tr><td>8.6.5</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.4</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.3</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.2</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.1</td><td>base-4.12.0.0</td></tr>
<tr><td>8.4.4</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.3</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.2</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.1</td><td>base-4.11.0.0</td></tr>
<tr><td>8.2.2</td><td>base-4.10.1.0</td></tr>
<tr><td>8.0.2</td><td>base-4.9.1.0</td></tr>
<tr><td>7.10.3</td><td>base-4.8.2.0</td></tr> <tr><td>7.10.3</td><td>base-4.8.2.0</td></tr>
<tr><td>8.0.2</td><td>base-4.9.1.0</td></tr>
<tr><td>8.2.2</td><td>base-4.10.1.0</td></tr>
<tr><td>8.4.1</td><td>base-4.11.0.0</td></tr>
<tr><td>8.4.2</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.3</td><td>base-4.11.1.0</td></tr>
<tr><td>8.4.4</td><td>base-4.11.1.0</td></tr>
<tr><td>8.6.1</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.2</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.3</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.4</td><td>base-4.12.0.0</td></tr>
<tr><td>8.6.5</td><td>base-4.12.0.0</td></tr>
<tr><td>8.8.1</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.2</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.3</td><td>base-4.13.0.0</td></tr>
<tr><td>8.8.4</td><td>base-4.13.0.0</td></tr>
<tr><td>8.10.1</td><td>base-4.14.0.0</td></tr>
<tr><td>8.10.2</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.3</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.4</td><td>base-4.14.1.0</td></tr>
<tr><td>8.10.5</td><td>base-4.14.2.0</td></tr>
<tr><td>8.10.6</td><td>base-4.14.3.0</td></tr>
<tr><td>8.10.7</td><td><span style="color:green">recommended</span>, base-4.14.3.0</td></tr>
<tr><td>9.0.1</td><td>base-4.15.0.0</td></tr>
<tr><td>9.0.2</td><td>base-4.15.1.0</td></tr>
<tr><td>9.2.1</td><td>base-4.16.0.0</td></tr>
<tr><td>9.2.2</td><td><span style="color:blue">latest</span>, base-4.16.1.0</td></tr>
</tbody> </tbody>
</table> </table>
</details> </details>
<details> <summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary> <details>
<table> <summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary>
<table>
<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead> <thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>3.8.1.0</td><td><span style="color:blue">latest</span></td></tr>
<tr><td>3.6.2.0</td><td><span style="color:green">recommended</span></td></tr>
<tr><td>3.6.0.0</td><td></td></tr>
<tr><td>3.4.1.0</td><td></td></tr>
<tr><td>3.4.0.0</td><td></td></tr>
<tr><td>3.2.0.0</td><td></td></tr>
<tr><td>3.0.0.0</td><td></td></tr>
<tr><td>2.4.1.0</td><td></td></tr> <tr><td>2.4.1.0</td><td></td></tr>
<tr><td>3.0.0.0</td><td></td></tr>
<tr><td>3.2.0.0</td><td></td></tr>
<tr><td>3.4.0.0</td><td></td></tr>
<tr><td>3.4.1.0</td><td></td></tr>
<tr><td>3.6.0.0</td><td></td></tr>
<tr><td>3.6.2.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody> </tbody>
</table> </table>
</details> </details>
<details> <summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary> <details>
<summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary>
<table> <table>
<thead><tr><th>HLS Version</th><th>Tags</th></tr></thead> <thead><tr><th>HLS Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>1.8.0.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
<tr><td>1.7.0.0</td><td></td></tr>
<tr><td>1.6.1.0</td><td></td></tr>
<tr><td>1.6.0.0</td><td></td></tr>
<tr><td>1.5.1</td><td></td></tr>
<tr><td>1.5.0</td><td></td></tr>
<tr><td>1.4.0</td><td></td></tr>
<tr><td>1.3.0</td><td></td></tr>
<tr><td>1.2.0</td><td></td></tr>
<tr><td>1.1.0</td><td></td></tr> <tr><td>1.1.0</td><td></td></tr>
<tr><td>1.2.0</td><td></td></tr>
<tr><td>1.3.0</td><td></td></tr>
<tr><td>1.4.0</td><td></td></tr>
<tr><td>1.5.0</td><td></td></tr>
<tr><td>1.5.1</td><td></td></tr>
<tr><td>1.6.0.0</td><td></td></tr>
<tr><td>1.6.1.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody> </tbody>
</table> </table>
</details> </details>
<details> <summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary> <details>
<summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary>
<table> <table>
<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead> <thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>2.9.1</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
<tr><td>2.7.5</td><td></td></tr>
<tr><td>2.7.3</td><td></td></tr>
<tr><td>2.7.1</td><td></td></tr>
<tr><td>2.5.1</td><td></td></tr> <tr><td>2.5.1</td><td></td></tr>
<tr><td>2.7.1</td><td></td></tr>
<tr><td>2.7.3</td><td></td></tr>
<tr><td>2.7.5</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
</tbody> </tbody>
</table> </table>
</details> </details>
@@ -234,12 +187,12 @@ HLS bindists are experimental.
Lower availability of bindists. Stack and HLS binaries are experimental. Lower availability of bindists. Stack and HLS binaries are experimental.
## Manual installation ## Manual install
Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/) Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
and place it into your `PATH` anywhere. and place it into your `PATH` anywhere.
If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`. If you want to GPG verify the binaries, import the following key first: `7784930957807690A66EBDBE3786C5262ECB4A3F`.
Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so: Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
@@ -251,20 +204,10 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See [ghcup.vim](https://github.com/hasufell/ghcup.vim). See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## VSCode integration
The developers of the Haskell Language Server offer an [extension](https://github.com/haskell/vscode-haskell) tightly integrated with the [Haskell Language Server](https://github.com/haskell/haskell-language-server). To get started:
1. Install GHCup. During installation, opt in to install the Haskell Language Server (HLS).
2. Install the extension (from VSCode: Ctrl + P and then `ext install haskell.haskell`).
3. Make sure your project uses the GHC version installed from GHCup (otherwise HLS is likely to fail on launch):
- instructions for [stack](https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc)
On Linux, some users have reported an issue when VSCode is not launched from a terminal ("cannot find ghc version"). A solution is to [let HLS know about your GHCup on $PATH](https://github.com/haskell/vscode-haskell#stackcabalghc-can-not-be-found).
## Get help ## Get help
* [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup) * [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)
* [GHCup issue tracker](https://github.com/haskell/ghcup-hs/issues/new) * [GHCup issue tracker](https://gitlab.haskell.org/haskell/ghcup-hs/issues)
* [Matrix](https://app.element.io/#/room/#haskell-tooling:matrix.org) * [Matrix](https://app.element.io/#/room/#haskell-tooling:matrix.org)
* [Discord](https://discord.gg/pKYf3zDQU7) * [Discord](https://discord.gg/pKYf3zDQU7)

File diff suppressed because it is too large Load Diff

Before

Width:  |  Height:  |  Size: 40 KiB

After

Width:  |  Height:  |  Size: 32 KiB

File diff suppressed because it is too large Load Diff

Before

Width:  |  Height:  |  Size: 40 KiB

After

Width:  |  Height:  |  Size: 33 KiB

View File

@@ -1,349 +0,0 @@
# First steps
In this guide we'll take a look at a few core tools that are installed
with the Haskell toolchain, namely, `ghc`, `runghc` and `ghci`.
These tools can be used to compile, interpret or explore Haskell programs.
First, let's start by opening your system's command line interface
and running `ghc --version` to make sure we have successfully
installed a Haskell toolchain:
```
➜ ghc --version
The Glorious Glasgow Haskell Compilation System, version 8.10.7
```
If this fails, consult [the Getting started page](../install) for information on
how to install Haskell on your computer.
This guide is partly based on [Gil Mizrahi's blog](https://gilmi.me/blog/post/2021/08/14/hs-core-tools).
## Compiling programs with ghc
Running `ghc` invokes the Glasgow Haskell Compiler (GHC), and can be used to
compile Haskell modules and programs into native executables and libraries.
Create a new Haskell source file named `hello.hs`,
and write the following code in it:
```hs
main = putStrLn "Hello, Haskell!"
```
Now, we can compile the program by invoking `ghc` with the file name:
```sh
➜ ghc hello.hs
[1 of 1] Compiling Main ( hello.hs, hello.o )
Linking hello ...
```
For more in-depth information about the files `ghc` produces,
follow the [GHC user guide](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/using.html#getting-started-compiling-programs) guide.
Now we run our program:
```sh
➜ ./hello
Hello, Haskell!
```
Alternatively, we can skip the compilation phase by using the command `runghc`:
```sh
➜ runghc hello.hs
Hello, Haskell!
```
`runghc` interprets the source file instead of compiling it and does not
create build artifacts. This makes it very useful when developing programs
and can help accelerate the feedback loop. More information about `runghc`
can be found in the
[GHC user guide](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/runghc.html).
### Turning on warnings
The `-Wall` flag will enable GHC to emit warnings about our code.
```sh
➜ ghc -Wall hello.hs -fforce-recomp
[1 of 1] Compiling Main ( hello.hs, hello.o )
hello.hs:1:1: warning: [-Wmissing-signatures]
Top-level binding with no type signature: main :: IO ()
|
1 | main = putStrLn "Hello, Haskell!"
| ^^^^
Linking hello ...
```
While Haskell can infer
the types of most expressions, it is recommended that top-level definitions
are annotated with their types.
Now our `hello.hs` source file should looks like this:
```hs
main :: IO ()
main = putStrLn "Hello, world!"
```
And now GHC will compile `hello.hs` without warnings.
## An interactive environment
GHC provides an interactive environment in a form of a
Read-Evaluate-Print Loop (REPL) called GHCi.
To enter the environment run the program `ghci`.
```sh
➜ ghci
GHCi, version 9.0.2: https://www.haskell.org/ghc/ :? for help
ghci>
```
It provides an interactive prompt where Haskell expressions can be written and
evaluated.
For example:
```sh
ghci> 1 + 1
2
ghci> putStrLn "Hello, world!"
Hello, world!
```
We can define new names:
```sh
ghci> double x = x + x
ghci> double 2
4
```
We can write multi-line code by surrounding it with `:{` and `:}`:
```hs
ghci> :{
| map f list =
| case list of
| [] -> []
| x : xs -> f x : map f xs
| :}
ghci> map (+1) [1, 2, 3]
[2,3,4]
```
We can import Haskell source files using the `:load` command (`:l` for short):
```sh
ghci> :load hello.hs
[1 of 1] Compiling Main ( hello.hs, interpreted )
Ok, one module loaded.
ghci> main
Hello, Haskell!
```
As well as import library modules:
```sh
ghci> import Data.Bits
ghci> shiftL 32 1
64
ghci> clearBit 33 0
32
```
We can even ask what the type of an expression is using the `:type` command
(`:t` for short):
```sh
λ> :type putStrLn
putStrLn :: String -> IO ()
```
To exit `ghci`, use the `:quit` command (or `:q` for short)
```sh
ghci> :quit
Leaving GHCi.
```
A more thorough introduction to GHCi can be found in the
[GHC user guide](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html).
### Using external packages in ghci
By default, GHCi can only load and use packages that are
[included with the GHC installation](https://downloads.haskell.org/ghc/9.4.2/docs/users_guide/9.4.2-notes.html#included-libraries).
However, users of the [cabal-install](https://www.haskell.org/cabal) and
[stack](http://haskellstack.org) build tools can download and load external packages
very easily using the following commands:
cabal-install:
```sh
cabal repl --build-depends async,say
```
Stack:
```sh
stack exec --package async --package say -- ghci
```
And the modules of the relevant packages will be available for import:
```sh
GHCi, version 9.0.1: https://www.haskell.org/ghc/ :? for help
ghci> import Control.Concurrent.Async
ghci> import Say
ghci> concurrently_ (sayString "Hello") (sayString "World")
Hello
World
```
Stack users can also use this feature with `runghc` and `ghc` by replacing
`ghci` in the command above, and cabal-install users can generate an
environment file that will make `async` and `say` visible for GHC tools
in the current directory using this command:
```sh
cabal install --lib async say --package-env .
```
Many more packages are waiting for you on [Hackage](https://hackage.haskell.org).
## Creating a proper package with modules
The previous methods to compile Haskell code are for quick experiments and small
programs. Usually in Haskell, we create cabal projects, where build tools such as
`cabal-install` or `stack` will install necessary dependencies and compile modules
in correct order. For simplicity's sake, this section will only use `cabal-install`.
To get started, run:
```sh
mkdir haskell-project
cd haskell-project
cabal init --interactive
```
If you let it generate a simple project with sensible defaults, then you should have these files:
* `src/MyLib.hs`: the library module of your project
* `app/Main.hs`: the entry point of your project
* `haskell-project.cabal`: the "cabal" file, describing your project, its dependencies and how it's built
To build the project, run:
```sh
cabal build
```
To run the main executable, run:
```sh
➜ cabal run
Hello, Haskell!
someFunc
```
### Adding dependencies
Now let's add a dependency and adjust our library module. Open `haskell-project.cabal`
and find the library section:
```
library
exposed-modules: MyLib
-- Modules included in this library but not exported.
-- other-modules:
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
build-depends: base ^>=4.14.3.0
hs-source-dirs: src
default-language: Haskell2010
```
The interesting parts here are `exposed-modules` and `build-depends`.
To add a dependency, it should look like this:
```
build-depends: base ^>=4.14.3.0
, directory
```
Now open `src/MyLib.hs` and change it to:
```hs
module MyLib (someFunc) where
import System.Directory
someFunc :: IO ()
someFunc = do
contents <- listDirectory "src"
putStrLn (show contents)
```
### Adding modules
To add a module to your package, adjust `exposed-modules`, like so
```
exposed-modules: MyLib
OtherLib
```
then create `src/OtherLib.hs` with the following contents:
```hs
module OtherLib where
otherFunc :: String -> Int
otherFunc str = length str
```
To use this function interactively, we can run:
```sh
➜ cabal repl
ghci> import OtherLib
ghci> otherFunc "Hello Haskell"
13
```
For further information about how to manage Haskell projects
see the [Cabal user guide](https://cabal.readthedocs.io/en/stable/getting-started.html).
# Where to go from here
<div class="text-center main-buttons">
<a href="https://hackage.haskell.org/" class="btn btn-primary" role="button">Discover Haskell packages</a>
<a href="https://hackage.haskell.org/package/base" class="btn btn-primary" role="button">The standard library</a>
<a href="https://haskell-language-server.readthedocs.io/en/stable/installation.html" class="btn btn-primary" role="button">Editor setup with HLS</a>
<a href="https://play-haskell.tomsmeding.com/play" class="btn btn-primary" role="button">Online playground</a>
</div>
## How to learn Haskell proper
To learn Haskell, try any of those:
- A beginner friendly [4-lectures course](https://github.com/haskell-beginners-2022/course-plan) with exercises (by [Dmitrii Kovanikov](https://kodimensional.dev/))
- An in-depth university [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises (by [Brent Yorgey](https://byorgey.wordpress.com/))
## Projects to contribute to
* [https://github.com/haskell/haskell-language-server](https://github.com/haskell/haskell-language-server)
* [https://github.com/haskell/cabal](https://github.com/haskell/cabal)
* [https://github.com/commercialhaskell/stack](https://github.com/commercialhaskell/stack)
* [https://github.com/haskell/ghcup-hs](https://github.com/haskell/ghcup-hs)
* [https://github.com/jgm/pandoc](https://github.com/jgm/pandoc)
* [https://github.com/simonmichael/hledger](https://github.com/simonmichael/hledger)
* [https://github.com/koalaman/shellcheck](https://github.com/koalaman/shellcheck)

View File

@@ -1,13 +1,13 @@
cabal-version: 3.0 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.18.1 version: 0.1.17.6
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
maintainer: hasufell@posteo.de maintainer: hasufell@posteo.de
author: Julian Ospald author: Julian Ospald
homepage: https://github.com/haskell/ghcup-hs homepage: https://gitlab.haskell.org/haskell/ghcup-hs
bug-reports: https://github.com/haskell/ghcup-hs/issues/ bug-reports: https://gitlab.haskell.org/haskell/ghcup-hs/issues
synopsis: ghc toolchain installer synopsis: ghc toolchain installer
description: description:
A rewrite of the shell script ghcup, for providing A rewrite of the shell script ghcup, for providing
@@ -21,18 +21,13 @@ extra-doc-files:
README.md README.md
extra-source-files: extra-source-files:
cbits/dirutils.c
cbits/dirutils.h
data/build_mk/cross data/build_mk/cross
data/build_mk/default data/build_mk/default
test/golden/unix/GHCupInfo.json test/golden/GHCupInfo.json
test/golden/windows/GHCupInfo.json
test/data/file
test/data/dir/.keep
source-repository head source-repository head
type: git type: git
location: https://github.com/haskell/ghcup-hs.git location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui flag tui
description: description:
@@ -49,40 +44,38 @@ flag internal-downloader
manual: True manual: True
flag no-exe flag no-exe
description: Don't build any executables description: Don't build any executables
default: False
manual: True
flag disable-upgrade
description:
Disable upgrade functionality. This is mainly to support brew packagers.
default: False default: False
manual: True manual: True
library library
exposed-modules: exposed-modules:
GHCup GHCup
GHCup.Cabal
GHCup.Download GHCup.Download
GHCup.Download.Utils GHCup.Download.Utils
GHCup.Errors GHCup.Errors
GHCup.GHC
GHCup.HLS
GHCup.List
GHCup.Platform GHCup.Platform
GHCup.Prelude
GHCup.Prelude.File
GHCup.Prelude.File.Search
GHCup.Prelude.Internal
GHCup.Prelude.Logger
GHCup.Prelude.Logger.Internal
GHCup.Prelude.MegaParsec
GHCup.Prelude.Process
GHCup.Prelude.String.QQ
GHCup.Prelude.Version.QQ
GHCup.Prompts
GHCup.Requirements GHCup.Requirements
GHCup.Stack
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.JSON.Utils GHCup.Types.JSON.Utils
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Utils GHCup.Utils
GHCup.Utils.Dirs GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.File.Common
GHCup.Utils.Logger
GHCup.Utils.MegaParsec
GHCup.Utils.Prelude
GHCup.Utils.String.QQ
GHCup.Utils.Version.QQ
GHCup.Version GHCup.Version
hs-source-dirs: lib hs-source-dirs: lib
@@ -114,8 +107,8 @@ library
, base >=4.12 && <5 , base >=4.12 && <5
, base16-bytestring >=0.1.1.6 && <1.1 , base16-bytestring >=0.1.1.6 && <1.1
, binary ^>=0.8.6.0 , binary ^>=0.8.6.0
, bytestring >=0.10 && <0.12 , bytestring ^>=0.10
, Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 , Cabal ^>=3.6.2.0
, case-insensitive ^>=1.2.1.0 , case-insensitive ^>=1.2.1.0
, casing ^>=0.1.4.1 , casing ^>=0.1.4.1
, containers ^>=0.6 , containers ^>=0.6
@@ -123,7 +116,6 @@ library
, deepseq ^>=1.4.4.0 , deepseq ^>=1.4.4.0
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1 , disk-free-space ^>=0.1.0.1
, exceptions ^>=0.10
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5 , haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1
@@ -141,7 +133,6 @@ library
, safe ^>=0.3.18 , safe ^>=0.3.18
, safe-exceptions ^>=0.1 , safe-exceptions ^>=0.1
, split ^>=0.2.3.4 , split ^>=0.2.3.4
, streamly ^>=0.8.2
, strict-base ^>=0.4 , strict-base ^>=0.4
, template-haskell >=2.7 && <2.18 , template-haskell >=2.7 && <2.18
, temporary ^>=1.3 , temporary ^>=1.3
@@ -167,31 +158,23 @@ library
, terminal-progress-bar >=0.4.1 , terminal-progress-bar >=0.4.1
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
other-modules: other-modules:
GHCup.Prelude.File.Windows GHCup.Utils.File.Windows
GHCup.Prelude.Windows GHCup.Utils.Prelude.Windows
GHCup.Utils.Windows
-- GHCup.OptParse.Run uses this
exposed-modules: GHCup.Prelude.Process.Windows
build-depends: build-depends:
, bzlib , bzlib
, process ^>=1.6.11.0 , process ^>=1.6.11.0
, Win32 >=2.10 , Win32 ^>=2.10
else else
other-modules: other-modules:
GHCup.Prelude.File.Posix GHCup.Utils.File.Posix
GHCup.Prelude.File.Posix.Foreign GHCup.Utils.Posix
GHCup.Prelude.Posix GHCup.Utils.Prelude.Posix
GHCup.Prelude.Process.Posix
exposed-modules:
GHCup.Prelude.File.Posix.Traversals
include-dirs: cbits
includes: dirutils.h
install-includes: dirutils.h
c-sources: cbits/dirutils.c
build-depends: build-depends:
, bz2 >=0.5.0.5 && <1.1 , bz2 >=0.5.0.5 && <1.1
, terminal-size ^>=0.3.2.1 , terminal-size ^>=0.3.2.1
@@ -221,7 +204,6 @@ executable ghcup
GHCup.OptParse.Set GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet GHCup.OptParse.UnSet
GHCup.OptParse.Upgrade
GHCup.OptParse.Whereis GHCup.OptParse.Whereis
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
@@ -245,14 +227,13 @@ executable ghcup
, aeson-pretty ^>=0.8.8 , aeson-pretty ^>=0.8.8
, async ^>=2.2.3 , async ^>=2.2.3
, base >=4.12 && <5 , base >=4.12 && <5
, bytestring >=0.10 && <0.12 , bytestring ^>=0.10
, cabal-plan ^>=0.7.2 , cabal-plan ^>=0.7.2
, containers ^>=0.6 , containers ^>=0.6
, deepseq ^>=1.4 , deepseq ^>=1.4
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghcup , ghcup
, haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.3 , megaparsec >=8.0.0 && <9.3
@@ -296,6 +277,12 @@ executable ghcup
if flag(no-exe) if flag(no-exe)
buildable: False buildable: False
if flag(disable-upgrade)
cpp-options: -DDISABLE_UPGRADE
else
other-modules: GHCup.OptParse.Upgrade
test-suite ghcup-test test-suite ghcup-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Main.hs main-is: Main.hs
@@ -304,8 +291,6 @@ test-suite ghcup-test
other-modules: other-modules:
GHCup.ArbitraryTypes GHCup.ArbitraryTypes
GHCup.Types.JSONSpec GHCup.Types.JSONSpec
GHCup.Utils.FileSpec
GHCup.Prelude.File.Posix.TraversalsSpec
Spec Spec
default-language: Haskell2010 default-language: Haskell2010
@@ -323,23 +308,14 @@ test-suite ghcup-test
build-depends: build-depends:
, base >=4.12 && <5 , base >=4.12 && <5
, bytestring >=0.10 && <0.12 , bytestring ^>=0.10
, containers ^>=0.6 , containers ^>=0.6
, directory ^>=1.3.6.0 , generic-arbitrary >=0.1.0 && <0.3
, filepath ^>=1.4.2.1
, generic-arbitrary >=0.1.0 && <0.2.1 || >=0.2.2 && <0.3
, ghcup , ghcup
, hspec >=2.7.10 && <2.11 , hspec >=2.7.10 && <2.10
, hspec-golden-aeson ^>=0.9 , hspec-golden-aeson ^>=0.9
, QuickCheck ^>=2.14.1 , QuickCheck ^>=2.14.1
, quickcheck-arbitrary-adt ^>=0.3.1.0 , quickcheck-arbitrary-adt ^>=0.3.1.0
, streamly ^>=0.8.2
, text ^>=1.2.4.0 , text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1 , versions >=4.0.1 && <5.1
if os(windows)
cpp-options: -DIS_WINDOWS
else
build-depends:
, unix ^>=2.7

File diff suppressed because it is too large Load Diff

View File

@@ -1,284 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Cabal
Description : GHCup installation functions for Cabal
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Cabal where
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import Codec.Archive ( ArchiveResult )
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Either
import Data.List
import Data.Maybe
import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
-------------------------
--[ Tool installation ]--
-------------------------
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installCabalBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
-- check if we already have a regular cabal already installed
regularCabalInstalled <- lift $ cabalInstalled ver
if
| not forceInstall
, regularCabalInstalled
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Cabal ver
| forceInstall
, regularCabalInstalled
, GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version first!"
liftE $ rmCabalVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- the subdir of the archive where we do the work
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case installDir of
IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall
-- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst ver forceInstall = do
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' (fromInstallDir inst)
let destFileName = cabalFile
<> (case inst of
IsolateDirResolved _ -> ""
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
let destPath = fromInstallDir inst </> destFileName
copyFileE
(path </> cabalFile <> exeExt)
destPath
(not forceInstall)
lift $ chmod_755 destPath
-- | 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 env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Version
-> InstallDir
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installCabalBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver installDir forceInstall
-----------------
--[ Set cabal ]--
-----------------
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasLog env
, MonadFail m
, MonadIO m
, MonadUnliftIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
let cabalbin = binDir </> "cabal" <> exeExt
-- create link
let destL = targetFile
lift $ createLink destL cabalbin
liftIO (isShadowed cabalbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
pure ()
unsetCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetCabal = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
hideError doesNotExistErrorType $ rmLink cabalbin
----------------
--[ Rm cabal ]--
----------------
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
rmCabalVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
cSet <- lift cabalSet
Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)

View File

@@ -34,10 +34,9 @@ import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Prelude import GHCup.Utils.File
import GHCup.Prelude.File import GHCup.Utils.Logger
import GHCup.Prelude.Logger.Internal import GHCup.Utils.Prelude
import GHCup.Prelude.Process
import GHCup.Version import GHCup.Version
import Control.Applicative import Control.Applicative
@@ -70,6 +69,7 @@ import Prelude hiding ( abs
, writeFile , writeFile
) )
import Safe import Safe
import System.Directory
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.FilePath import System.FilePath
@@ -145,7 +145,7 @@ getDownloadsF = do
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do yamlFromCache uri = do
Dirs{..} <- getDirs Dirs{..} <- getDirs
pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
etagsFile :: FilePath -> FilePath etagsFile :: FilePath -> FilePath
@@ -242,7 +242,7 @@ getBase uri = do
Settings { metaCache } <- lift getSettings Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time -- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
| e -> do | e -> do
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -581,7 +581,7 @@ downloadCached dli mfn = do
True -> downloadCached' dli mfn Nothing True -> downloadCached' dli mfn Nothing
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
downloadCached' :: ( MonadReader env m downloadCached' :: ( MonadReader env m
@@ -599,7 +599,7 @@ downloadCached' :: ( MonadReader env m
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let destDir = fromMaybe cacheDir mDestDir
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = destDir </> fn let cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile

View File

@@ -10,7 +10,7 @@ module GHCup.Download.IOStreams where
import GHCup.Download.Utils import GHCup.Download.Utils
import GHCup.Errors import GHCup.Errors
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Prelude import GHCup.Utils.Prelude
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe

View File

@@ -10,7 +10,7 @@ module GHCup.Download.Utils where
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Prelude import GHCup.Utils.Prelude
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad

View File

@@ -27,7 +27,6 @@ import Data.CaseInsensitive ( CI )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Haskus.Utils.Variant import Haskus.Utils.Variant
import System.FilePath
import Text.PrettyPrint hiding ( (<>) ) import Text.PrettyPrint hiding ( (<>) )
import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString import URI.ByteString
@@ -105,15 +104,6 @@ instance Pretty CopyError where
pPrint (CopyError reason) = pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason) text ("Unable to copy a file. Reason was: " ++ reason)
-- | Unable to merge file trees.
data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
deriving Show
instance Pretty MergeFileTreeError where
pPrint (MergeFileTreeError e from to) =
text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
<+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."
-- | Unable to find a tag of a tool. -- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool data TagNotFound = TagNotFound Tag Tool
deriving Show deriving Show
@@ -137,13 +127,10 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
instance Pretty AlreadyInstalled where instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') = pPrint (AlreadyInstalled tool ver') =
(pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;" pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
<+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")
-- | The Directory is supposed to be empty, but wasn't. -- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath} data DirNotEmpty = DirNotEmpty {path :: FilePath}
deriving Show
instance Pretty DirNotEmpty where instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do pPrint (DirNotEmpty path) = do
@@ -158,13 +145,6 @@ instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) = pPrint (NotInstalled tool ver) =
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed." text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
data UninstallFailed = UninstallFailed FilePath [FilePath]
deriving Show
instance Pretty UninstallFailed where
pPrint (UninstallFailed dir files) =
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
-- | An executable was expected to be in PATH, but was not found. -- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show deriving Show
@@ -311,26 +291,6 @@ instance Pretty HadrianNotFound where
pPrint HadrianNotFound = pPrint HadrianNotFound =
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
data ToolShadowed = ToolShadowed
Tool
FilePath -- shadow binary
FilePath -- upgraded binary
Version -- upgraded version
deriving Show
instance Pretty ToolShadowed where
pPrint (ToolShadowed tool sh up _) =
text (prettyShow tool
<> " is shadowed by "
<> sh
<> ".\nThe upgrade will not be in effect, unless you remove "
<> sh
<> "\nor make sure "
<> takeDirectory up
<> " comes before "
<> takeDirectory sh
<> " in PATH."
)
------------------------- -------------------------
--[ High-level errors ]-- --[ High-level errors ]--
@@ -347,17 +307,6 @@ instance Pretty DownloadFailed where
deriving instance Show DownloadFailed deriving instance Show DownloadFailed
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
instance Pretty InstallSetError where
pPrint (InstallSetError reason1 reason2) =
text "Both installation and setting the tool failed. Install error was:"
<+> pPrint reason1
<+> text "\nSet error was:"
<+> pPrint reason2
deriving instance Show InstallSetError
-- | A build failed. -- | A build failed.
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es) data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

File diff suppressed because it is too large Load Diff

View File

@@ -1,723 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.HLS
Description : GHCup installation functions for HLS
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.HLS where
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ
import Codec.Archive ( ArchiveResult )
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.Maybe
import Data.String ( fromString )
import Data.Text ( Text )
import Data.Versions hiding ( patch )
import Distribution.Types.Version hiding ( Version )
import Distribution.Types.PackageId
import Distribution.Types.PackageDescription
import Distribution.Types.GenericPackageDescription
import Distribution.PackageDescription.Parsec
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import URI.ByteString
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import Text.PrettyPrint.HughesPJClass (prettyShow)
data HLSVer = SourceDist Version
| GitDist GitBranch
| HackageDist Version
| RemoteDist URI
--------------------
--[ Installation ]--
--------------------
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
installHLSBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
regularHLSInstalled <- lift $ hlsInstalled ver
if
| not forceInstall
, regularHLSInstalled
, GHCupInternal <- installDir -> do -- regular install
throwE $ AlreadyInstalled HLS ver
| forceInstall
, regularHLSInstalled
, GHCupInternal <- installDir -> do -- regular forced install
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- the subdir of the archive where we do the work
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
legacy <- liftIO $ isLegacyHLSBindist workdir
if
| not forceInstall
, not legacy
, (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)
| otherwise -> pure ()
case installDir of
IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
if legacy
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do
if legacy
then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack
$ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall
liftE $ setHLS ver SetHLS_XYZ Nothing
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
-> IO Bool
isLegacyHLSBindist path = do
not <$> doesFileExist (path </> "GNUmakefile")
-- | Install an unpacked hls distribution.
installHLSUnpacked :: ( MonadMask m
, MonadUnliftIO m
, MonadReader env m
, MonadFail m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadIO m
, MonadResource m
, HasPlatformReq env
)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
installHLSUnpacked path inst ver forceInstall = do
PlatformRequest { .. } <- lift getPlatformReq
lift $ logInfo "Installing HLS"
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
inst
HLS
(mkTVer ver)
(\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall)
forM_ mtime $ setModificationTime t)
-- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy path installDir ver forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' (fromInstallDir installDir)
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> (case installDir of
IsolateDirResolved _ -> ""
_ -> ("~" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
let srcPath = path </> f
let destPath = fromInstallDir installDir </> toF
-- destination could be an existing symlink
-- for new make-based HLSes
liftIO $ rmFileForce destPath
copyFileE
srcPath
destPath
(not forceInstall)
lift $ chmod_755 destPath
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper
<> (case installDir of
IsolateDirResolved _ -> ""
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = fromInstallDir installDir </> toF
liftIO $ rmFileForce destWrapperPath
copyFileE
srcWrapperPath
destWrapperPath
(not forceInstall)
lift $ chmod_755 destWrapperPath
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Version
-> InstallDir
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
installHLSBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver installDir forceInstall
compileHLS :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> HLSVer
-> [Version]
-> Maybe Int
-> Either Bool Version
-> InstallDir
-> Maybe (Either FilePath URI)
-> Maybe URI
-> Bool
-> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to cabal install
-> Excepts '[ NoDownload
, GPGError
, DownloadFailed
, DigestError
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, BuildFailed
, NotInstalled
] m Version
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs
when updateCabal $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do
lift $ logInfo "Updating cabal DB"
lEM $ exec "cabal" ["update"] (Just $ fromGHCupPath tmpDir) Nothing
(workdir, tmpUnpack, tver, git_describe) <- case targetHLS of
-- unpack from version tarball
SourceDist tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver
-- download source tarball
dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
pure (workdir, tmpUnpack, tver, Nothing)
HackageDist tver -> do
lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver
-- download source tarball
tmpUnpack <- lift mkGhcupTmpDir
let hls = "haskell-language-server-" <> T.unpack (prettyVer tver)
reThrowAll @_ @'[ProcessError] DownloadFailed $ do
-- unpack
lEM $ exec "cabal" ["unpack", hls] (Just $ fromGHCupPath tmpUnpack) Nothing
let workdir = appendGHCupPath tmpUnpack hls
pure (workdir, tmpUnpack, tver, Nothing)
RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
-- download source tarball
tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
(cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
[cabalFile] <- liftIO $ findFilesDeep
tmpUnpack
(makeRegexOpts compExtended
execBlank
regex
)
tver <- getCabalVersion (fromGHCupPath tmpUnpack </> cabalFile)
pure (cabalFile, tver)
let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)
pure (workdir, tmpUnpack, tver, Nothing)
-- clone from git
GitDist GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
, "origin"
, fromString rep ]
-- figure out if we can do a shallow clone
remoteBranches <- catchE @ProcessError @'[ProcessError] @'[] (\_ -> pure [])
$ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
let shallow_clone
| gitDescribeRequested = False
| isCommitHash ref = True
| fromString ref `elem` remoteBranches = True
| otherwise = False
lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)
-- fetch
let fetch_args
| shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]
| otherwise = ["fetch", "--tags", "--quiet", "origin" ]
lEM $ git fetch_args
-- checkout
lEM $ git [ "checkout", fromString ref ]
-- gather some info
git_describe <- if shallow_clone
then pure Nothing
else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
"HLS version (from cabal file): " <> prettyVer tver <>
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
pure (tmpUnpack, tmpUnpack, tver, git_describe)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
installVer <- case ov of
Left True -> case git_describe of
-- git describe
Just h -> either (fail . displayException) pure . version $ h
-- git describe, but not building from git, lol
Nothing -> pure tver
-- default: use detected version
Left False -> pure tver
-- overwrite version with users value
Right v -> pure v
liftE $ runBuildAction
tmpUnpack
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
let tmpInstallDir = fromGHCupPath workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
-- apply patches
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
-- set up project files
cp <- case cabalProject of
Just (Left cp)
| isAbsolute cp -> do
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project"
| otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack' <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project"
Nothing
| HackageDist _ <- targetHLS -> do
liftIO $ B.writeFile (fromGHCupPath workdir </> "cabal.project") "packages: ./"
pure "cabal.project"
| RemoteDist _ <- targetHLS -> do
let cabalFile = fromGHCupPath workdir </> "cabal.project"
liftIO $ whenM (not <$> doesFileExist cabalFile) $ B.writeFile cabalFile "packages: ./"
pure "cabal.project"
| otherwise -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do
tmpUnpack' <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' tmpInstallDir
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-install"
, "-w"
, "ghc-" <> T.unpack (prettyVer ghc)
, "--install-method=copy"
] ++
maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
[ "--overwrite-policy=always"
, "--disable-profiling"
, "--disable-tests"
, "--installdir=" <> ghcInstallDir
, "--project-file=" <> cp
] ++ fmap T.unpack cabalArgs ++ [
"exe:haskell-language-server"
, "exe:haskell-language-server-wrapper"]
)
(Just $ fromGHCupPath workdir)
"cabal"
Nothing
pure ghcInstallDir
forM_ artifacts $ \artifact -> do
logDebug $ T.pack (show artifact)
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
case installDir of
IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
GHCupInternal -> do
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True
)
pure installVer
where
gitDescribeRequested = case ov of
Left b -> b
_ -> False
-----------------
--[ Set/Unset ]--
-----------------
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadMask m
, MonadFail m
, MonadUnliftIO m
)
=> Version
-> SetHLS
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m ()
setHLS ver shls mBinDir = do
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
-- symlink destination
binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
-- first delete the old symlinks
when (isNothing mBinDir) $
case shls of
-- not for legacy
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-- legacy and new
SetHLSOnly -> liftE rmPlainHLS
case shls of
-- not for legacy
SetHLS_XYZ -> do
bins <- lift $ hlsInternalServerScripts ver Nothing
forM_ bins $ \f -> do
let fname = takeFileName f
destL <- binarySymLinkDestination binDir f
let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
lift $ createLink destL (binDir </> target)
-- legacy and new
SetHLSOnly -> do
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver Nothing
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do
let destL = f
let target = (<> exeExt) . head . splitOn "~" $ f
lift $ createLink destL (binDir </> target)
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
lift $ createLink destL wrapper
when (isNothing mBinDir) $
lift warnAboutHlsCompatibility
liftIO (isShadowed wrapper) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
unsetHLS :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetHLS = do
Dirs {..} <- getDirs
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'
binDir
(MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)
forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))
hideError doesNotExistErrorType $ rmLink wrapper
---------------
--[ Removal ]--
---------------
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
isHlsSet <- lift hlsSet
liftE $ rmMinorHLSSymlinks ver
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
liftE rmPlainHLS
hlsDir' <- ghcupHLSDir ver
let hlsDir = fromGHCupPath hlsDir'
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir </> dropDrive f))
removeEmptyDirsRecursive hlsDir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
f <- recordedInstallationFile HLS (mkTVer ver)
lift $ recycleFile f
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
Nothing -> do
isDir <- liftIO $ doesDirectoryExist hlsDir
isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink hlsDir
when (isDir && not isSyml) $ do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
recyclePathForcibly hlsDir'
when (Just ver == isHlsSet) $ do
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
Nothing -> pure ()
getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
getCabalVersion fp = do
contents <- liftIO $ B.readFile fp
gpd <- case parseGenericPackageDescriptionMaybe contents of
Nothing -> fail $ "could not parse cabal file: " <> fp
Just r -> pure r
let tver = (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
pure tver

View File

@@ -1,410 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.List
Description : Listing versions and tools
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.List where
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude.Logger
import GHCup.Version
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Either
import Data.List
import Data.Maybe
import Data.Text ( Text )
import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
------------------
--[ List tools ]--
------------------
-- | Filter data type for 'listVersions'.
data ListCriteria = ListInstalled
| ListSet
| ListAvailable
deriving Show
-- | A list result describes a single tool version
-- and various of its properties.
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
, lCross :: Maybe Text -- ^ currently only for GHC
, lTag :: [Tag]
, lInstalled :: Bool
, lSet :: Bool -- ^ currently active version
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
}
deriving (Eq, Ord, Show)
-- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
availableToolVersions av tool = view
(at tool % non Map.empty)
av
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
, HasLog env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
)
=> Maybe Tool
-> Maybe ListCriteria
-> m [ListResult]
listVersions lt' criteria = do
-- some annoying work to avoid too much repeated IO
cSet <- cabalSet
cabals <- getInstalledCabals
hlsSet' <- hlsSet
hlses <- getInstalledHLSs
sSet <- stackSet
stacks <- getInstalledStacks
go lt' cSet cabals hlsSet' hlses sSet stacks
where
go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of
Just t -> do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-- get versions from GHCupDownloads
let avTools = availableToolVersions dls t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
case t of
GHC -> do
slr <- strayGHCs avTools
pure (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools cSet cabals
pure (sort (slr ++ lr))
HLS -> do
slr <- strayHLS avTools hlsSet' hlses
pure (sort (slr ++ lr))
Stack -> do
slr <- strayStacks avTools sSet stacks
pure (sort (slr ++ lr))
GHCup -> do
let cg = maybeToList $ currentGHCup avTools
pure (sort (cg ++ lr))
Nothing -> do
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
strayGHCs :: ( MonadCatch m
, MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
-> m [ListResult]
strayGHCs avTools = do
ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
case Map.lookup _tvVersion avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup _tvVersion avTools)
, lNoBindist = False
, ..
}
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = _tvTarget
, lTag = []
, lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist
, lNoBindist = False
, ..
}
Left e -> do
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
strayCabals :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
strayCabals avTools cSet cabals = do
fmap catMaybes $ forM cabals $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
let lSet = cSet == Just ver
pure $ Just $ ListResult
{ lTool = Cabal
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
strayHLS :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, HasLog env
, MonadIO m)
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
strayHLS avTools hlsSet' hlss = do
fmap catMaybes $ forM hlss $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
let lSet = hlsSet' == Just ver
pure $ Just $ ListResult
{ lTool = HLS
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
strayStacks :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
strayStacks avTools stackSet' stacks = do
fmap catMaybes $ forM stacks $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
let lSet = stackSet' == Just ver
pure $ Just $ ListResult
{ lTool = Stack
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
currentGHCup av =
let currentVer = fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in if | Map.member currentVer av -> Nothing
| otherwise -> Just $ ListResult { lVer = currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing
, lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer
, lSet = True
, lInstalled = True
, lNoBindist = False
, hlsPowered = False
}
-- NOTE: this are not cross ones, because no bindists
toListResult :: ( HasLog env
, MonadReader env m
, HasDirs env
, HasGHCupInfo env
, HasPlatformReq env
, MonadIO m
, MonadCatch m
)
=> Tool
-> Maybe Version
-> [Either FilePath Version]
-> Maybe Version
-> [Either FilePath Version]
-> Maybe Version
-> [Either FilePath Version]
-> (Version, VersionInfo)
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
case t of
GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet
pure ListResult { lVer = v
, lTag = tags
, lCross = Nothing
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v
let lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
Stack -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v
let lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr

View File

@@ -23,11 +23,10 @@ import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.File
import GHCup.Prelude import GHCup.Utils.Logger
import GHCup.Prelude.Logger import GHCup.Utils.Prelude
import GHCup.Prelude.Process import GHCup.Utils.String.QQ
import GHCup.Prelude.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -47,6 +46,7 @@ import Prelude hiding ( abs
, writeFile , writeFile
) )
import System.Info import System.Info
import System.Directory
import System.OsRelease import System.OsRelease
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix

View File

@@ -1,82 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module : GHCup.Prelude
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Prelude
(module GHCup.Prelude,
module GHCup.Prelude.Internal,
#if defined(IS_WINDOWS)
module GHCup.Prelude.Windows
#else
module GHCup.Prelude.Posix
#endif
)
where
import GHCup.Errors
import GHCup.Prelude.Internal
import GHCup.Types.Optics (HasLog)
import GHCup.Prelude.Logger (logWarn)
#if defined(IS_WINDOWS)
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.Posix
#endif
import Control.Monad.IO.Class
import Control.Monad.Reader
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import qualified Data.Text as T
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m env . ( Pretty (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
runBothE' :: forall e m a b .
( Monad m
, Show (V e)
, Pretty (V e)
, PopVariant InstallSetError e
, LiftVariant' e (InstallSetError ': e)
, e :<< (InstallSetError ': e)
)
=> Excepts e m a
-> Excepts e m b
-> Excepts (InstallSetError ': e) m ()
runBothE' a1 a2 = do
r1 <- lift $ runE @e a1
r2 <- lift $ runE @e a2
case (r1, r2) of
(VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)
(VLeft e , _ ) -> throwSomeE e
(_ , VLeft e ) -> throwSomeE e
(VRight _, VRight _) -> pure ()
-- | Throw some exception
throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
{-# INLINABLE throwSomeE #-}
throwSomeE = Excepts . pure . VLeft . liftVariant

View File

@@ -1,426 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Prelude.File (
mergeFileTree,
copyFileE,
findFilesDeep,
getDirectoryContentsRecursive,
getDirectoryContentsRecursiveBFS,
getDirectoryContentsRecursiveDFS,
getDirectoryContentsRecursiveUnsafe,
getDirectoryContentsRecursiveBFSUnsafe,
getDirectoryContentsRecursiveDFSUnsafe,
recordedInstallationFile,
module GHCup.Prelude.File.Search,
chmod_755,
isBrokenSymlink,
copyFile,
deleteFile,
install,
removeEmptyDirectory,
removeDirIfEmptyOrIsSymlink,
removeEmptyDirsRecursive,
rmFileForce,
createDirRecursive',
recyclePathForcibly,
rmDirectory,
recycleFile,
rmFile,
rmDirectoryLink,
moveFilePortable,
moveFile,
rmPathForcibly,
exeExt,
exeExt',
getLinkTarget,
pathIsLink,
rmLink,
createLink
) where
import GHCup.Utils.Dirs
import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
import GHCup.Prelude.Internal
import GHCup.Prelude.File.Search
#if IS_WINDOWS
import GHCup.Prelude.File.Windows
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.File.Posix
import GHCup.Prelude.Posix
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import Text.Regex.Posix
import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Control.Exception.Safe
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Haskus.Utils.Variant.Excepts
import System.FilePath
import Text.PrettyPrint.HughesPJClass (prettyShow)
import qualified Data.Text as T
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import GHC.IO.Exception
import System.IO.Error
-- | Merge one file tree to another given a copy operation.
--
-- Records every successfully installed file into the destination
-- returned by 'recordedInstallationFile'.
--
-- If any copy operation fails, the record file is deleted, as well
-- as the partially installed files.
mergeFileTree :: ( MonadMask m
, S.MonadAsync m
, MonadReader env m
, HasDirs env
, HasLog env
, MonadCatch m
)
=> GHCupPath -- ^ source base directory from which to install findFiles
-> InstallDirResolved -- ^ destination base dir
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree _ (GHCupBinDir fp) _ _ _ =
throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
mergeFileTree sourceBase destBase tool v' copyOp = do
lift $ logInfo $ "Merging file tree from \""
<> T.pack (fromGHCupPath sourceBase)
<> "\" to \""
<> T.pack (fromInstallDir destBase)
<> "\""
recFile <- recordedInstallationFile tool v'
wrapInExcepts $ do
-- These checks are not atomic, but we perform them to have
-- the opportunity to abort before copying has started.
--
-- The actual copying might still fail.
liftIO $ baseCheck (fromGHCupPath sourceBase)
liftIO $ destCheck (fromInstallDir destBase)
-- we only record for non-isolated installs
when (isSafeDir destBase) $ do
whenM (liftIO $ doesFileExist recFile)
$ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
-- we want the cleanup action to leak through in case of exception
onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do
logDebug "Starting merge"
lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
copy f
logDebug $ T.pack "Recording installed file: " <> T.pack f
recordInstalledFile f recFile
pure f
where
wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))
cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do
(force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO
(readFile recFile >>= evaluate)
logDebug "Deleting recorded files due to partial install"
forM_ l $ \f -> do
let dest = fromInstallDir destBase </> dropDrive f
logDebug $ "rm -f " <> T.pack f
hideError NoSuchThing $ rmFile dest
pure ()
logDebug $ "rm -f " <> T.pack recFile
hideError NoSuchThing $ rmFile recFile
logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)
hideError UnsatisfiedConstraints $ hideError NoSuchThing $
removeEmptyDirsRecursive (fromInstallDir destBase)
recordInstalledFile f recFile = when (isSafeDir destBase) $
liftIO $ appendFile recFile (f <> "\n")
copy source = do
let dest = fromInstallDir destBase </> source
src = fromGHCupPath sourceBase </> source
when (isAbsolute source)
$ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
liftIO . createDirectoryIfMissing True . takeDirectory $ dest
copyOp src dest
baseCheck src = do
when (isRelative src)
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
whenM (not <$> doesDirectoryExist src)
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
destCheck dest = do
when (isRelative dest)
$ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
-- depth first
getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
-- breadth first
getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> FilePath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
findFilesDeep path regex =
S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
recordedInstallationFile :: ( MonadReader env m
, HasDirs env
)
=> Tool
-> GHCTargetVersion
-> m FilePath
recordedInstallationFile t v' = do
Dirs {..} <- getDirs
pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
(liftIO $ removeEmptyDirectory filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
if isSym
then rmFileForce fp
else liftIO $ ioError e
removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive = go
where
go fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs go
liftIO $ removeEmptyDirectory fp
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- pathIsSymbolicLink p
case ft of
True -> do
rp <- canonicalizePath p
rft <- doesDirectoryExist rp
case rft of
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
recyclePathForcibly :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadMask m
)
=> GHCupPath
-> m ()
recyclePathForcibly fp
| isWindows = do
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
`catch`
(\e -> if | isDoesNotExistError e -> pure ()
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
| otherwise -> throwIO e)
`finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removePathForcibly fp
rmDirectory :: (MonadIO m, MonadMask m)
=> GHCupPath
-> m ()
rmDirectory fp
| isWindows = recover (liftIO $ removeDirectory fp)
| otherwise = liftIO $ removeDirectory fp
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
recycleFile :: ( MonadIO m
, MonadMask m
, MonadReader env m
, HasDirs env
)
=> FilePath
-> m ()
recycleFile fp
| isWindows = do
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
let dest = fromGHCupPath tmp </> takeFileName fp
liftIO (moveFile fp dest)
`catch`
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
`finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removeFile fp
rmFile :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
rmFile fp
| isWindows = recover (liftIO $ removeFile fp)
| otherwise = liftIO $ removeFile fp
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
=> FilePath
-> m ()
rmDirectoryLink fp
| isWindows = recover (liftIO $ removeDirectoryLink fp)
| otherwise = liftIO $ removeDirectoryLink fp
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> GHCupPath
-> m ()
rmPathForcibly fp
| isWindows = recover (liftIO $ removePathForcibly fp)
| otherwise = liftIO $ removePathForcibly fp
-- | The file extension for executables.
exeExt :: String
exeExt
| isWindows = ".exe"
| otherwise = ""
-- | The file extension for executables.
exeExt' :: ByteString
exeExt'
| isWindows = ".exe"
| otherwise = ""
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
rmLink fp
| isWindows = do
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
| otherwise = hideError doesNotExistErrorType . recycleFile $ fp
-- | Creates a symbolic link on unix and a fake symlink on windows for
-- executables, which:
-- 1. is a shim exe
-- 2. has a corresponding .shim file in the same directory that
-- contains the target
--
-- This overwrites previously existing files.
--
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe
| isWindows = do
dirs <- getDirs
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
logDebug $ "rm -f " <> T.pack exe
rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe False
liftIO $ writeFile shim shimContents
| otherwise = do
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe

View File

@@ -1,324 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CApiFFI #-}
{-|
Module : GHCup.Utils.File.Posix
Description : File and directory handling for unix
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Prelude.File.Posix where
import GHCup.Prelude.File.Posix.Traversals
import Control.Exception.Safe
import Control.Monad.Reader
import Foreign.C.String
import Foreign.C.Error
import Foreign.C.Types
import System.IO ( hClose, hSetBinaryMode )
import System.IO.Error hiding ( catchIOError )
import System.FilePath
import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist )
import System.Posix.Directory
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
import System.Posix.Internals ( withFilePath )
import System.Posix.Files
import System.Posix.Types
import qualified System.Posix.Directory as PD
import qualified System.Posix.Files as PF
import qualified System.Posix.IO as SPI
import qualified System.Posix as Posix
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.FileSystem.Handle
as IFH
import qualified Streamly.Prelude as S
import qualified GHCup.Prelude.File.Posix.Foreign as FD
import qualified Streamly.Internal.Data.Stream.StreamD.Type
as D
import Streamly.Internal.Data.Unfold.Type
import qualified Streamly.Internal.Data.Unfold as U
import Streamly.Internal.Control.Concurrent ( withRunInIO )
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
-- | On unix, we can use symlinks, so we just get the
-- symbolic link target.
--
-- On windows, we have to emulate symlinks via shims,
-- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath
getLinkTarget = getSymbolicLinkTarget
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
pathIsLink = pathIsSymbolicLink
chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
liftIO $ setFileMode fp exe_mode
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e
copyFile :: FilePath -- ^ source file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if file exists
-> IO ()
copyFile from to fail' = do
bracket
(openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
(hClose . snd)
$ \(fromFd, fH) -> do
sourceFileMode <- fileMode <$> getFdStatus fromFd
let dflags = [ FD.oNofollow
, if fail' then FD.oExcl else FD.oTrunc
]
bracket
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
(hClose . snd)
$ \(_, tH) -> do
hSetBinaryMode fH True
hSetBinaryMode tH True
streamlyCopy (fH, tH)
where
openFdHandle fp omode flags fM = do
fd <- openFd' fp omode flags fM
handle' <- SPI.fdToHandle fd
pure (fd, handle')
streamlyCopy (fH, tH) =
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
foreign import capi unsafe "fcntl.h open"
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
open_ :: CString
-> Posix.OpenMode
-> [FD.Flags]
-> Maybe Posix.FileMode
-> IO Posix.Fd
open_ str how optional_flags maybe_mode = do
fd <- c_open str all_flags mode_w
return (Posix.Fd fd)
where
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
(creat, mode_w) = case maybe_mode of
Nothing -> ([],0)
Just x -> ([FD.oCreat], x)
open_mode = case how of
Posix.ReadOnly -> FD.oRdonly
Posix.WriteOnly -> FD.oWronly
Posix.ReadWrite -> FD.oRdwr
-- |Open and optionally create this file. See 'System.Posix.Files'
-- for information on how to use the 'FileMode' type.
--
-- Note that passing @Just x@ as the 4th argument triggers the
-- `oCreat` status flag, which must be set when you pass in `oExcl`
-- to the status flags. Also see the manpage for @open(2)@.
openFd' :: FilePath
-> Posix.OpenMode
-> [FD.Flags] -- ^ status flags of @open(2)@
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
-> IO Posix.Fd
openFd' name how optional_flags maybe_mode =
withFilePath name $ \str ->
throwErrnoPathIfMinus1Retry "openFd" name $
open_ str how optional_flags maybe_mode
-- |Deletes the given file. Raises `eISDIR`
-- if run on a directory. Does not follow symbolic links.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (directory)
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read
--
-- Notes: calls `unlink`
deleteFile :: FilePath -> IO ()
deleteFile = removeLink
-- |Recreate a symlink.
--
-- In `Overwrite` copy mode only files and empty directories are deleted.
--
-- Safety/reliability concerns:
--
-- * `Overwrite` mode is inherently non-atomic
--
-- Throws:
--
-- - `InvalidArgument` if source file is wrong type (not a symlink)
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `SameFile` if source and destination are the same file
-- (`HPathIOException`)
--
--
-- Throws in `Strict` mode only:
--
-- - `AlreadyExists` if destination already exists
--
-- Throws in `Overwrite` mode only:
--
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
--
-- Notes:
--
-- - calls `symlink`
recreateSymlink :: FilePath -- ^ the old symlink file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if destination file exists
-> IO ()
recreateSymlink symsource newsym fail' = do
sympoint <- readSymbolicLink symsource
case fail' of
True -> pure ()
False ->
handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ deleteFile newsym
createSymbolicLink sympoint newsym
-- copys files, recreates symlinks, fails on all other types
install :: FilePath -> FilePath -> Bool -> IO ()
install from to fail' = do
fs <- PF.getSymbolicLinkStatus from
decide fs
where
decide fs | PF.isRegularFile fs = copyFile from to fail'
| PF.isSymbolicLink fs = recreateSymlink from to fail'
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
moveFile :: FilePath -> FilePath -> IO ()
moveFile = rename
moveFilePortable :: FilePath -> FilePath -> IO ()
moveFilePortable from to = do
catchErrno [eXDEV] (moveFile from to) $ do
copyFile from to True
removeFile from
catchErrno :: [Errno] -- ^ errno to catch
-> IO a -- ^ action to try, which can raise an IOException
-> IO a -- ^ action to carry out in case of an IOException and
-- if errno matches
-> IO a
catchErrno en a1 a2 =
catchIOError a1 $ \e -> do
errno <- getErrno
if errno `elem` en
then a2
else ioError e
removeEmptyDirectory :: FilePath -> IO ()
removeEmptyDirectory = PD.removeDirectory
-- | Create an 'Unfold' of directory contents.
unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
where
{-# INLINE [0] step #-}
step dirstream = do
(typ, e) <- liftIO $ readDirEnt dirstream
return $ if
| null e -> D.Stop
| "." == e -> D.Skip dirstream
| ".." == e -> D.Skip dirstream
| otherwise -> D.Yield (typ, e) dirstream
getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
=> FilePath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
where
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
if | t == FD.dtDir -> go (cd </> f)
| otherwise -> pure (cd </> f)
getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath
getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))
where
{-# INLINE [0] step #-}
step (_, Nothing, []) = return D.Stop
step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
(dt, f) <- liftIO $ readDirEnt dirstream
if | FD.dtUnknown == dt -> do
runIOFinalizer finalizer
return $ D.Skip (topdir, Nothing, dirs)
| f == "." || f == ".."
-> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs)
| FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)
| otherwise -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)
step (topdir, Nothing, dir:dirs) = do
(s, f) <- acquire (topdir </> dir)
return $ D.Skip (topdir, Just (dir, s, f), dirs)
acquire dir =
withRunInIO $ \run -> mask_ $ run $ do
dirstream <- liftIO $ openDirStream dir
ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
return (dirstream, ref)
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
=> FilePath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold

View File

@@ -1,58 +0,0 @@
{-# LANGUAGE PatternSynonyms #-}
module GHCup.Prelude.File.Posix.Foreign where
import Data.Bits
import Data.List (foldl')
import Foreign.C.Types
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
newtype DirType = DirType Int deriving (Eq, Show)
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
unFlags :: Flags -> Int
unFlags (Flags i) = i
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
-- |Returns @True@ if posix-paths was compiled with support for the provided
-- flag. (As of this writing, the only flag for which this check may be
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
isSupported :: Flags -> Bool
isSupported (Flags _) = True
isSupported _ = False
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
-- throw an exception.)
oCloexec :: Flags
#ifdef O_CLOEXEC
oCloexec = Flags #{const O_CLOEXEC}
#else
{-# WARNING oCloexec
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
oCloexec = UnsupportedFlag "O_CLOEXEC"
#endif
-- If these enum declarations occur earlier in the file, haddock
-- gets royally confused about the above doc comments.
-- Probably http://trac.haskell.org/haddock/ticket/138
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
pathMax :: Int
pathMax = #{const PATH_MAX}
unionFlags :: [Flags] -> CInt
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0

View File

@@ -1,92 +0,0 @@
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module GHCup.Prelude.File.Posix.Traversals (
-- lower-level stuff
readDirEnt
, unpackDirStream
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import GHCup.Prelude.File.Posix.Foreign
import Unsafe.Coerce (unsafeCoerce)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import System.Posix
import Foreign (alloca)
import System.Posix.Internals (peekFilePath)
----------------------------------------------------------
-- dodgy stuff
data {-# CTYPE "DIR" #-} CDir
data {-# CTYPE "struct dirent" #-} CDirent
-- Posix doesn't export DirStream, so to re-use that type we need to use
-- unsafeCoerce. It's just a newtype, so this is a legitimate usage.
-- ugly trick.
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream = unsafeCoerce
-- the __hscore_* functions are defined in the unix package. We can import them and let
-- the linker figure it out.
foreign import ccall unsafe "__hscore_readdir"
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
foreign import ccall unsafe "__hscore_free_dirent"
c_freeDirEnt :: Ptr CDirent -> IO ()
foreign import ccall unsafe "__hscore_d_name"
c_name :: Ptr CDirent -> IO CString
foreign import capi unsafe "dirutils.h __posixdir_d_type"
c_type :: Ptr CDirent -> IO DirType
----------------------------------------------------------
-- less dodgy but still lower-level
readDirEnt :: DirStream -> IO (DirType, FilePath)
readDirEnt (unpackDirStream -> dirp) =
alloca $ \ptr_dEnt -> loop ptr_dEnt
where
loop ptr_dEnt = do
resetErrno
r <- c_readdir dirp ptr_dEnt
if r == 0
then do
dEnt <- peek ptr_dEnt
if dEnt == nullPtr
then return (dtUnknown, mempty)
else do
dName <- c_name dEnt >>= peekFilePath
dType <- c_type dEnt
c_freeDirEnt dEnt
return (dType, dName)
else do
errno <- getErrno
if errno == eINTR
then loop ptr_dEnt
else do
let (Errno eo) = errno
if eo == 0
then return (dtUnknown, mempty)
else throwErrno "readDirEnt"

View File

@@ -1,311 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-|
Module : GHCup.Utils.File.Windows
Description : File and directory handling for windows
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : Windows
-}
module GHCup.Prelude.File.Windows where
import GHCup.Utils.Dirs
import GHCup.Prelude.Internal
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.List
import qualified GHC.Unicode as U
import System.FilePath
import qualified System.IO.Error as IOE
import qualified System.Win32.Info as WS
import qualified System.Win32.File as WS
import qualified Streamly.Internal.Data.Stream.StreamD.Type
as D
import Streamly.Internal.Data.Unfold.Type hiding ( concatMap )
import Data.Bits ((.&.))
import qualified Streamly.Prelude as S
import qualified Streamly.Internal.Data.Unfold as U
import Streamly.Internal.Control.Concurrent ( withRunInIO )
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
-- | On unix, we can use symlinks, so we just get the
-- symbolic link target.
--
-- On windows, we have to emulate symlinks via shims,
-- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath
getLinkTarget fp = do
content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp =
let perm = setOwnerWritable True emptyPermissions
in liftIO $ setPermissions fp perm
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
b <- pathIsLink fp
if b
then do
tfp <- getLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp)
else pure False
copyFile :: FilePath -- ^ source file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if file exists
-> IO ()
copyFile = WS.copyFile
deleteFile :: FilePath -> IO ()
deleteFile = WS.deleteFile
install :: FilePath -> FilePath -> Bool -> IO ()
install = copyFile
moveFile :: FilePath -> FilePath -> IO ()
moveFile from to = WS.moveFileEx from (Just to) 0
moveFilePortable :: FilePath -> FilePath -> IO ()
moveFilePortable = WS.moveFile
removeEmptyDirectory :: FilePath -> IO ()
removeEmptyDirectory = WS.removeDirectory
unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath)
unfoldDirContents = U.bracket alloc dealloc (Unfold step return)
where
{-# INLINE [0] step #-}
step (_, False, _, _) = return D.Stop
step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do
f <- liftIO $ WS.getFindDataFileName fd
more <- liftIO $ WS.findNextFile h fd
-- can't get file attribute from FindData yet (needs Win32 PR)
fattr <- liftIO $ WS.getFileAttributes (topdir </> f)
if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd)
| otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd)
alloc topdir = do
query <- liftIO $ furnishPath (topdir </> "*")
(h, fd) <- liftIO $ WS.findFirstFile query
pure (topdir, True, h, fd)
dealloc (_, _, fd, _) = liftIO $ WS.findClose fd
getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t)
=> FilePath
-> t m FilePath
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
where
isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
if | isDir t -> go (cd </> f)
| otherwise -> pure (cd </> f)
getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath
getDirectoryContentsRecursiveUnfold = Unfold step init'
where
{-# INLINE [0] step #-}
step (_, Nothing, []) = return D.Stop
step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do
f <- liftIO $ WS.getFindDataFileName findData
more <- liftIO $ WS.findNextFile h findData
when (not more) $ runIOFinalizer ref
let nextState = if more then state else Nothing
-- can't get file attribute from FindData yet (needs Win32 PR)
fattr <- liftIO $ WS.getFileAttributes (topdir </> cdir </> f)
if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs)
| isDir fattr -> return $ D.Skip (topdir, nextState, (cdir </> f):dirs)
| otherwise -> return $ D.Yield (cdir </> f) (topdir, nextState, dirs)
step (topdir, Nothing, dir:dirs) = do
(h, findData, ref) <- acquire (topdir </> dir)
return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs)
init' topdir = do
(h, findData, ref) <- acquire topdir
return (topdir, Just ("", (h, findData, ref)), [])
isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
acquire dir = do
query <- liftIO $ furnishPath (dir </> "*")
withRunInIO $ \run -> mask_ $ run $ do
(h, findData) <- liftIO $ WS.findFirstFile query
ref <- newIOFinalizer (liftIO $ WS.findClose h)
return (h, findData, ref)
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
=> FilePath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
--------------------------------------
--[ Inlined from directory package ]--
--------------------------------------
furnishPath :: FilePath -> IO FilePath
furnishPath path =
(toExtendedLengthPath <$> rawPrependCurrentDirectory path)
`IOE.catchIOError` \ _ ->
pure path
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath path
| isRelative path = simplifiedPath
| otherwise =
case simplifiedPath of
'\\' : '?' : '?' : '\\' : _ -> simplifiedPath
'\\' : '\\' : '?' : '\\' : _ -> simplifiedPath
'\\' : '\\' : '.' : '\\' : _ -> simplifiedPath
'\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
_ -> "\\\\?\\" <> simplifiedPath
where simplifiedPath = simplify path
simplify :: FilePath -> FilePath
simplify = simplifyWindows
simplifyWindows :: FilePath -> FilePath
simplifyWindows "" = ""
simplifyWindows path =
case drive' of
"\\\\?\\" -> drive' <> subpath
_ -> simplifiedPath
where
simplifiedPath = joinDrive drive' subpath'
(drive, subpath) = splitDrive path
drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
subpath' = appendSep . avoidEmpty . prependSep . joinPath .
stripPardirs . expandDots . skipSeps .
splitDirectories $ subpath
upperDrive d = case d of
c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s
_ -> d
skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
| otherwise = id
prependSep | subpathIsAbsolute = (pathSeparator :)
| otherwise = id
avoidEmpty | not pathIsAbsolute
&& (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
= emptyToCurDir
| otherwise = id
appendSep p | hasTrailingPathSep
&& not (pathIsAbsolute && null p)
= addTrailingPathSeparator p
| otherwise = p
pathIsAbsolute = not (isRelative path)
subpathIsAbsolute = any isPathSeparator (take 1 subpath)
hasTrailingPathSep = hasTrailingPathSeparator subpath
emptyToCurDir :: FilePath -> FilePath
emptyToCurDir "" = "."
emptyToCurDir path = path
normaliseTrailingSep :: FilePath -> FilePath
normaliseTrailingSep path = do
let path' = reverse path
let (sep, path'') = span isPathSeparator path'
let addSep = if null sep then id else (pathSeparator :)
reverse (addSep path'')
normalisePathSeps :: FilePath -> FilePath
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
expandDots :: [FilePath] -> [FilePath]
expandDots = reverse . go []
where
go ys' xs' =
case xs' of
[] -> ys'
x : xs ->
case x of
"." -> go ys' xs
".." ->
case ys' of
[] -> go (x : ys') xs
".." : _ -> go (x : ys') xs
_ : ys -> go ys xs
_ -> go (x : ys') xs
rawPrependCurrentDirectory :: FilePath -> IO FilePath
rawPrependCurrentDirectory path
| isRelative path =
((`ioeAddLocation` "prependCurrentDirectory") .
(`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do
getFullPathName path
| otherwise = pure path
ioeAddLocation :: IOError -> String -> IOError
ioeAddLocation e loc = do
IOE.ioeSetLocation e newLoc
where
newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
oldLoc = IOE.ioeGetLocation e
getFullPathName :: FilePath -> IO FilePath
getFullPathName path =
fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)
fromExtendedLengthPath :: FilePath -> FilePath
fromExtendedLengthPath ePath =
case ePath of
'\\' : '\\' : '?' : '\\' : path ->
case path of
'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath
drive : ':' : subpath
-- if the path is not "regular", then the prefix is necessary
-- to ensure the path is interpreted literally
| U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path
_ -> ePath
_ -> ePath
where
isPathRegular path =
not ('/' `elem` path ||
"." `elem` splitDirectories path ||
".." `elem` splitDirectories path)

View File

@@ -1,61 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Utils.Logger
Description : logger definition
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Here we define our main logger.
-}
module GHCup.Prelude.Logger
( module GHCup.Prelude.Logger
, module GHCup.Prelude.Logger.Internal
)
where
import GHCup.Prelude.Logger.Internal
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Dirs (fromGHCupPath)
import GHCup.Prelude.Internal
import GHCup.Prelude.File.Search (findFiles)
import GHCup.Prelude.File (recycleFile)
import GHCup.Prelude.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Prelude hiding ( appendFile )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import qualified Data.ByteString as B
initGHCupFileLogging :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadMask m
) => m FilePath
initGHCupFileLogging = do
Dirs { logsDir } <- getDirs
let logfile = fromGHCupPath logsDir </> "ghcup.log"
logFiles <- liftIO $ findFiles
(fromGHCupPath logsDir)
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
liftIO $ writeFile logfile ""
pure logfile

View File

@@ -1,25 +0,0 @@
{-# LANGUAGE CPP #-}
{-|
Module : GHCup.Utils.Process
Description : Process handling
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Prelude.Process (
executeOut,
execLogged,
exec,
toProcessError,
) where
#if IS_WINDOWS
import GHCup.Prelude.Process.Windows
#else
import GHCup.Prelude.Process.Posix
#endif

View File

@@ -1,28 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module GHCup.Prompts
( PromptQuestion,
PromptResponse (..),
getUserPromptResponse,
)
where
import Control.Monad.Reader
import qualified Data.Text.IO as TIO
import GHCup.Prelude.Logger
import GHCup.Types.Optics
import GHCup.Types (PromptQuestion, PromptResponse(..))
getUserPromptResponse :: ( HasLog env
, MonadReader env m
, MonadIO m)
=> PromptQuestion
-> m PromptResponse
getUserPromptResponse prompt = do
logInfo prompt
resp <- liftIO TIO.getLine
if resp `elem` ["YES", "yes", "y", "Y"]
then pure PromptYes
else pure PromptNo

View File

@@ -1,283 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Stack
Description : GHCup installation functions for Stack
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Stack where
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import Codec.Archive ( ArchiveResult )
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Either
import Data.List
import Data.Maybe
import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
--------------------
--[ Installation ]--
--------------------
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
-- creates a default @stack -> stack-x.y.z.q@ symlink for
-- the latest installed version.
installStackBin :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Version
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installStackBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver installDir forceInstall
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installStackBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
regularStackInstalled <- lift $ stackInstalled ver
if
| not forceInstall
, regularStackInstalled
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Stack ver
| forceInstall
, regularStackInstalled
, GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version of Stack first!"
liftE $ rmStackVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case installDir of
IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> InstallDirResolved
-> Version
-> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path installDir ver forceInstall = do
lift $ logInfo "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' (fromInstallDir installDir)
let destFileName = stackFile
<> (case installDir of
IsolateDirResolved _ -> ""
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
destPath = fromInstallDir installDir </> destFileName
copyFileE
(fromGHCupPath path </> stackFile <> exeExt)
destPath
(not forceInstall)
lift $ chmod_755 destPath
-----------------
--[ Set stack ]--
-----------------
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
setStack ver = do
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
let stackbin = binDir </> "stack" <> exeExt
lift $ createLink targetFile stackbin
liftIO (isShadowed stackbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
pure ()
unsetStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetStack = do
Dirs {..} <- getDirs
let stackbin = binDir </> "stack" <> exeExt
hideError doesNotExistErrorType $ rmLink stackbin
----------------
--[ Rm stack ]--
----------------
-- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version).
rmStackVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmStackVer ver = do
whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
sSet <- lift stackSet
Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)

View File

@@ -26,8 +26,6 @@ module GHCup.Types
) )
where where
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
import Control.DeepSeq ( NFData, rnf ) import Control.DeepSeq ( NFData, rnf )
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
@@ -309,12 +307,11 @@ data UserSettings = UserSettings
, uUrlSource :: Maybe URLSource , uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool , uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting , uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
@@ -329,17 +326,16 @@ fromSettings Settings{..} Nothing =
, uKeyBindings = Nothing , uKeyBindings = Nothing
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
} }
fromSettings Settings{..} (Just KeyBindings{..}) = fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings let ukb = UserKeyBindings
{ kUp = Just bUp { kUp = Just bUp
, kDown = Just bDown , kDown = Just bDown
, kQuit = Just bQuit , kQuit = Just bQuit
, kInstall = Just bInstall , kInstall = Just bInstall
, kUninstall = Just bUninstall , kUninstall = Just bUninstall
, kSet = Just bSet , kSet = Just bSet
, kChangelog = Just bChangelog , kChangelog = Just bChangelog
, kShowAll = Just bShowAllVersions , kShowAll = Just bShowAllVersions
, kShowAllTools = Just bShowAllTools , kShowAllTools = Just bShowAllTools
} }
@@ -354,7 +350,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uKeyBindings = Just ukb , uKeyBindings = Just ukb
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
} }
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
@@ -410,9 +405,6 @@ data AppState = AppState
instance NFData AppState instance NFData AppState
fromAppState :: AppState -> LeanAppState
fromAppState AppState {..} = LeanAppState {..}
data LeanAppState = LeanAppState data LeanAppState = LeanAppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs
@@ -424,17 +416,16 @@ instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, metaCache :: Integer , metaCache :: Integer
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
, urlSource :: URLSource , urlSource :: URLSource
, noNetwork :: Bool , noNetwork :: Bool
, gpgSetting :: GPGSetting , gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig , noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@@ -442,19 +433,17 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False Nothing defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False
instance NFData Settings instance NFData Settings
data Dirs = Dirs data Dirs = Dirs
{ baseDir :: GHCupPath { baseDir :: FilePath
, binDir :: FilePath , binDir :: FilePath
, cacheDir :: GHCupPath , cacheDir :: FilePath
, logsDir :: GHCupPath , logsDir :: FilePath
, confDir :: GHCupPath , confDir :: FilePath
, dbDir :: GHCupPath , recycleDir :: FilePath -- mainly used on windows
, recycleDir :: GHCupPath -- mainly used on windows
, tmpDir :: GHCupPath
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@@ -639,29 +628,3 @@ data CapturedProcess = CapturedProcess
deriving (Eq, Show) deriving (Eq, Show)
makeLenses ''CapturedProcess makeLenses ''CapturedProcess
data InstallDir = IsolateDir FilePath
| GHCupInternal
deriving (Eq, Show)
data InstallDirResolved = IsolateDirResolved FilePath
| GHCupDir GHCupPath
| GHCupBinDir FilePath
deriving (Eq, Show)
fromInstallDir :: InstallDirResolved -> FilePath
fromInstallDir (IsolateDirResolved fp) = fp
fromInstallDir (GHCupDir fp) = fromGHCupPath fp
fromInstallDir (GHCupBinDir fp) = fp
isSafeDir :: InstallDirResolved -> Bool
isSafeDir (IsolateDirResolved _) = False
isSafeDir (GHCupDir _) = True
isSafeDir (GHCupBinDir _) = False
type PromptQuestion = Text
data PromptResponse = PromptYes | PromptNo
deriving (Show, Eq)

View File

@@ -23,7 +23,7 @@ module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON.Utils import GHCup.Types.JSON.Utils
import GHCup.Prelude.MegaParsec import GHCup.Utils.MegaParsec
import Control.Applicative ( (<|>) ) import Control.Applicative ( (<|>) )
import Data.Aeson hiding (Key) import Data.Aeson hiding (Key)
@@ -56,7 +56,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Global
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "r-") . T.pack . kebab . tail $ str' } ''PlatformRequest
instance ToJSON Tag where instance ToJSON Tag where
toJSON Latest = String "Latest" toJSON Latest = String "Latest"
@@ -80,6 +79,37 @@ instance FromJSON Tag where
instance ToJSON URI where instance ToJSON URI where
toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
instance FromJSON URLSource where
parseJSON v =
parseGHCupURL v
<|> parseOwnSourceLegacy v
<|> parseOwnSourceNew1 v
<|> parseOwnSourceNew2 v
<|> parseOwnSpec v
<|> legacyParseAddSource v
<|> newParseAddSource v
where
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
r :: URI <- o .: "OwnSource"
pure (OwnSource [Right r])
parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
r :: [URI] <- o .: "OwnSource"
pure (OwnSource (fmap Right r))
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
pure (OwnSource r)
parseOwnSpec = withObject "URLSource" $ \o -> do
r :: GHCupInfo <- o .: "OwnSpec"
pure (OwnSpec r)
parseGHCupURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "GHCupURL"
pure GHCupURL
legacyParseAddSource = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo URI <- o .: "AddSource"
pure (AddSource [r])
newParseAddSource = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "AddSource"
pure (AddSource r)
instance FromJSON URI where instance FromJSON URI where
parseJSON = withText "URL" $ \t -> parseJSON = withText "URL" $ \t ->
@@ -319,40 +349,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
instance FromJSON URLSource where
parseJSON v =
parseGHCupURL v
<|> parseOwnSourceLegacy v
<|> parseOwnSourceNew1 v
<|> parseOwnSourceNew2 v
<|> parseOwnSpec v
<|> legacyParseAddSource v
<|> newParseAddSource v
where
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
r :: URI <- o .: "OwnSource"
pure (OwnSource [Right r])
parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
r :: [URI] <- o .: "OwnSource"
pure (OwnSource (fmap Right r))
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
pure (OwnSource r)
parseOwnSpec = withObject "URLSource" $ \o -> do
r :: GHCupInfo <- o .: "OwnSpec"
pure (OwnSpec r)
parseGHCupURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "GHCupURL"
pure GHCupURL
legacyParseAddSource = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo URI <- o .: "AddSource"
pure (AddSource [r])
newParseAddSource = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "AddSource"
pure (AddSource r)
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key

View File

@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@@ -23,18 +22,18 @@ module GHCup.Utils
( module GHCup.Utils.Dirs ( module GHCup.Utils.Dirs
, module GHCup.Utils , module GHCup.Utils
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
, module GHCup.Prelude.Windows , module GHCup.Utils.Windows
#else #else
, module GHCup.Prelude.Posix , module GHCup.Utils.Posix
#endif #endif
) )
where where
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
import GHCup.Prelude.Windows import GHCup.Utils.Windows
#else #else
import GHCup.Prelude.Posix import GHCup.Utils.Posix
#endif #endif
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
@@ -42,13 +41,11 @@ import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Version import GHCup.Utils.File
import GHCup.Prelude import GHCup.Utils.Logger
import GHCup.Prelude.File import GHCup.Utils.MegaParsec
import GHCup.Prelude.Logger.Internal import GHCup.Utils.Prelude
import GHCup.Prelude.MegaParsec import GHCup.Utils.String.QQ
import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ
import Codec.Archive hiding ( Directory ) import Codec.Archive hiding ( Directory )
import Control.Applicative import Control.Applicative
@@ -61,7 +58,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit )
import Data.Bifunctor ( first ) import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
@@ -75,10 +71,10 @@ import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
import Safe import Safe
import System.Directory hiding ( findFiles )
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
import Text.Regex.Posix import Text.Regex.Posix
import Text.PrettyPrint.HughesPJClass (prettyShow)
import URI.ByteString import URI.ByteString
import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.BZip as BZip
@@ -90,9 +86,6 @@ import qualified Data.Text as T
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
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)
-- $setup -- $setup
@@ -103,14 +96,14 @@ import GHC.IO (evaluate)
-- >>> import System.Directory -- >>> import System.Directory
-- >>> import URI.ByteString -- >>> import URI.ByteString
-- >>> import qualified Data.Text as T -- >>> import qualified Data.Text as T
-- >>> import GHCup.Prelude -- >>> import GHCup.Utils.Prelude
-- >>> import GHCup.Download -- >>> import GHCup.Download
-- >>> import GHCup.Version -- >>> import GHCup.Version
-- >>> import GHCup.Errors -- >>> import GHCup.Errors
-- >>> import GHCup.Types -- >>> import GHCup.Types
-- >>> import GHCup.Types.Optics -- >>> import GHCup.Types.Optics
-- >>> import Optics -- >>> import Optics
-- >>> import GHCup.Prelude.Version.QQ -- >>> import GHCup.Utils.Version.QQ
-- >>> import qualified Data.Text.Encoding as E -- >>> import qualified Data.Text.Encoding as E
-- >>> import Control.Monad.Reader -- >>> import Control.Monad.Reader
-- >>> import Haskus.Utils.Variant.Excepts -- >>> import Haskus.Utils.Variant.Excepts
@@ -284,14 +277,14 @@ rmPlainHLS = do
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
@@ -324,17 +317,17 @@ ghcSet mtarget = do
MP.setInput rest MP.setInput rest
pure x pure x
) )
<* MP.some pathSep <* pathSep
<* MP.takeRest <* MP.takeRest
<* MP.eof <* MP.eof
ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir) fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r Right r -> pure $ Right r
Left _ -> pure $ Left f Left _ -> pure $ Left f
@@ -405,10 +398,10 @@ cabalSet = do
cabalParse = MP.chunk "cabal-" *> version' cabalParse = MP.chunk "cabal-" *> version'
-- parses any path component ending with path separator, -- parses any path component ending with path separator,
-- e.g. "foo/" -- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator, -- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator, -- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -437,7 +430,7 @@ getInstalledHLSs = do
Nothing -> pure $ Left f Nothing -> pure $ Left f
hlsdir <- ghcupHLSBaseDir hlsdir <- ghcupHLSBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir) fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
new <- forM fs $ \f -> case parseGHCupHLSDir f of new <- forM fs $ \f -> case parseGHCupHLSDir f of
Right r -> pure $ Right r Right r -> pure $ Right r
Left _ -> pure $ Left f Left _ -> pure $ Left f
@@ -499,10 +492,10 @@ stackSet = do
cabalParse = MP.chunk "stack-" *> version' cabalParse = MP.chunk "stack-" *> version'
-- parses any path component ending with path separator, -- parses any path component ending with path separator,
-- e.g. "foo/" -- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator, -- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator, -- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -522,7 +515,7 @@ hlsInstalled ver = do
isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
isLegacyHLS ver = do isLegacyHLS ver = do
bdir <- ghcupHLSDir ver bdir <- ghcupHLSDir ver
not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir) not <$> liftIO (doesDirectoryExist bdir)
-- Return the currently set hls version, if any. -- Return the currently set hls version, if any.
@@ -550,10 +543,10 @@ hlsSet = do
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
-- parses any path component ending with path separator, -- parses any path component ending with path separator,
-- e.g. "foo/" -- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator, -- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator, -- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -623,7 +616,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr
-> m [FilePath] -> m [FilePath]
hlsInternalServerScripts ver mghcVer = do hlsInternalServerScripts ver mghcVer = do
dir <- ghcupHLSDir ver dir <- ghcupHLSDir ver
let bdir = fromGHCupPath dir </> "bin" let bdir = dir </> "bin"
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
<$> liftIO (listDirectory bdir) <$> liftIO (listDirectory bdir)
@@ -634,7 +627,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh
-> Maybe Version -- ^ optional GHC version -> Maybe Version -- ^ optional GHC version
-> m [FilePath] -> m [FilePath]
hlsInternalServerBinaries ver mghcVer = do hlsInternalServerBinaries ver mghcVer = do
dir <- fromGHCupPath <$> ghcupHLSDir ver dir <- ghcupHLSDir ver
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"] (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
@@ -648,7 +641,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow
-> Version -- ^ GHC version -> Version -- ^ GHC version
-> m [FilePath] -> m [FilePath]
hlsInternalServerLibs ver ghcVer = do hlsInternalServerLibs ver ghcVer = do
dir <- fromGHCupPath <$> ghcupHLSDir ver dir <- ghcupHLSDir ver
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))] (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
fmap (bdir </>) <$> liftIO (listDirectory bdir) fmap (bdir </>) <$> liftIO (listDirectory bdir)
@@ -852,21 +845,21 @@ getArchiveFiles av = do
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> GHCupPath -- ^ unpacked tar dir => FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend -> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m GHCupPath -> Excepts '[TarDirDoesNotExist] m FilePath
intoSubdir bdir tardir = case tardir of intoSubdir bdir tardir = case tardir of
RealDir pr -> do RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir) (throwE $ TarDirDoesNotExist tardir)
pure (bdir `appendGHCupPath` pr) pure (bdir </> pr)
RegexDir r -> do RegexDir r -> do
let rs = split (`elem` pathSeparators) r let rs = split (`elem` pathSeparators) r
foldlM foldlM
(\y x -> (\y x ->
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
[] -> throwE $ TarDirDoesNotExist tardir [] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y `appendGHCupPath` p)) . sort (p : _) -> pure (y </> p)) . sort
) )
bdir bdir
rs rs
@@ -912,7 +905,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
=> GHCTargetVersion => GHCTargetVersion
-> m FilePath -> m FilePath
ghcInternalBinDir ver = do ghcInternalBinDir ver = do
ghcdir <- fromGHCupPath <$> ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
pure (ghcdir </> "bin") pure (ghcdir </> "bin")
@@ -1023,28 +1016,6 @@ applyPatch patch ddir = do
!? PatchFailed !? PatchFailed
applyAnyPatch :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadCatch m
, MonadResource m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
liftE $ applyPatch patch workdir
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
=> Platform => Platform
@@ -1058,8 +1029,6 @@ darwinNotarization Darwin path = exec
darwinNotarization _ _ = pure $ Right () darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog dls tool (Left v') = getChangeLog dls tool (Left v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls preview (ix tool % ix v' % viChangeLog % _Just) dls
@@ -1070,6 +1039,7 @@ getChangeLog dls tool (Right tag) =
-- | Execute a build action while potentially cleaning up: -- | Execute a build action while potentially cleaning up:
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: ( MonadReader env m runBuildAction :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
@@ -1080,12 +1050,15 @@ runBuildAction :: ( MonadReader env m
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
) )
=> GHCupPath -- ^ build directory (cleaned up depending on Settings) => FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts e m a -> Excepts e m a
runBuildAction bdir action = do runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir ->
hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never) when (keepDirs == Never)
$ rmBDir bdir $ rmBDir bdir
v <- v <-
@@ -1097,8 +1070,7 @@ runBuildAction bdir action = do
-- | Clean up the given directory if the action fails, -- | Clean up the given directory if the action fails,
-- depending on the Settings. -- depending on the Settings.
cleanUpOnError :: forall e m a env . cleanUpOnError :: ( MonadReader env m
( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadIO m , MonadIO m
@@ -1108,7 +1080,7 @@ cleanUpOnError :: forall e m a env .
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
) )
=> GHCupPath -- ^ build directory (cleaned up depending on Settings) => FilePath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a -> Excepts e m a
-> Excepts e m a -> Excepts e m a
cleanUpOnError bdir action = do cleanUpOnError bdir action = do
@@ -1117,33 +1089,13 @@ cleanUpOnError bdir action = do
flip onException (lift exAction) $ onE_ exAction action flip onException (lift exAction) $ onE_ exAction action
-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanFinally :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a
-> Excepts e m a
cleanFinally bdir action = do
Settings {..} <- lift getSettings
let exAction = when (keepDirs == Never) $ rmBDir bdir
flip finally (lift exAction) $ onE_ exAction action
-- | Remove a build directory, ignoring if it doesn't exist and gracefully -- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing. -- printing other errors without crashing.
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m () rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $ rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ logWarn $ liftIO $ handleIO (\e -> run $ logWarn $
"Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e)) "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
$ rmPathForcibly dir) $ rmPathForcibly dir)
@@ -1161,6 +1113,97 @@ getVersionInfo v' tool =
) )
-- | The file extension for executables.
exeExt :: String
exeExt
| isWindows = ".exe"
| otherwise = ""
-- | The file extension for executables.
exeExt' :: ByteString
exeExt'
| isWindows = ".exe"
| otherwise = ""
-- | On unix, we can use symlinks, so we just get the
-- symbolic link target.
--
-- On windows, we have to emulate symlinks via shims,
-- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath
getLinkTarget fp
| isWindows = do
content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p
| otherwise = getSymbolicLinkTarget fp
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
pathIsLink fp
| isWindows = doesPathExist (dropExtension fp <.> "shim")
| otherwise = pathIsSymbolicLink fp
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
rmLink fp
| isWindows = do
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
| otherwise = hideError doesNotExistErrorType . recycleFile $ fp
-- | Creates a symbolic link on unix and a fake symlink on windows for
-- executables, which:
-- 1. is a shim exe
-- 2. has a corresponding .shim file in the same directory that
-- contains the target
--
-- This overwrites previously existing files.
--
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe
| isWindows = do
dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
logDebug $ "rm -f " <> T.pack exe
rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
| otherwise = do
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
ensureGlobalTools :: ( MonadMask m ensureGlobalTools :: ( MonadMask m
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env
@@ -1182,8 +1225,8 @@ ensureGlobalTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe")) lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe") lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
| otherwise = pure () | otherwise = pure ()
@@ -1191,17 +1234,14 @@ ensureGlobalTools
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO () ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' (fromGHCupPath baseDir) createDirRecursive' baseDir
createDirRecursive' (fromGHCupPath baseDir </> "ghc") createDirRecursive' (baseDir </> "ghc")
createDirRecursive' (fromGHCupPath baseDir </> "hls")
createDirRecursive' binDir createDirRecursive' binDir
createDirRecursive' (fromGHCupPath cacheDir) createDirRecursive' cacheDir
createDirRecursive' (fromGHCupPath logsDir) createDirRecursive' logsDir
createDirRecursive' (fromGHCupPath confDir) createDirRecursive' confDir
createDirRecursive' (fromGHCupPath trashDir) createDirRecursive' trashDir
createDirRecursive' (fromGHCupPath dbDir)
createDirRecursive' (fromGHCupPath tmpDir)
pure () pure ()
@@ -1224,90 +1264,10 @@ ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)
-- 3. if it exists and is non-empty -> panic and leave the house -- 3. if it exists and is non-empty -> panic and leave the house
installDestSanityCheck :: ( MonadIO m installDestSanityCheck :: ( MonadIO m
, MonadCatch m , MonadCatch m
, MonadMask m
) => ) =>
InstallDirResolved -> FilePath ->
Excepts '[DirNotEmpty] m () Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved isoDir) = do installDestSanityCheck isoDir = do
hideErrorDef [doesNotExistErrorType] () $ do hideErrorDef [doesNotExistErrorType] () $ do
empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir contents <- liftIO $ getDirectoryContentsRecursive isoDir
when (not empty') (throwE $ DirNotEmpty isoDir) unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()
-- | Returns 'Nothing' for legacy installs.
getInstalledFiles :: ( MonadIO m
, MonadCatch m
, MonadReader env m
, HasDirs env
, MonadFail m
)
=> Tool
-> GHCTargetVersion
-> m (Maybe [FilePath])
getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
f <- recordedInstallationFile t v'
(force -> !c) <- liftIO
(readFile f >>= evaluate)
pure (Just $ lines c)
-- | Warn if the installed and set HLS is not compatible with the installed and
-- set GHC version.
warnAboutHlsCompatibility :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadCatch m
, MonadIO m
)
=> m ()
warnAboutHlsCompatibility = do
supportedGHC <- hlsGHCVersions
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
currentHLS <- hlsSet
case (currentGHC, currentHLS) of
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
logWarn $
"GHC-" <> T.pack (prettyShow gv) <> " appears to have no corresponding HLS-" <> T.pack (prettyShow hv) <> " binary." <> "\n" <>
"Haskell IDE support may not work." <> "\n" <>
"You can try to either: " <> "\n" <>
" 1. Install a different HLS version (e.g. downgrade for older GHCs)" <> "\n" <>
" 2. Install and set one of the following GHCs: " <> T.pack (prettyShow supportedGHC) <> "\n" <>
" 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " <> T.pack (prettyShow hv) <> " --ghc " <> T.pack (prettyShow gv) <> " --cabal-update\n" <>
" (see https://www.haskell.org/ghcup/guide/#hls for more information)"
_ -> return ()
-----------
--[ Git ]--
-----------
isCommitHash :: String -> Bool
isCommitHash str' = let hex = all isHexDigit str'
len = length str'
in hex && len == 40
gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut args dir = do
CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)
case _exitCode of
ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
ExitFailure c -> do
let pe = NonZeroExit c "git" args
lift $ logDebug $ T.pack (prettyShow pe)
throwE pe
processBranches :: T.Text -> [String]
processBranches str' = let lines' = lines (T.unpack str')
words' = fmap words lines'
refs = catMaybes $ fmap (`atMay` 1) words'
branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
in branches

4
lib/GHCup/Utils.hs-boot Normal file
View File

@@ -0,0 +1,4 @@
module GHCup.Utils where
getLinkTarget :: FilePath -> IO FilePath
pathIsLink :: FilePath -> IO Bool

View File

@@ -3,7 +3,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-| {-|
Module : GHCup.Utils.Dirs Module : GHCup.Utils.Dirs
@@ -31,74 +30,6 @@ module GHCup.Utils.Dirs
, getConfigFilePath , getConfigFilePath
, useXDG , useXDG
, cleanupTrash , cleanupTrash
, GHCupPath
, appendGHCupPath
, fromGHCupPath
, createTempGHCupDirectory
, getGHCupTmpDirs
, removeDirectory
, removeDirectoryRecursive
, removePathForcibly
-- System.Directory re-exports
, createDirectory
, createDirectoryIfMissing
, renameDirectory
, listDirectory
, getDirectoryContents
, getCurrentDirectory
, setCurrentDirectory
, withCurrentDirectory
, getHomeDirectory
, XdgDirectory(..)
, getXdgDirectory
, XdgDirectoryList(..)
, getXdgDirectoryList
, getAppUserDataDirectory
, getUserDocumentsDirectory
, getTemporaryDirectory
, removeFile
, renameFile
, renamePath
, getFileSize
, canonicalizePath
, makeAbsolute
, makeRelativeToCurrentDirectory
, doesPathExist
, doesFileExist
, doesDirectoryExist
, findExecutable
, findExecutables
, findExecutablesInDirectories
, findFile
, findFileWith
, findFilesWith
, exeExtension
, createFileLink
, createDirectoryLink
, removeDirectoryLink
, pathIsSymbolicLink
, getSymbolicLinkTarget
, Permissions
, emptyPermissions
, readable
, writable
, executable
, searchable
, setOwnerReadable
, setOwnerWritable
, setOwnerExecutable
, setOwnerSearchable
, getPermissions
, setPermissions
, copyPermissions
, getAccessTime
, getModificationTime
, setAccessTime
, setModificationTime
, isSymbolicLink
) )
where where
@@ -107,86 +38,35 @@ import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Prelude.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Prelude.File.Search import GHCup.Utils.Logger
import GHCup.Prelude.String.QQ import GHCup.Utils.Prelude
import GHCup.Prelude.Logger.Internal (logWarn, logDebug)
#if defined(IS_WINDOWS)
import GHCup.Prelude.Windows ( isWindows )
#else
import GHCup.Prelude.Posix ( isWindows )
#endif
import Control.DeepSeq (NFData, rnf)
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM) import Control.Monad.Trans.Resource hiding (throwM)
import Data.List
import Data.ByteString ( ByteString )
import Data.Bifunctor import Data.Bifunctor
import Data.Maybe import Data.Maybe
import Data.Versions import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
import Safe import System.Directory
import System.Directory hiding ( removeDirectory import System.DiskSpace
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import qualified System.Directory as SD
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.IO.Temp import System.IO.Temp
import Text.Regex.Posix
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Yaml.Aeson as Y import qualified Data.Yaml.Aeson as Y
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import System.IO.Error (ioeGetErrorType) import Control.Concurrent (threadDelay)
---------------------------
--[ GHCupPath utilities ]--
---------------------------
-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
--
-- The constructor is not exported.
newtype GHCupPath = GHCupPath FilePath
deriving (Show, Eq, Ord)
instance NFData GHCupPath where
rnf (GHCupPath fp) = rnf fp
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)
fromGHCupPath :: GHCupPath -> FilePath
fromGHCupPath (GHCupPath gp) = gp
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d
getGHCupTmpDirs :: IO [GHCupPath]
getGHCupTmpDirs = do
tmpdir <- fromGHCupPath <$> ghcupTMPDir
ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
tmpdir
(makeRegexOpts compExtended
execBlank
([s|^ghcup-.*$|] :: ByteString)
)
pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)
------------------------------ ------------------------------
--[ GHCup base directories ]-- --[ GHCup base directories ]--
------------------------------ ------------------------------
@@ -196,11 +76,11 @@ getGHCupTmpDirs = do
-- --
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec. -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO GHCupPath ghcupBaseDir :: IO FilePath
ghcupBaseDir ghcupBaseDir
| isWindows = do | isWindows = do
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX" bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (GHCupPath (bdir </> "ghcup")) pure (bdir </> "ghcup")
| otherwise = do | otherwise = do
xdg <- useXDG xdg <- useXDG
if xdg if xdg
@@ -210,19 +90,19 @@ ghcupBaseDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share") pure (home </> ".local" </> "share")
pure (GHCupPath (bdir </> "ghcup")) pure (bdir </> "ghcup")
else do else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r Just r -> pure r
Nothing -> liftIO getHomeDirectory Nothing -> liftIO getHomeDirectory
pure (GHCupPath (bdir </> ".ghcup")) pure (bdir </> ".ghcup")
-- | ~/.ghcup by default -- | ~/.ghcup by default
-- --
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec. -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO GHCupPath ghcupConfigDir :: IO FilePath
ghcupConfigDir ghcupConfigDir
| isWindows = ghcupBaseDir | isWindows = ghcupBaseDir
| otherwise = do | otherwise = do
@@ -234,12 +114,12 @@ ghcupConfigDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".config") pure (home </> ".config")
pure (GHCupPath (bdir </> "ghcup")) pure (bdir </> "ghcup")
else do else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r Just r -> pure r
Nothing -> liftIO getHomeDirectory Nothing -> liftIO getHomeDirectory
pure (GHCupPath (bdir </> ".ghcup")) pure (bdir </> ".ghcup")
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -247,7 +127,7 @@ ghcupConfigDir
-- (which, sadly is not strictly xdg spec). -- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO FilePath ghcupBinDir :: IO FilePath
ghcupBinDir ghcupBinDir
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin") | isWindows = ghcupBaseDir <&> (</> "bin")
| otherwise = do | otherwise = do
xdg <- useXDG xdg <- useXDG
if xdg if xdg
@@ -257,16 +137,16 @@ ghcupBinDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin") pure (home </> ".local" </> "bin")
else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin") else ghcupBaseDir <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'. -- | Defaults to '~/.ghcup/cache'.
-- --
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec. -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO GHCupPath ghcupCacheDir :: IO FilePath
ghcupCacheDir ghcupCacheDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache")) | isWindows = ghcupBaseDir <&> (</> "cache")
| otherwise = do | otherwise = do
xdg <- useXDG xdg <- useXDG
if xdg if xdg
@@ -276,17 +156,17 @@ ghcupCacheDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".cache") pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup")) pure (bdir </> "ghcup")
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache")) else ghcupBaseDir <&> (</> "cache")
-- | Defaults to '~/.ghcup/logs'. -- | Defaults to '~/.ghcup/logs'.
-- --
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec. -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO GHCupPath ghcupLogsDir :: IO FilePath
ghcupLogsDir ghcupLogsDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs")) | isWindows = ghcupBaseDir <&> (</> "logs")
| otherwise = do | otherwise = do
xdg <- useXDG xdg <- useXDG
if xdg if xdg
@@ -296,55 +176,16 @@ ghcupLogsDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".cache") pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup" </> "logs")) pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs")) else ghcupBaseDir <&> (</> "logs")
-- | Defaults to '~/.ghcup/db.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO GHCupPath
ghcupDbDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup" </> "db"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
-- | '~/.ghcup/trash'. -- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations -- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO GHCupPath ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash")) ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
-- | Defaults to '~/.ghcup/tmp.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
ghcupTMPDir :: IO GHCupPath
ghcupTMPDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
getAllDirs :: IO Dirs getAllDirs :: IO Dirs
getAllDirs = do getAllDirs = do
@@ -354,8 +195,6 @@ getAllDirs = do
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir confDir <- ghcupConfigDir
recycleDir <- ghcupRecycleDir recycleDir <- ghcupRecycleDir
tmpDir <- ghcupTMPDir
dbDir <- ghcupDbDir
pure Dirs { .. } pure Dirs { .. }
@@ -367,21 +206,16 @@ getAllDirs = do
getConfigFilePath :: (MonadIO m) => m FilePath getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath = do getConfigFilePath = do
confDir <- liftIO ghcupConfigDir confDir <- liftIO ghcupConfigDir
pure $ fromGHCupPath confDir </> "config.yaml" pure $ confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m) ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings => Excepts '[JSONError] m UserSettings
ghcupConfigFile = do ghcupConfigFile = do
filepath <- getConfigFilePath filepath <- getConfigFilePath
contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
case contents of case contents of
Nothing -> pure defaultUserSettings Nothing -> pure defaultUserSettings
Just contents' -> liftE Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
. veitherToExcepts @_ @'[JSONError]
. either (VLeft . V) VRight
. first (JSONDecodeError . displayException)
. Y.decodeEither'
$ contents'
------------------------- -------------------------
@@ -390,10 +224,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default. -- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir = do ghcupGHCBaseDir = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
pure (baseDir `appendGHCupPath` "ghc") pure (baseDir </> "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'. -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -402,11 +236,11 @@ ghcupGHCBaseDir = do
-- * 8.8.4 -- * 8.8.4
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion => GHCTargetVersion
-> m GHCupPath -> m FilePath
ghcupGHCDir ver = do ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir `appendGHCupPath` verdir) pure (ghcbasedir </> verdir)
-- | See 'ghcupToolParser'. -- | See 'ghcupToolParser'.
@@ -418,27 +252,20 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
parseGHCupHLSDir (T.pack -> fp) = parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp throwEither $ MP.parse version' "" fp
-- TODO: inlined from GHCup.Prelude
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
-- | ~/.ghcup/hls by default, for new-style installs. -- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupHLSBaseDir = do ghcupHLSBaseDir = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
pure (baseDir `appendGHCupPath` "hls") pure (baseDir </> "hls")
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs. -- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> Version => Version
-> m GHCupPath -> m FilePath
ghcupHLSDir ver = do ghcupHLSDir ver = do
basedir <- ghcupHLSBaseDir basedir <- ghcupHLSBaseDir
let verdir = T.unpack $ prettyVer ver let verdir = T.unpack $ prettyVer ver
pure (basedir `appendGHCupPath` verdir) pure (basedir </> verdir)
mkGhcupTmpDir :: ( MonadReader env m mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env , HasDirs env
@@ -448,10 +275,31 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadMask m , MonadMask m
, MonadIO m) , MonadIO m)
=> m GHCupPath => m FilePath
mkGhcupTmpDir = GHCupPath <$> do mkGhcupTmpDir = do
Dirs { tmpDir } <- getDirs tmpdir <- liftIO getCanonicalTemporaryDirectory
liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
logWarn ("Possibly insufficient disk space on "
<> T.pack tmpdir
<> ". At least "
<> T.pack (show minSpace)
<> " MB are recommended, but only "
<> toMB (fromJust space)
<> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
logWarn
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
liftIO $ createTempDirectory tmpdir "ghcup"
where
toBytes mb = mb * 1024 * 1024
toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
withGHCupTmpDir :: ( MonadReader env m withGHCupTmpDir :: ( MonadReader env m
@@ -464,15 +312,15 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadMask m , MonadMask m
, MonadIO m) , MonadIO m)
=> m GHCupPath => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> withGHCupTmpDir = snd <$> withRunInIO (\run ->
run run
$ allocate $ allocate
(run mkGhcupTmpDir) (run mkGhcupTmpDir)
(\fp -> (\fp ->
handleIO (\e -> run handleIO (\e -> run
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. removePathForcibly . rmPathForcibly
$ fp)) $ fp))
@@ -512,28 +360,12 @@ cleanupTrash :: ( MonadIO m
=> m () => m ()
cleanupTrash = do cleanupTrash = do
Dirs { recycleDir } <- getDirs Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory (fromGHCupPath recycleDir) contents <- liftIO $ listDirectory recycleDir
if null contents if null contents
then pure () then pure ()
else do else do
logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir)) logWarn ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e -> forM_ contents (\fp -> handleIO (\e ->
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)) logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp)) ) $ liftIO $ removePathForcibly (recycleDir </> fp))
-- System.Directory re-exports with GHCupPath
removeDirectory :: GHCupPath -> IO ()
removeDirectory (GHCupPath fp) = SD.removeDirectory fp
removeDirectoryRecursive :: GHCupPath -> IO ()
removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp
removePathForcibly :: GHCupPath -> IO ()
removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp

Some files were not shown because too many files have changed in this diff Show More