Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • haskell/ghcup-hs
  • ethercrow/ghcup-hs
  • ArturGajowy/ghcup-hs
  • puffnfresh/ghcup-hs
  • Kleidukos/ghcup-hs
  • amesgen/ghcup-hs
  • iyefrat/ghcup-hs
  • alessioprestileo/ghcup-hs
  • szabi/ghcup-hs
  • mrtnpaolo/ghcup-hs
  • Anton-Latukha/ghcup-hs
  • mindbat/ghcup-hs
  • Aster89/ghcup-hs
  • jneira/ghcup-hs
  • HuwCampbell/ghcup-hs
  • yaxu/ghcup-hs
  • trac-parsonsmatt/ghcup-hs
  • bgamari/ghcup-hs
  • fendor/ghcup-hs
  • alinab/ghcup-hs
  • cbarrett/ghcup-hs
  • arjun/ghcup-hs
  • DrewFenwick/ghcup-hs
  • tomjaguarpaw1/ghcup-hs
  • emilypi/ghcup-hs
  • juhp/ghcup-hs
  • vglfr/ghcup-hs
  • jhrcek/ghcup-hs
  • peterbecich/ghcup-hs
  • cdsmith/ghcup-hs
  • rae/ghcup-hs
  • Frank-kilo/ghcup-hs
  • fgaz/ghcup-hs
  • tommd/ghcup-hs
  • galp76/ghcup-hs
  • Joyia012/ghcup-hs
  • normalcoder/ghcup-hs
  • Rufflewind/ghcup-hs
  • Malaki846/ghcup-hs
  • andersonsbr/ghcup-hs
  • MorrowM/ghcup-hs
  • jeremybrunson/ghcup-hs
  • drsooch/ghcup-hs
  • badochov/ghcup-hs
  • InfiniteVerma/ghcup-hs
  • why-not-try-calmer/ghcup-hs
  • jaro/ghcup-hs
  • mpilgrem/ghcup-hs
  • fishtreesugar/ghcup-hs
  • ulysses4ever/ghcup-hs
  • chshersh/ghcup-hs
  • trac-taylorfausak/ghcup-hs
  • 0931665782/ghcup-hs
  • eliadh/ghcup-hs
  • wbadart/ghcup-hs
  • rebeccat/ghcup-hs
  • baig/ghcup-hs
57 results
Show changes
Showing
with 3009 additions and 893 deletions
......@@ -7,7 +7,7 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal --store-dir="$(pwd)"/.store "$@"
cabal "$@"
}
git describe
......@@ -15,32 +15,30 @@ git describe
# build
ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
elif [ "${ARCH}" = "64" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
else
ecabal build -w ghc-${GHC_VERSION} -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" -ftui
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" --constraint="zip +disable-zstd" -ftui
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static"
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
fi
mkdir out
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version)
binary=$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')
ver=$("${binary}" --numeric-version)
if [ "${OS}" = "DARWIN" ] ; then
strip ./ghcup
strip "${binary}"
else
strip -s ./ghcup
strip -s "${binary}"
fi
cp ghcup out/${ARTIFACT}-${ver}
cp "${binary}" out/${ARTIFACT}-${ver}
#!/bin/sh
#!/usr/bin/env bash
set -eux
......@@ -6,114 +6,309 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd)
ecabal() {
cabal --store-dir="$(pwd)"/.store "$@"
cabal "$@"
}
raw_eghcup() {
ghcup -v -c "$@"
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
if [ "${OS}" = "WINDOWS" ] ; then
ghcup -v -c -s file:/$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
else
ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
fi
}
if [ "${OS}" = "WINDOWS" ] ; then
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
git describe --always
### build
ecabal update
rm -rf "${GHCUP_DIR}"/share
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -ftui
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar ghcup-test
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
if [ "${ARCH}" = "64" ] ; then
# doctest
curl -sL https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-docspec/cabal-docspec-0.0.0.20210228_p1.tar.bz2 > cabal-docspec.tar.bz2
echo '3a10f6fec16dbd18efdd331b1cef5d2d342082da42f5b520726d1fa6a3990d12 cabal-docspec.tar.bz2' | sha256sum -c -
tar -xjf cabal-docspec.tar.bz2 cabal-docspec
mv cabal-docspec "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
rm -f cabal-docspec.tar.bz2
chmod a+x "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
cabal-docspec -XCPP -XTypeSynonymInstances -XOverloadedStrings -XPackageImports --check-properties
fi
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd" ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION}
ecabal test -w ghc-${GHC_VERSION} ghcup-test
ecabal haddock -w ghc-${GHC_VERSION}
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
if [ "${OS}" = "WINDOWS" ] ; then
ext=".exe"
else
ext=''
fi
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup${ext}
### cleanup
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
rm -rf "${GHCUP_DIR}"
### manual cli based testing
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
eghcup --numeric-version
eghcup install ${GHC_VERSION}
eghcup set ${GHC_VERSION}
eghcup install-cabal ${CABAL_VERSION}
eghcup install ghc ${GHC_VERSION}
eghcup unset ghc ${GHC_VERSION}
ls -lah "$(eghcup whereis -d ghc ${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 install cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
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_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
eghcup set cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
if [ "${OS}" != "FREEBSD" ] ; then
if [ "${ARCH}" = "64" ] ; 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
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.windows" | sort)
else
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort)
fi
actual=$(cd ".bin" && find . | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
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
ghci --version
ghc-$(ghc --numeric-version) --version
ghci-$(ghc --numeric-version) --version
ghc-${ghc_ver} --version
if [ "${OS}" != "WINDOWS" ] ; then
ghci --version
ghci-${ghc_ver} --version
fi
# 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 install 8.10.3
else # test wget a bit
eghcup install 8.10.3
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup set 8.10.3
eghcup set 8.10.3
[ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
# install hls
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then
if [ "${OS}" = "DARWIN" ] && [ "${ARCH}" = "ARM64" ] ; then
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
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
fi
elif [ "${OS}" = "WINDOWS" ] ; then
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
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_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup unset ghc
"$GHCUP_BIN"/ghc --numeric-version && exit 1 || echo yes
eghcup set ${GHC_VERSION}
eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
ls -lah "$GHCUP_BIN"
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
$(eghcup whereis hls) --version
eghcup install stack
$(eghcup whereis stack) --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; 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
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
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
sha_sum() {
if [ "${OS}" = "FREEBSD" ] ; then
sha256 "$@"
else
sha256sum "$@"
fi
}
# 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
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
eghcup upgrade
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
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 ]
......@@ -15,5 +15,5 @@ git describe
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
hlint -r lib/ test/
hlint -r app/ lib/ test/
[submodule "data/metadata"]
path = data/metadata
url = https://github.com/haskell/ghcup-metadata.git
branch = master
......@@ -20,6 +20,7 @@
- ignore: {name: "Avoid lambda"}
- ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"}
- ignore: {name: "Use unless"}
- ignore: {name: "Redundant irrefutable pattern"}
......
jobs:
include:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
- os: osx
osx_image: xcode10.1
language: generic
......@@ -15,23 +10,16 @@ jobs:
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
allow_failures:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
script: ".travis/build.sh"
deploy:
provider: releases
api_key:
secure: GQESg4TcYf3PQJRRaZV/kWS0hsF+OFnH2+EcwpgnIcfx4+aogMyprdh745KtBXe1FlFN1luKHksFjqceqhcg/xcNyeCJiSnLWMn4D/i4WUperEHseRBi5yZZCB1AvOjIlHrE4DS3a8pyEm1GV3G7CKY5Fu8jBjof2SnyENfd7fofhjtNHWmeFS+jBn8HRDf1YaSRYxzTw6uHLrPLsybfgQZVl7babMu/38Ghin0f5pz5OlNokzDxaubIYQHOZ7st7YndHJtBWWql/KualBWbMILy88dUVQBnbqQLP2P8d1ME8ILUjJVqz33HiRU0JzlEJyWfbvEjcJ6iD8M6n4nXTaxfu3i2UhhGsQ6SSBNKssMP4tji8nkNpMqG59wLQ/zhcetEm71fKkgJNrIMNllkqlWSo5K74IqqP9kiLg/qm8ipOJjui0gPk8tZXKcV+ztX1d1OVCapoLfiDM5l/0LLQXaTOXOV1x3e5LLQ/w2doNiH3eh5CV4II9dRu7owpaiiMBHMssmT0pH99jEeF6giHLKtt3y7l2GWoRLPdhsZZ54gxsaBxZt9GuypmkbNcr97CEnAVaWij5v0CF3w4rAWqy/tAxQpIDJOIOQBgmwG5WrBAKyKrFvEpBL5a8BPcRWJDvqKC83QeWpvPrEVdgJevC6ZN1MKzrb2SiPOwC2Kerc=
secure: "hT2od8Iy04tdFVuonPSWv0NX5hZDmv4al8Q0GbIWmviUetROuM7c6/MCHUcgyiw6H2L3pmH4F24GBYWpKBT3ZMbxrKXhZOZ3KPLXzlnuRlm1qymKqqwsJs3466bMftaiBr16rx1VpAuditN4A32oSmTFcQAJc84Bxn2WZ4t8hk9muS8YPyLhqg3/NxT6ob8dzNp9eS2cA0WODMb/fMzaMruRtepSK8JvuXb/SnTvaDcl9plmPzEa+eW54jwVsDps8ZpQMQlTtGIjYHIwTQ36/iLH4LoAvD7OEnB7qf753LOzmI/bvlB75xYGsLxe1qgpzPMjuG3AK0jb2KGSZCzyAyrbBFSQMIyC1gNKMtab3CohnA9WdQqAT1xrzPzA9zNw516G5Fn/z+t9Ek1f6L2OYO2hJfweNhWh+ChAIsOags2QBpqc0qjkwUS4wqxCWBdyVfgPTUoGelvjCfjQgypgIyLEHFvXt9rlj+kd97FY7nG3vxZrsvWTKKKT551OqUYX5zWTyvGR71jKyNst/p93Pg3DkRy31gHrGnG9zfNgN5tWxJqDd/suR/BAFTp0VtkFb8fR3ct7WMVeJXtE2+bKqxO5Fnocs1VjEm8pKPk7glnp0muu08kaO0h54wiSOCbk1RvO1KZtHue4wKWrHcI18dwW2WtzoBQ4P1lOSkS81UY="
file: $ARTIFACT
on:
repo: haskell/ghcup-hs
repo: hasufell/ghcup-hs
tags: true
skip_cleanup: true
draft: true
......@@ -18,8 +18,8 @@ ghcup set 8.10.4
cabal update
(
cd /tmp
cabal install --installdir="$HOME"/.ghcup/bin hspec-discover
cd /tmp
cabal install --installdir="$HOME"/.ghcup/bin hspec-discover
)
cabal build --constraint="zlib +static" --constraint="lzma +static" -ftui
......
# Revision history for ghcup
## 0.1.18.1 -- 2022-08-06
* 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)
* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)
* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)
* Fix bug with isolated installation of not previously installed versions
* 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`
* 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
* Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137)
* Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)
* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/311)
* Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson
* Fix redundant upgrade warnings in `ghcup upgrade`
* Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)
* Don't print logs to stdout, but stderr
* Allow unpacking legacy lzma archives wrt [#307](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/307)
* Allow to disable self-upgrade functionality wrt [#305](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/305)
* Fix `ghcup install ghc --set` when ghc is already installed wrt [#291](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/291)
## 0.1.17.4 -- 2021-11-13
* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)
* make upgrading ghcup in TUI more pleasant wrt [#276](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/276)
* fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`)
* fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245)
* redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files
* avoid redundant update warnings wrt [#283](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283)
## 0.1.17.3 -- 2021-10-27
* clean up during unpack failures as well
* migrate te aeson-2.0.1.0
* switch to yaml-streamly to fix performance regression wrt [#270](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/270)
* use [github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) for metadata file download (better caching)
## 0.1.17.2 -- 2021-09-30
* Honour GHC bootstrap compiler during git clone stages wrt [#250](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/250)
* Speed up `unset` command
* Fix `--overwrite-version` for `ghcup compile ghc` wrt [#253](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/253)
* Apply patches before bootstrap
## 0.1.17.1 -- 2021-09-26
* Fix `NO_COLOR`
* Fix `ghcup list -t` for hls/stack, wrt [#244](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/244)
* Get rid of concurrent-output
* Improve cli interface with partial versions (e.g. `ghcup install ghc 8`)
* Fix HLS compilation builds
* Implement `ghcup gc` (garbage collection) command
## 0.1.17 -- 2021-09-20
* Add `--force` option to install/compile wrt [#210](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/210) by Arjun Kathuria
* Implement compiling HLS from source wrt [#201](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/201)
* Implement experimental GPG verification of the metadata file (see README) wrt [#263](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/236)
* Add `ghcup unset` command wrt [#145](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/145)
* Add `ghcup whereis bindir` etc wrt [#221](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/221)
* Greatly reduce dependency footprint wrt [#212](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/212)
* Add `ghcup --plan-json`
* Improve `--patchdir` option for GHC compilation wrt [#226](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/226)
* Try to improve logging and failure modes, especially during downloads
* Add descriptive warnings when HLS and GHC versions are incompatible
* Improve curl header parsing wrt [#213](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/213)
## 0.1.16.2 -- 2021-08-12
* Add isolated installations wrt [#141](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/141) by Arjun Kathuria
* Implement config cli MVP wrt [#134](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/134) by Oleksii Dorozhkin
* Fix `ghcup compile ghc --flavor`
* Fix minor installation bug causing increased disk space wrt [#139](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/139)
* Improved error handling wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/136)
* Various improvements to metadata download when using `file://` and `--offline` wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/137)
## 0.1.16.1 -- 2021-07-29
* Add 'nuke' subcommand wrt [#135](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/135), implemented by Arjun Kathuria
* Add uninstallation powershell script on windows wrt [#150](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/150)
* Improve logging
* Fix building GHC cross compiler wrt [#180](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/180)
* Allow to use hadrian as build system (for git based versions only) wrt [#35](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/35)
* Allow passing `--flavor` to `ghcup compile ghc`
* Support new GHC `bin/` directory format wrt [ghc/ghc#20074](https://gitlab.haskell.org/ghc/ghc/-/issues/20074#note_363720)
* Implement `whereis` subcommand wrt [#173](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/173)
* Add `--offline` switch and `prefetch` subcommand wrt [#186](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/186)
* Implement ETAGs hashing for metadata downloads to speed up `ghcup list` wrt [#193](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/193)
* Avoid unnecessary fetching of ghcup metadata in some commands
* Avoid unnecessary update checks for some commands
* Preserve mtimes on unpacked GHC tarballs on windows wrt [#187](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/187), fixing issues with `ghc-pkg`
* Fix lesser bug in `ghcup list` for stray stack versions wrt [#183](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/183)
* Major redo on how file removal on windows works, avoiding partial removals etc, wrt [#165](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/165)
* Improve ghcup tui for screen readers wrt [github/#4](https://github.com/haskell/ghcup-hs/pull/4), thanks to Mario Lang
## 0.1.15.2 -- 2021-06-13
* Remove legacy handling of cabal binary and be more graceful about binaries not installed by ghcup (e.g. stack)
* Fix GHC compilation from git
* Fix 'ghcup upgrade' on windows
* Allow to skip update checks via `GHCUP_SKIP_UPDATE_CHECK`
* Use libarchive on windows as well, fixing unpack errors wrt [#147](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/147)
## 0.1.15.1 -- 2021-06-11
* Add Apple Silicon support
* Add windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130)
* Add stack support
* Warn when /tmp doesn't have 5GB or more of disk space
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
* Allow to set custom ghc version when running 'ghcup compile ghc' wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/136)
* Add date to GHC bindist names created by ghcup
## 0.1.14.2 -- 2021-05-12
* Remove dead dependency on ascii-string
## 0.1.14.1 -- 2021-04-11
* Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119)
......
`ghcup` makes it easy to install specific versions of `ghc` on GNU/Linux,
macOS (aka Darwin) and FreeBSD and can also bootstrap a fresh Haskell developer environment from scratch.
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).
## The GHCup Haskell installer
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).
[![Join the chat at Libera.chat](https://img.shields.io/badge/chat-on%20libera%20IRC-brightgreen.svg)](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)
[![Join the chat at Matrix.org](https://img.shields.io/matrix/haskell-tooling:matrix.org?label=chat%20on%20matrix.org)](https://app.element.io/#/room/#haskell-tooling:matrix.org)
[![Join the chat at Discord](https://img.shields.io/discord/280033776820813825?label=chat%20on%20discord)](https://discord.gg/pKYf3zDQU7)
[![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>
*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
GHCup is the main installer for the general purpose language [Haskell](https://www.haskell.org/).
## Table of Contents
Visit the [documentation](https://www.haskell.org/ghcup/) for installation instructions.
* [Installation](#installation)
* [Simple bootstrap](#simple-bootstrap)
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Configuration](#configuration)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Env variables](#env-variables)
* [Installing custom bindists](#installing-custom-bindists)
* [Design goals](#design-goals)
* [How](#how)
* [Known users](#known-users)
* [Known problems](#known-problems)
* [FAQ](#faq)
## Installation
### Simple bootstrap
Follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/)
### Manual install
Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
and place it into your `PATH` anywhere.
Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
```sh
export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
```
### Vim integration
See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## Usage
See `ghcup --help`.
For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
```sh
# list available ghc/cabal versions
ghcup list
# install the recommended GHC version
ghcup install ghc
# install a specific GHC version
ghcup install ghc 8.2.2
# set the currently "active" GHC version
ghcup set ghc 8.4.4
# install cabal-install
ghcup install cabal
# update ghcup itself
ghcup upgrade
```
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do.
### Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml).
Partial configuration is fine. Command line options always overwrite the config file settings.
### 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.
`MANPATH` may be required to be unset.
### Shell-completion
Shell completions are in `shell-completions`.
For bash: install `shell-completions/bash`
as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros).
### Cross support
ghcup can compile and install a cross GHC for any target. However, this
requires that the build host has a complete cross toolchain and various
libraries installed for the target platform.
Consult the GHC documentation on the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#tools-to-install).
For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information.
### 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`)
### 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
* `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).
## Design goals
1. simplicity
2. non-interactive
3. portable (eh)
4. do one thing and do it well (UNIX philosophy)
### Non-goals
1. invoking `sudo`, `apt-get` or *any* package manager
2. handling system packages
3. handling cabal projects
4. being a stack alternative
## How
Installs a specified GHC version into `~/.ghcup/ghc/<ver>`, and places `ghc-<ver>` symlinks in `~/.ghcup/bin/`.
Optionally, an unversioned `ghc` link can point to a default version of your choice.
This uses precompiled GHC binaries that have been compiled on fedora/debian by [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries).
Alternatively, you can also tell it to compile from source (note that this might fail due to missing requirements).
In addition this script can also install `cabal-install`.
## Known users
* Github action [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
* [vabal](https://github.com/Franciman/vabal)
## Known problems
### Custom ghc version names
When installing ghc bindists with custom version names as outlined in
[installing custom bindists](#installing-custom-bindists), then cabal might
be unable to find the correct `ghc-pkg` (also see [#73](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/73))
if you use `cabal build --with-compiler=ghc-foo`. Instead, point it to the full path, such as:
`cabal build --with-compiler=$HOME/.ghcup/ghc/<version-name>/bin/ghc` or set that GHC version
as the current one via: `ghcup set ghc <version-name>`.
This problem doesn't exist for regularly installed GHC versions.
### Limited distributions supported
Currently only GNU/Linux distributions compatible with the [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries) binaries are supported.
### Precompiled binaries
Since this uses precompiled binaries you may run into
several problems.
#### Missing libtinfo (ncurses)
You may run into problems with *ncurses* and **missing libtinfo**, in case
your distribution doesn't use the legacy way of building
ncurses and has no compatibility symlinks in place.
Ask your distributor on how to solve this or
try to compile from source via `ghcup compile <version>`.
#### Libnuma required
This was a [bug](https://ghc.haskell.org/trac/ghc/ticket/15688) in the build system of some GHC versions that lead to
unconditionally enabled libnuma support. To mitigate this you might have to install the libnuma
package of your distribution. See [here](https://gitlab.haskell.org/haskell/ghcup/issues/58) for a discussion.
### Compilation
Although this script can compile GHC for you, it's just a very thin
wrapper around the build system. It makes no effort in trying
to figure out whether you have the correct toolchain and
the correct dependencies. Refer to [the official docs](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Linux)
on how to prepare your environment for building GHC.
## FAQ
1. Why reimplement stack?
ghcup is not a reimplementation of stack. The only common part is automatic installation of GHC, but even that differs in scope and design.
2. Why not support windows?
Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
3. Why the haskell reimplementation?
Why not?
If you're looking for the metadata YAML files, see here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata)
# RELEASING
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version.
2. Update version in ghcup.cabal
3. Add ChangeLog entry
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
6. Download release artifacts and upload them `downloads.haskell.org/ghcup`
7. Add release artifacts to yaml file (see point 4.)
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import Text.Regex.Posix
import Validate
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
data Options = Options
{ optCommand :: Command
}
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
data Input
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdInput
fileInput :: Parser Input
fileInput =
FileInput
<$> strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
stdInput :: Parser Input
stdInput = flag'
StdInput
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateYAMLOpts = ValidateYAMLOpts
{ vInput :: Maybe Input
}
validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
tarballFilterP :: Parser TarballFilter
tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
def = TarballFilter Nothing (makeRegex ("" :: String))
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
( command
"check"
( ValidateYAML
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
)
<> command
"check-tarballs"
(info
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
main :: IO ()
main = do
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate
ValidateTarballs vopts tarballFilter -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit (validateTarballs tarballFilter)
pure ()
where
valAndExit f contents = do
(GHCupInfo _ av) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#else
import Codec.Archive
#endif
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.Containers.ListUtils ( nubOrd )
import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import HPath ( toFilePath, rel )
import Haskus.Utils.Variant.Excepts
import Optics
import System.Exit
import System.IO
import System.Posix.FilePath
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> m ExitCode
validate dls = do
ref <- liftIO $ newIORef 0
-- verify binary downloads --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)
checkGHCVerIsValid
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
_ <- checkGHCHasBaseVersion
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
addError
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
<$> ( mapM
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) (not (isUniqueTag t) || null ts)
)
. group
. sort
$ allTags
)
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
checkGHCVerIsValid = do
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) [i|GHC version #{v} is not valid |]
addError
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, tags) -> case any isBase tags of
False -> do
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
addError
True -> pure ()
isBase (Base _) = True
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Maybe Tool
, tfVersion :: Regex
}
validateTarballs :: ( Monad m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
)
=> TarballFilter
-> GHCupDownloads
-> m ExitCode
validateTarballs (TarballFilter tool versionRegex) dls = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let dlis = nubOrd $ dls ^.. each
%& indices (maybe (const True) (==) tool) %> each
%& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viSourceDL % _Just `summing` viArch % each % each % each)
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ dlis downloadAll
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = \_ -> pure ()
}
downloadAll dli = do
dirs <- liftIO getDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
r <-
runLogger
. flip runReaderT settings
. runResourceT
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
]
$ do
case tool of
Just GHCup -> do
let fn = [rel|ghcup|]
dir <- liftIO ghcupCacheDir
p <- liftE $ download dli dir (Just fn)
liftE $ checkDigest dli p
pure Nothing
_ -> do
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir (toFilePath -> prel)) -> do
lift $ $(logInfo)
[i|verifying subdir: #{prel}|]
when (basePath /= prel) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected "#{prel}", got "#{basePath}"|]
addError
Just (RegexDir regexString) -> do
lift $ $(logInfo)
[i|verifying subdir (regex): #{regexString}|]
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected regex "#{regexString}", got "#{basePath}"|]
addError
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
lift $ $(logError)
[i|Could not download (or verify hash) of #{dli}, Error was: #{prettyShow e}|]
addError
......@@ -2,20 +2,22 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prompts
import Brick
import Brick.Widgets.Border
......@@ -25,48 +27,52 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr
, listAttr
)
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe
import Control.Monad.Logger
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector
, (!?)
)
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Environment
import System.FilePath
import System.Exit
import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified GHCup.Types as GT
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 Data.Vector as V
import System.Environment (getExecutablePath)
import qualified System.Posix.Process as SPP
hiddenTools :: [Tool]
hiddenTools = []
data BrickData = BrickData
{ lr :: [ListResult]
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
deriving Show
data BrickSettings = BrickSettings
{ showAll :: Bool
{ showAllVersions :: Bool
, showAllTools :: Bool
}
deriving Show
......@@ -97,17 +103,22 @@ keyHandlers KeyBindings {..} =
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAll
, ( bShowAllVersions
, \BrickSettings {..} ->
if showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler (not . showAllVersions) showAllTools
)
, ( bShowAllTools
, \BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
, hideShowHandler
if showAllTools then "Don't show all tools" else "Show all tools"
, hideShowHandler showAllVersions (not . showAllTools)
)
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
]
where
hideShowHandler BrickState{..} =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
hideShowHandler f p BrickState{..} =
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
......@@ -161,7 +172,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
| elem Latest lTag && not lInstalled =
withAttr "hooray"
| otherwise = id
active = if b then forceAttr "active" else id
active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr "active" else id
in hooray $ active $ dim
( marks
<+> padLeft (Pad 2)
......@@ -194,6 +205,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTool GHC = str "GHC"
printTool GHCup = str "GHCup"
printTool HLS = str "HLS"
printTool Stack = str "Stack"
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
......@@ -248,7 +260,7 @@ app attrs dimAttrs =
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const attrs
, appChooseCursor = neverShowCursor
, appChooseCursor = showFirstCursor
}
defaultAttributes :: Bool -> AttrMap
......@@ -316,21 +328,25 @@ moveCursor steps ais@BrickInternalState{..} direction =
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a))
withIOAction :: (BrickState
-> (Int, ListResult)
-> ReaderT AppState IO (Either String a))
-> BrickState
-> EventM n (Next BrickState)
withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
action as (ix, e) >>= \case
Left err -> putStrLn ("Error: " <> err)
Right _ -> putStrLn "Success"
getAppData Nothing (pfreq . appData $ as) >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
Just (ix, e) -> do
suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action as (ix, e) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
-- | Update app data and list internal state based on new evidence.
......@@ -351,17 +367,16 @@ constructList :: BrickData
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAll appSettings)) (lr appD)
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int
selectLatest v =
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
Just ix -> ix
Nothing -> 0
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
-- | Replace the @appState@ or construct it based on a filter function
......@@ -384,27 +399,32 @@ replaceLR filterF lr s =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
filterVisible :: Bool -> ListResult -> Bool
filterVisible showAll e | lInstalled e = True
| showAll = True
| otherwise = not (elem Old (lTag e))
filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, lTool e `notElem` hiddenTools = True
| not v
, t
, Old `notElem` lTag e = True
| v
, t = True
| otherwise = (Old `notElem` lTag e) &&
(lTool e `notElem` hiddenTools)
install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run =
runLogger
. flip runReaderT settings
. runResourceT
runResourceT
. runE
@'[ AlreadyInstalled
#if !defined(TAR)
, ArchiveResult
#endif
, UnknownArchive
, FileDoesNotExistError
, CopyError
......@@ -413,67 +433,115 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
, ProcessError
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
]
run (do
ce <- liftIO $ fmap (either (const Nothing) Just) $
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
dirs <- lift getDirs
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin dls lVer pfreq $> vi
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin dls lVer pfreq $> vi
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup dls Nothing False pfreq $> vi
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin dls lVer pfreq $> vi
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
)
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
VRight (vi, Dirs{..}, Just ce) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
case lTool of
GHCup -> do
up <- liftIO $ fmap (either (const Nothing) Just)
$ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
when ((normalise <$> up) == Just (normalise ce)) $
-- TODO: track cli arguments of previous invocation
liftIO $ SPP.executeFile ce False ["tui"] Nothing
logInfo "Please restart 'ghcup' for the changes to take effect"
_ -> pure ()
pure $ Right ()
VRight (vi, _, _) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
logInfo "Please restart 'ghcup' for the changes to take effect"
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{prettyShow e}
Also check the logs in ~/.ghcup/logs|]
VLeft e -> pure $ Left $ prettyShow e <> "\n"
<> "Also check the logs in ~/.ghcup/logs"
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
set' bs input@(_, ListResult {..}) = do
settings <- liftIO $ readIORef settings'
let run =
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
VLeft e -> case e of
(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)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = runE @'[NotInstalled, UninstallFailed]
run (do
let vi = getVersionInfo lVer lTool dls
......@@ -481,27 +549,33 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> vi
Stack -> liftE $ rmStackVer lVer $> vi
GHCup -> pure Nothing
)
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
forM_ (_viPostRemove =<< vi) $ \msg ->
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
changelog' :: (MonadReader AppState m, MonadIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
changelog' _ (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e
......@@ -509,97 +583,68 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getDirs
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, urlSource = GHCupURL
, ..
})
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
}
newIORef $ AppState defaultSettings
dirs
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
loggerConfig
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState
-> LoggerConfig
-> GHCupDownloads
-> PlatformRequest
-> IO ()
brickMain s l av pfreq' = do
brickMain s = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just av) pfreq'
eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of
Right ad ->
defaultMain
(app (defaultAttributes no_color) (dimAttributes no_color))
(app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
(BrickState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings s)
(keyBindings (s :: AppState))
)
$> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
exitWith $ ExitFailure 2
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAll = False }
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
getDownloads' :: IO (Either String GHCupDownloads)
getDownloads' = do
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ fmap _ghcupDownloads
$ liftE
$ getDownloadsF (urlSource . GT.settings $ settings)
flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE getDownloadsF
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
getAppData :: Maybe GHCupDownloads
-> PlatformRequest
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mg pfreq' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <- maybe getDownloads' (pure . Right) mg
runLogger . flip runReaderT settings $ do
case r of
Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ BrickData (reverse lV) dls pfreq'
Left e -> pure $ Left [i|#{e}|]
getAppData mgi = runExceptT $ do
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module GHCup.OptParse (
module GHCup.OptParse.Common
, module GHCup.OptParse.Install
, module GHCup.OptParse.Set
, module GHCup.OptParse.UnSet
, module GHCup.OptParse.Rm
, module GHCup.OptParse.Compile
, module GHCup.OptParse.Config
, module GHCup.OptParse.Whereis
, module GHCup.OptParse.List
#ifndef DISABLE_UPGRADE
, module GHCup.OptParse.Upgrade
#endif
, module GHCup.OptParse.ChangeLog
, module GHCup.OptParse.Prefetch
, module GHCup.OptParse.GC
, module GHCup.OptParse.DInfo
, module GHCup.OptParse.Nuke
, module GHCup.OptParse.ToolRequirements
, module GHCup.OptParse.Run
, module GHCup.OptParse
) where
import GHCup.OptParse.Common
import GHCup.OptParse.Install
import GHCup.OptParse.Set
import GHCup.OptParse.UnSet
import GHCup.OptParse.Rm
import GHCup.OptParse.Run
import GHCup.OptParse.Compile
import GHCup.OptParse.Config
import GHCup.OptParse.Whereis
import GHCup.OptParse.List
#ifndef DISABLE_UPGRADE
import GHCup.OptParse.Upgrade
#endif
import GHCup.OptParse.ChangeLog
import GHCup.OptParse.Prefetch
import GHCup.OptParse.GC
import GHCup.OptParse.DInfo
import GHCup.OptParse.ToolRequirements
import GHCup.OptParse.Nuke
import GHCup.Types
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Bifunctor
import Data.Either
import Data.Functor
import Data.Maybe
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
data Options = Options
{
-- global options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optMetaCache :: Maybe Integer
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting
-- commands
, optCommand :: Command
}
data Command
= Install (Either InstallCommand InstallOptions)
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
| UnSet UnsetCommand
| List ListOptions
| Rm (Either RmCommand RmOptions)
| DInfo
| Compile CompileCommand
| Config ConfigCommand
| Whereis WhereisOptions WhereisCommand
#ifndef DISABLE_UPGRADE
| Upgrade UpgradeOpts Bool Bool
#endif
| ToolRequirements ToolReqOpts
| ChangeLog ChangeLogOptions
| Nuke
#if defined(BRICK)
| Interactive
#endif
| Prefetch PrefetchCommand
| GC GCOptions
| Run RunOptions
opts :: Parser Options
opts =
Options
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (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
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> optional
(option
(eitherReader parseUri)
( short 's'
<> long "url-source"
<> metavar "URL"
<> help "Alternative ghcup download info url"
<> internal
<> completer fileUri
)
)
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
<*> optional (option
(eitherReader keepOnParser)
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: errors)"
<> hidden
<> completer (listCompleter ["always", "errors", "never"])
))
<*> optional (option
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
<> completer (listCompleter ["internal", "curl", "wget"])
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
<> completer (listCompleter ["curl", "wget"])
#endif
<> hidden
))
<*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> optional (option
(eitherReader gpgParser)
( long "gpg"
<> metavar "<strict|lax|none>"
<> help
"GPG verification (default: none)"
<> completer (listCompleter ["strict", "lax", "none"])
))
<*> com
where
parseUri s' =
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
com =
subparser
#if defined(BRICK)
( command
"tui"
( (\_ -> Interactive)
<$> info
helper
( progDesc "Start the interactive GHCup UI"
)
)
<> command
#else
( command
#endif
"install"
( Install
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal/HLS/stack"
<> footerDoc (Just $ text installToolFooter)
)
)
<> command
"set"
(info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
<> command
"unset"
(info
(UnSet <$> unsetParser <**> helper)
( progDesc "Unset currently active GHC/cabal version"
<> footerDoc (Just $ text unsetFooter)
)
)
<> command
"rm"
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal/HLS/stack version"
<> footerDoc (Just $ text rmFooter)
)
)
<> command
"list"
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
<> command
"upgrade"
(info
( (Upgrade <$> upgradeOptsP <*> switch
(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
)
(progDesc "Upgrade ghcup")
)
<> command
"compile"
( Compile
<$> info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
<> command
"whereis"
(info
( (Whereis
<$> (WhereisOptions <$> switch (short 'd' <> long "directory" <> help "return directory of the binary instead of the binary location"))
<*> whereisP
) <**> helper
)
(progDesc "Find a tools location"
<> footerDoc ( Just $ text whereisFooter ))
)
<> command
"prefetch"
(info
( (Prefetch
<$> prefetchP
) <**> helper
)
(progDesc "Prefetch assets"
<> footerDoc ( Just $ text prefetchFooter ))
)
<> command
"gc"
(info
( (GC
<$> gcP
) <**> helper
)
(progDesc "Garbage collection"
<> footerDoc ( Just $ text gcFooter ))
)
<> command
"run"
(Run
<$>
info
(runOpts <**> helper)
(progDesc "Run a command with the given tool in PATH"
<> footerDoc ( Just $ text runFooter )
)
)
<> commandGroup "Main commands:"
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
<> command
"tool-requirements"
( ToolRequirements
<$> info (toolReqP <**> helper)
(progDesc "Show the requirements for ghc/cabal")
)
<> command
"changelog"
(info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
<> command
"config"
( Config
<$> info (configP <**> helper)
(progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
)
<> commandGroup "Other commands:"
<> hidden
)
<|> subparser
( command
"install-cabal"
(info
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> internal
)
<|> subparser
(command
"nuke"
(info (pure Nuke <**> helper)
(progDesc "Completely remove ghcup from your system"))
<> commandGroup "Nuclear Commands:"
<> hidden
)
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.ChangeLog where
import GHCup.Types
import GHCup.OptParse.Common
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import GHCup.Prelude.Process (exec)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
import GHCup.Utils
import Data.Versions
import URI.ByteString (serializeURIRef')
import Data.Char (toLower)
---------------
--[ Options ]--
---------------
data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool
, clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion
}
---------------
--[ Parsers ]--
---------------
changelogP :: Parser ChangeLogOptions
changelogP =
(\x y -> ChangeLogOptions x y)
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
<*> optional
(option
(eitherReader
(\s' -> case fmap toLower s' of
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
"stack" -> Right Stack
"hls" -> Right HLS
e -> Left e
)
)
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help
"Open changelog for given tool (default: ghc)"
<> completer toolCompleter
)
)
<*> optional (toolVersionTagArgument Nothing Nothing)
--------------
--[ Footer ]--
--------------
changeLogFooter :: String
changeLogFooter = [s|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
------------------
--[ Entrypoint ]--
------------------
changelog :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ChangeLogOptions
-> (forall a . ReaderT AppState m a -> m a)
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
changelog ChangeLogOptions{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
(\case
GHCVersion tv -> Left (_tvVersion tv)
ToolVersion tv -> Left tv
ToolTag t -> Right t
)
clToolVer
muri = getChangeLog dls tool ver'
case muri of
Nothing -> do
runLogger
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
Just uri -> do
pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
if clOpen
then do
runAppState $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-}
module GHCup.OptParse.Common where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.Process
import GHCup.Prelude.Logger
import GHCup.Prelude.MegaParsec
import Control.DeepSeq
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as KM
import qualified Data.Aeson.KeyMap as KM
#else
import qualified Data.HashMap.Strict as KM
#endif
import Data.ByteString.Lazy ( ByteString )
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Functor
import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix )
import Data.Maybe
import Data.Text ( Text )
import Data.Versions hiding ( str )
import Data.Void
import qualified Data.Vector as V
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import Safe
import System.Process ( readProcess )
import System.FilePath
import Text.HTML.TagSoup hiding ( Tag )
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import qualified System.FilePath.Posix as FP
import GHCup.Version
import Control.Exception (evaluate)
-------------
--[ Types ]--
-------------
data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag
-- a superset of ToolVersion
data SetToolVersion = SetGHCVersion GHCTargetVersion
| SetToolVersion Version
| SetToolTag Tag
| SetRecommended
| SetNext
prettyToolVer :: ToolVersion -> String
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
prettyToolVer (ToolTag t) = show t
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer Nothing = SetRecommended
--------------
--[ Parser ]--
--------------
toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionTagArgument criteria tool =
argument (eitherReader (parser tool))
(metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
mv (Just GHC) = "GHC_VERSION|TAG"
mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG"
parser (Just GHC) = ghcVersionTagEither
parser Nothing = ghcVersionTagEither
parser _ = toolVersionTagEither
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
-- The option modifier is applied to only the option that is *not* enabled
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
:: String -- ^ long option
-> Maybe Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier
-> Parser (Maybe Bool)
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
(if defv then mempty else optmod)
(if defv then optmod else mempty)
-- | Allows providing option modifiers for both --foo and --no-foo.
invertableSwitch'
:: String -- ^ long option (eg "foo")
-> Maybe Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier for --foo
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
-> Parser (Maybe Bool)
invertableSwitch' longopt shortopt defv enmod dismod = optional
( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt)
<|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty)
)
where
nolongopt = "no-" ++ longopt
---------------------
--[ Either Parser ]--
---------------------
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Right r -> pure r
Left e -> Left $ errorBundlePretty e
where
archP :: MP.Parsec Void Text Architecture
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (`PlatformRequest` FreeBSD)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "portbld"
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk "-freebsd"
)
, (`PlatformRequest` Darwin)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "apple"
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk "-darwin"
)
, (\a d mv -> PlatformRequest a (Linux d) mv)
<$> (archP <* MP.chunk "-")
<*> distroP
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
)
<* MP.chunk "-linux"
)
]
distroP :: MP.Parsec Void Text LinuxDistro
distroP = choice'
[ MP.chunk "debian" $> Debian
, MP.chunk "deb" $> Debian
, MP.chunk "ubuntu" $> Ubuntu
, MP.chunk "mint" $> Mint
, MP.chunk "fedora" $> Fedora
, MP.chunk "centos" $> CentOS
, MP.chunk "redhat" $> RedHat
, MP.chunk "alpine" $> Alpine
, MP.chunk "gentoo" $> Gentoo
, MP.chunk "exherbo" $> Exherbo
, MP.chunk "unknown" $> UnknownLinux
]
uriParser :: String -> Either String URI
uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
absolutePathParser :: FilePath -> Either String FilePath
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right $ normalise f
False -> Left "Please enter a valid absolute filepath."
isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f && isAbsolute f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
-- this accepts cross prefix
ghcVersionTagEither :: String -> Either String ToolVersion
ghcVersionTagEither 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 s' = case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
Left _ -> Left $ "Invalid PVP version for base " <> ver'
other -> Left $ "Unknown tag " <> other
ghcVersionEither :: String -> Either String GHCTargetVersion
ghcVersionEither =
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 s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| t == T.pack "hls" = Right HLS
| t == T.pack "stack" = Right Stack
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| t == T.pack "available" = Right ListAvailable
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
keepOnParser :: String -> Either String KeepDirs
keepOnParser s' | t == T.pack "always" = Right Always
| t == T.pack "errors" = Right Errors
| t == T.pack "never" = Right Never
| otherwise = Left ("Unknown keep value: " <> s')
where t = T.toLower (T.pack s')
downloaderParser :: String -> Either String Downloader
downloaderParser s' | t == T.pack "curl" = Right Curl
| t == T.pack "wget" = Right Wget
#if defined(INTERNAL_DOWNLOADER)
| t == T.pack "internal" = Right Internal
#endif
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
gpgParser :: String -> Either String GPGSetting
gpgParser s' | t == T.pack "strict" = Right GPGStrict
| t == T.pack "lax" = Right GPGLax
| t == T.pack "none" = Right GPGNone
| otherwise = Left ("Unknown gpg setting value: " <> s')
where t = T.toLower (T.pack s')
------------------
--[ Completers ]--
------------------
toolCompleter :: Completer
toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
gitFileUri :: [String] -> Completer
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
fileUri :: Completer
fileUri = mkCompleter $ fileUri' []
fileUri' :: [String] -> String -> IO [String]
fileUri' add = \case
"" -> do
pwd <- getCurrentDirectory
pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add
xs
| "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>
case stripPrefix "file://" xs of
Nothing -> pure []
Just r -> do
pwd <- getCurrentDirectory
dirs <- compgen "directory" r ["-S", "/"]
files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []
pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])
| xs `isPrefixOf` "file:///" -> pure ["file:///"]
| xs `isPrefixOf` "https://" -> pure ["https://"]
| xs `isPrefixOf` "http://" -> pure ["http://"]
| otherwise -> pure []
where
compgen :: String -> String -> [String] -> IO [String]
compgen action' r opts = do
let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]
result <- tryIO $ readProcess "bash" ["-c", cmd] ""
return . lines . either (const []) id $ result
-- | Strongly quote the string we pass to compgen.
--
-- We need to do this so bash doesn't expand out any ~ or other
-- chars we want to complete on, or emit an end of line error
-- when seeking the close to the quote.
--
-- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote
requote :: String -> String
requote s =
let
-- Bash doesn't appear to allow "mixed" escaping
-- in bash completions. So we don't have to really
-- worry about people swapping between strong and
-- weak quotes.
unescaped =
case s of
-- It's already strongly quoted, so we
-- can use it mostly as is, but we must
-- ensure it's closed off at the end and
-- there's no single quotes in the
-- middle which might confuse bash.
('\'': rs) -> unescapeN rs
-- We're weakly quoted.
('"': rs) -> unescapeD rs
-- We're not quoted at all.
-- We need to unescape some characters like
-- spaces and quotation marks.
elsewise -> unescapeU elsewise
in
strong unescaped
where
strong ss = '\'' : foldr go "'" ss
where
-- If there's a single quote inside the
-- command: exit from the strong quote and
-- emit it the quote escaped, then resume.
go '\'' t = "'\\''" ++ t
go h t = h : t
-- Unescape a strongly quoted string
-- We have two recursive functions, as we
-- can enter and exit the strong escaping.
unescapeN = goX
where
goX ('\'' : xs) = goN xs
goX (x : xs) = x : goX xs
goX [] = []
goN ('\\' : '\'' : xs) = '\'' : goN xs
goN ('\'' : xs) = goX xs
goN (x : xs) = x : goN xs
goN [] = []
-- Unescape an unquoted string
unescapeU = goX
where
goX [] = []
goX ('\\' : x : xs) = x : goX xs
goX (x : xs) = x : goX xs
-- Unescape a weakly quoted string
unescapeD = goX
where
-- Reached an escape character
goX ('\\' : x : xs)
-- If it's true escapable, strip the
-- slashes, as we're going to strong
-- escape instead.
| x `elem` ("$`\"\\\n" :: String) = x : goX xs
| otherwise = '\\' : x : goX xs
-- We've ended quoted section, so we
-- don't recurse on goX, it's done.
goX ('"' : xs)
= xs
-- Not done, but not a special character
-- just continue the fold.
goX (x : xs)
= x : goX xs
goX []
= []
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let appState = LeanAppState
(defaultSettings { noNetwork = True })
dirs'
defaultKeyBindings
loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
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' criteria tool filter' = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let settings = defaultSettings { noNetwork = True }
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
settings
dirs'
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
toolDlCompleter :: Tool -> Completer
toolDlCompleter tool = mkCompleter $ \case
"" -> pure (initUrl tool <> ["https://", "http://", "file:///"])
word
| "file://" `isPrefixOf` word -> fileUri' [] word
-- downloads.haskell.org
| "https://downloads.haskell.org/" `isPrefixOf` word ->
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word
-- github releases
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"
| "https://github.com/commercialhaskell/stack/releases/download/" == word
, let xs = splitPath word
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"
-- github release assets
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 7 && last word == '/') || length xs == 8
, let rel = xs !! 6
, length rel > 1 -> do
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)
| "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 7 && last word == '/') || length xs == 8
, let rel = xs !! 6
, length rel > 1 -> do
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)
-- github
| "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
| "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
| "https://g" `isPrefixOf` word
, tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
| "https://g" `isPrefixOf` word
, tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
| "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool
| "h" `isPrefixOf` word -> pure $ initUrl tool
| word `isPrefixOf` "file:///" -> pure ["file:///"]
| word `isPrefixOf` "https://" -> pure ["https://"]
| word `isPrefixOf` "http://" -> pure ["http://"]
| otherwise -> pure []
where
initUrl :: Tool -> [String]
initUrl GHC = [ "https://downloads.haskell.org/~ghc/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"
]
initUrl Cabal = [ "https://downloads.haskell.org/~cabal/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"
]
initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ]
initUrl HLS = [ "https://github.com/haskell/haskell-language-server/releases/download/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"
]
initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"
]
completePrefix :: String -- ^ url, e.g. 'https://github.com/haskell/haskell-languag'
-> String -- ^ match, e.g. 'haskell-language-server'
-> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'
completePrefix url match =
let base = FP.takeDirectory url
fn = FP.takeFileName url
in if fn `isPrefixOf` match then base <> "/" <> match else url
prefixMatch :: String -> [String] -> [String]
prefixMatch pref = filter (pref `isPrefixOf`)
fromHRef :: String -> IO [String]
fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->
pure
. fmap (T.unpack . decUTF8Safe' . fromAttrib "href")
. filter isTagOpen
. filter (~== ("<a href>" :: String))
. parseTags
$ stdout
withCurl :: String -- ^ url
-> Int -- ^ delay
-> (ByteString -> IO [String]) -- ^ callback
-> IO [String]
withCurl url delay cb = do
let limit = threadDelay delay
race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case
Right (CapturedProcess {_exitCode, _stdOut}) -> do
case _exitCode of
ExitSuccess ->
(try @_ @SomeException . cb $ _stdOut) >>= \case
Left _ -> pure []
Right r' -> do
r <- try @_ @SomeException
. evaluate
. force
$ r'
either (\_ -> pure []) pure r
ExitFailure _ -> pure []
Left _ -> pure []
getGithubReleases :: String
-> String
-> IO [String]
getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do
Just xs <- pure $ decode' @Array stdout
fmap V.toList $ forM xs $ \x -> do
(Object r) <- pure x
Just (String name) <- pure $ KM.lookup (mkval "tag_name") r
pure $ T.unpack name
where
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"
getGithubAssets :: String
-> String
-> String
-> IO [String]
getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do
Just xs <- pure $ decode' @Object stdout
Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs
as <- fmap V.toList $ forM assets $ \val -> do
(Object asset) <- pure val
Just (String name) <- pure $ KM.lookup (mkval "name") asset
pure $ T.unpack name
pure as
where
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag
#if MIN_VERSION_aeson(2,0,0)
mkval = KM.fromString
#else
mkval = id
#endif
-----------------
--[ Utilities ]--
-----------------
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Maybe ToolVersion
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> SetToolVersion
-> Tool
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool
?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just 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
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
ghcs <- rights <$> lift getInstalledGHCs
(headMay
. tail
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
. cycle
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
. filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
$ ghcs) ?? NoToolVersionSet tool
Cabal -> do
set <- cabalSet !? NoToolVersionSet tool
cabals <- rights <$> lift getInstalledCabals
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ cabals) ?? NoToolVersionSet tool
HLS -> do
set <- hlsSet !? NoToolVersionSet tool
hlses <- rights <$> lift getInstalledHLSs
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ hlses) ?? NoToolVersionSet tool
Stack -> do
set <- stackSet !? NoToolVersionSet tool
stacks <- rights <$> lift getInstalledStacks
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls
pure (next, vi)
fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadFail m
)
=> m [(Tool, Version)]
checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing
otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
forMM (getLatest dls t) $ \(l, _) -> do
let mver = latestInstalled t
forMM mver $ \ver ->
if (l > ver) then pure $ Just (t, l) else pure Nothing
pure $ catMaybes (ghcup:otherTools)
where
forMM a f = fmap join $ forM a f
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Compile where
import GHCup
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Codec.Archive ( ArchiveResult )
import Control.Concurrent (threadDelay)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Functor
import Data.Maybe
import Data.Versions ( Version, prettyVer, version, pvp )
import qualified Data.Versions as V
import Data.Text ( Text )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask, displayException)
import System.FilePath (isPathSeparator)
import Text.Read (readEither)
----------------
--[ Commands ]--
----------------
data CompileCommand = CompileGHC GHCCompileOptions
| CompileHLS HLSCompileOptions
---------------
--[ Options ]--
---------------
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: GHC.GHCVer Version
, bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int
, buildConfig :: Maybe FilePath
, patches :: Maybe (Either FilePath [URI])
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String
, hadrian :: Bool
, isolateDir :: Maybe FilePath
}
data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: HLS.HLSVer
, jobs :: Maybe Int
, setCompile :: Bool
, updateCabal :: Bool
, ovewrwiteVer :: Either Bool Version
, isolateDir :: Maybe FilePath
, cabalProject :: Maybe (Either FilePath URI)
, cabalProjectLocal :: Maybe URI
, patches :: Maybe (Either FilePath [URI])
, targetGHCs :: [ToolVersion]
, cabalArgs :: [Text]
}
---------------
--[ Parsers ]--
---------------
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> info
(ghcCompileOpts <**> helper)
( progDesc "Compile GHC from source"
<> footerDoc (Just $ text compileFooter)
)
)
<> command
"hls"
( CompileHLS
<$> info
(hlsCompileOpts <**> helper)
( progDesc "Compile HLS from source"
<> footerDoc (Just $ text compileHLSFooter)
)
)
)
where
compileFooter = [s|Discussion:
Compiles and installs the specified GHC version into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
This also allows building a cross-compiler. Consult the documentation
first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
ENV variables:
Various toolchain variables will be passed onto the ghc build system,
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
Examples:
# compile from known version
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
# compile from git commit/reference
ghcup compile ghc -j 4 -g master -b 8.2.2
# specify path to bootstrap ghc
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version.
The --ghc arguments are necessary to specify which GHC version to build for/against.
These need to be available in PATH prior to compilation.
Examples:
# compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build
ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update
# compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state
ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
# 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 =
GHCCompileOptions
<$> ((GHC.SourceDist <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
<> (completer $ versionCompleter Nothing GHC)
)
) <|>
(GHC.GitDist <$> (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://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
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
)
)
( short 'b'
<> long "bootstrap-ghc"
<> metavar "BOOTSTRAP_GHC"
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
<> (completer $ versionCompleter Nothing GHC)
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
)
)
<*> optional
(option
str
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
<> completer (bashCompleter "file")
)
)
<*> (optional
(
(fmap Right $ many $ option
(eitherReader uriParser)
(long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)"
<> completer fileUri
)
)
<|>
(fmap Left $ option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"
<> completer (bashCompleter "directory")
)
)
)
)
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)"))
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
<> (completer $ versionCompleter Nothing GHC)
)
)
<*> optional
(option
str
(short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
"Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
)
)
<*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory")
)
)
hlsCompileOpts :: Parser HLSCompileOptions
hlsCompileOpts =
HLSCompileOptions
<$> ((HLS.HackageDist <$> option
(eitherReader
((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The version to compile (pulled from hackage)"
<> (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)
)
))
<|>
(
HLS.RemoteDist <$> (option
(eitherReader uriParser)
(long "remote-source-dist" <> metavar "URI" <> help
"URI (https/http/file) to a HLS source distribution"
<> completer fileUri
)
)
)
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
)
)
<*> 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")
<*>
(
(Right <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
<> (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
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory")
)
)
<*> optional
(option
((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help
"If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
<> completer fileUri
)
)
<*> optional
(option
(eitherReader uriParser)
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
"URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
<> completer fileUri
)
)
<*> (optional
(
(fmap Right $ many $ option
(eitherReader uriParser)
(long "patch" <> metavar "PATCH_URI" <> help
"URI to a patch (https/http/file)"
<> completer fileUri
)
)
<|>
(fmap Left $ option
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
<> completer (bashCompleter "directory")
)
)
)
)
<*> some (
option (eitherReader ghcVersionTagEither)
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
<> completer (tagCompleter GHC [])
<> completer (versionCompleter Nothing GHC))
)
<*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
---------------------------
--[ Effect interpreters ]--
---------------------------
type GHCEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
]
type HLSEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled
, DirNotEmpty
, ArchiveResult
, UninstallFailed
, MergeFileTreeError
]
runCompileGHC :: (MonadUnliftIO m, MonadIO m)
=> (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a))
-> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither GHCEffects a)
runCompileGHC runAppState =
runAppState
. runResourceT
. runE
@GHCEffects
runCompileHLS :: (MonadUnliftIO m, MonadIO m)
=> (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a))
-> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither HLSEffects a)
runCompileHLS runAppState =
runAppState
. runResourceT
. runE
@HLSEffects
------------------
--[ Entrypoint ]--
------------------
compile :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> CompileCommand
-> Settings
-> Dirs
-> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
compile compileCommand settings Dirs{..} runAppState runLogger = do
case compileCommand of
(CompileHLS HLSCompileOptions { .. }) -> do
runCompileHLS runAppState (do
case targetHLS of
HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ compileHLS
targetHLS
ghcs
jobs
ovewrwiteVer
(maybe GHCupInternal IsolateDir isolateDir)
cabalProject
cabalProjectLocal
updateCabal
patches
cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer)
)
>>= \case
VRight (vi, tv) -> do
runLogger $ logInfo
"HLS successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ prettyVer tv)
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> 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" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do
case targetGhc of
GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
targetVer <- liftE $ compileGHC
((\case
GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
ovewrwiteVer
bootstrapGhc
jobs
buildConfig
patches
addConfArgs
buildFlavour
hadrian
(maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer)
)
>>= \case
VRight (vi, tv) -> do
runLogger $ logInfo
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ tVerToText tv)
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> 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" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Config where
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Exception ( displayException )
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style, ParseError )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Yaml.Aeson as Y
import Control.Exception.Safe (MonadMask)
----------------
--[ Commands ]--
----------------
data ConfigCommand
= ShowConfig
| SetConfig String (Maybe String)
| InitConfig
| AddReleaseChannel URI
---------------
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
<> command "set" setP -- [set] KEY VALUE at help lhs
<> command "show" showP
<> command "add-release-channel" addP
)
<|> argsP -- add show for a single option
<|> pure ShowConfig
where
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
(progDesc "Add a release channel from a URI")
--------------
--[ Footer ]--
--------------
configFooter :: String
configFooter = [s|Examples:
# show current config
ghcup config
# initialize config
ghcup config init
# set <key> <value> configuration pair
ghcup config set <key> <value>|]
configSetFooter :: String
configSetFooter = [s|Examples:
# disable caching
ghcup config set cache false
# switch downloader to wget
ghcup config set downloader Wget
# set mirror for ghcup metadata
ghcup config set '{url-source: { OwnSource: "<url>"}}'|]
-----------------
--[ Utilities ]--
-----------------
formatConfig :: UserSettings -> String
formatConfig = UTF8.toString . Y.encode
updateSettings :: UserSettings -> Settings -> Settings
updateSettings UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache
noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
------------------
--[ Entrypoint ]--
------------------
config :: forall m. ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ConfigCommand
-> Settings
-> KeyBindings
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
config configCommand settings keybindings runLogger = case configCommand of
InitConfig -> do
path <- getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
ShowConfig -> do
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
pure ExitSuccess
(SetConfig k mv) -> do
r <- runE @'[JSONError, ParseError] $ do
case mv of
Just "" ->
throwE $ ParseError "Empty values are not allowed"
Nothing -> do
usersettings <- decodeSettings k
lift $ doConfig usersettings
pure ()
Just v -> do
usersettings <- decodeSettings (k <> ": " <> v <> "\n")
lift $ doConfig usersettings
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
AddReleaseChannel uri -> do
case urlSource settings of
AddSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
pure ExitSuccess
_ -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ExitSuccess
where
doConfig :: MonadIO m => UserSettings -> m ()
doConfig usersettings = do
let settings' = updateSettings usersettings settings
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
runLogger $ logDebug $ T.pack $ show settings'
pure ()
decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.DInfo where
import GHCup
import GHCup.Errors
import GHCup.Version
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import Language.Haskell.TH
-----------------
--[ Utilities ]--
-----------------
describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
let settings = AppState (defaultSettings { noNetwork = True })
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure _ -> pure numericVer
)
)
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
"==========" <> "\n" <>
"GHCup base dir: " <> diBaseDir <> "\n" <>
"GHCup bin dir: " <> diBinDir <> "\n" <>
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
"GHCup cache directory: " <> diCacheDir <> "\n" <>
"Architecture: " <> prettyShow diArch <> "\n" <>
"Platform: " <> prettyShow diPlatform <> "\n" <>
"Version: " <> describe_result
---------------------------
--[ Effect interpreters ]--
---------------------------
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
-> Excepts DInfoEffects (ReaderT env m) a
-> m (VEither DInfoEffects a)
runDebugInfo runAppState =
runAppState
. runE
@DInfoEffects
------------------
--[ Entrypoint ]--
------------------
dinfo :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, Alternative m
)
=> (ReaderT AppState m (VEither DInfoEffects DebugInfo)
-> m (VEither DInfoEffects DebugInfo))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
dinfo runAppState runLogger = do
runDebugInfo runAppState (liftE getDebugInfo)
>>= \case
VRight di -> do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.GC where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
---------------
--[ Options ]--
---------------
data GCOptions = GCOptions
{ gcOldGHC :: Bool
, gcProfilingLibs :: Bool
, gcShareDir :: Bool
, gcHLSNoGHC :: Bool
, gcCache :: Bool
, gcTmp :: Bool
}
---------------
--[ Parsers ]--
---------------
gcP :: Parser GCOptions
gcP =
GCOptions
<$>
switch
(short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
<*>
switch
(short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
<*>
switch
(short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
<*>
switch
(short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
<*>
switch
(short 'c' <> long "cache" <> help "GC the GHCup cache")
<*>
switch
(short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
--------------
--[ Footer ]--
--------------
gcFooter :: String
gcFooter = [s|Discussion:
Performs garbage collection. If no switches are specified, does nothing.|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type GCEffects = '[ NotInstalled, UninstallFailed ]
runGC :: MonadUnliftIO m
=> (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither GCEffects a)
runGC runAppState =
runAppState
. runResourceT
. runE
@GCEffects
------------------
--[ Entrypoint ]--
------------------
gc :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> GCOptions
-> (forall a. ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC (liftE rmOldGHC)
lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir
liftE $ when gcHLSNoGHC rmHLSNoGHC
lift $ when gcCache rmCache
lift $ when gcTmp rmTmp
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 27