Compare commits

..

2 Commits

Author SHA1 Message Date
ff60744cc6 WIP 2023-05-01 16:01:57 +08:00
e0222b4007 First draft of implementing revisions 2023-02-27 13:39:48 +08:00
94 changed files with 36464 additions and 41634 deletions

View File

@@ -1,5 +1,5 @@
freebsd_instance: freebsd_instance:
image_family: freebsd-13-2 image_family: freebsd-13-1
build_task: build_task:
name: build name: build
@@ -16,9 +16,7 @@ build_task:
AWS_ACCESS_KEY_ID: ENCRYPTED[6ed6287e2dd78ab5f84b22232c5245834ab042bd8ba443883aaf4b4d1ecc0481add1fdfad5ae6f6a8cfb418e6f19b2fc] AWS_ACCESS_KEY_ID: ENCRYPTED[6ed6287e2dd78ab5f84b22232c5245834ab042bd8ba443883aaf4b4d1ecc0481add1fdfad5ae6f6a8cfb418e6f19b2fc]
AWS_SECRET_ACCESS_KEY: ENCRYPTED[16f3cda2954c7cee99444e6788eb5997382aa4ce1477e7523fef2586077541f43b5c816156961fc6b4677259679875a7] AWS_SECRET_ACCESS_KEY: ENCRYPTED[16f3cda2954c7cee99444e6788eb5997382aa4ce1477e7523fef2586077541f43b5c816156961fc6b4677259679875a7]
S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d] S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d]
install_script: install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake llvm14
- sed -i.bak -e 's/quarterly/latest/' /etc/pkg/FreeBSD.conf
- pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake llvm14
script: script:
- tzsetup Etc/GMT - tzsetup Etc/GMT
- adjkerntz -a - adjkerntz -a

View File

@@ -1,11 +0,0 @@
root = true
[*]
end_of_line = LF
trim_trailing_whitespace = true
insert_final_newline = true
[*.hs]
indent_style = space
indent_size = 2
max_line_length = 80

View File

@@ -27,11 +27,9 @@ build_with_cache --project-file=cabal.project.release -w "${GHC}" --enable-tests
mkdir -p out mkdir -p out
binary=$(cabal --project-file=cabal.project.release list-bin ghcup) binary=$(cabal --project-file=cabal.project.release list-bin ghcup)
binary_test=$(cabal --project-file=cabal.project.release list-bin ghcup-test) binary_test=$(cabal --project-file=cabal.project.release list-bin ghcup-test)
binary_opttest=$(cabal --project-file=cabal.project.release list-bin ghcup-optparse-test)
ver=$("${binary}" --numeric-version) ver=$("${binary}" --numeric-version)
strip_binary "${binary}" strip_binary "${binary}"
cp "${binary}" "out/${ARTIFACT}-${ver}${ext}" cp "${binary}" "out/${ARTIFACT}-${ver}${ext}"
cp "${binary_test}" "out/test-${ARTIFACT}-${ver}${ext}" cp "${binary_test}" "out/test-${ARTIFACT}-${ver}${ext}"
cp "${binary_opttest}" "out/test-optparse-${ARTIFACT}-${ver}${ext}"
cp ./dist-newstyle/cache/plan.json "out/${ARTIFACT}.plan.json" cp ./dist-newstyle/cache/plan.json "out/${ARTIFACT}.plan.json"

View File

@@ -1,13 +0,0 @@
#!/usr/bin/env bash
case "$(uname -s)" in
MSYS_*|MINGW*)
ext=".exe"
;;
*)
ext=""
;;
esac
echo "cabal-cache disabled (CABAL_CACHE_DISABLE set)"

View File

@@ -15,7 +15,7 @@ sync_from() {
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store" cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi fi
cabal-cache.sh sync-from-archive \ cabal-cache sync-from-archive \
--host-name-override=${S3_HOST} \ --host-name-override=${S3_HOST} \
--host-port-override=443 \ --host-port-override=443 \
--host-ssl-override=True \ --host-ssl-override=True \
@@ -29,7 +29,7 @@ sync_to() {
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store" cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi fi
cabal-cache.sh sync-to-archive \ cabal-cache sync-to-archive \
--host-name-override=${S3_HOST} \ --host-name-override=${S3_HOST} \
--host-port-override=443 \ --host-port-override=443 \
--host-ssl-override=True \ --host-ssl-override=True \
@@ -115,10 +115,6 @@ download_cabal_cache() {
mv "cabal-cache${exe}" "${dest}${exe}" mv "cabal-cache${exe}" "${dest}${exe}"
chmod +x "${dest}${exe}" chmod +x "${dest}${exe}"
fi fi
# install shell wrapper
cp "${CI_PROJECT_DIR}"/.github/scripts/cabal-cache.sh "$HOME"/.local/bin/
chmod +x "$HOME"/.local/bin/cabal-cache.sh
) )
} }

View File

@@ -1,74 +0,0 @@
#!/usr/bin/env bash
set -ex
. .github/scripts/common.sh
run() {
"$@"
}
if [ "${OS}" = "Windows" ] ; then
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
git_describe
rm -rf "${GHCUP_DIR}"
mkdir -p "${GHCUP_BIN}"
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
cp "out/test-${ARTIFACT}"-* "ghcup-test${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}"
chmod +x "ghcup-test${ext}"
"$GHCUP_BIN/ghcup${ext}" --version
eghcup --version
sha_sum "$GHCUP_BIN/ghcup${ext}"
sha_sum "$(raw_eghcup --offline whereis ghcup)"
### cross build
eghcup --numeric-version
eghcup install ghc "${GHC_VER}"
eghcup set ghc "${GHC_VER}"
eghcup install cabal "${CABAL_VER}"
cabal --version
eghcup debug-info
ecabal update
"${WRAPPER}" "$GHCUP_BIN/ghcup${ext}" -c -s "file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" -v \
compile ghc \
$(if [ -n "${HADRIAN_FLAVOUR}" ] ; then printf "%s" "--flavour=${HADRIAN_FLAVOUR}" ; else true ; fi) \
-j "$(nproc)" \
-v "${GHC_TARGET_VERSION}" \
-b "${GHC_VER}" \
-x "${CROSS}" \
-- ${BUILD_CONF_ARGS}
eghcup set ghc "${CROSS}-${GHC_TARGET_VERSION}"
[ "$($(eghcup whereis ghc "${CROSS}-${GHC_TARGET_VERSION}") --numeric-version)" = "${GHC_TARGET_VERSION}" ]
# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
mkdir no_nuke/
mkdir no_nuke/bar
echo 'foo' > no_nuke/file
echo 'bar' > no_nuke/bar/file
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
# nuke
eghcup nuke
[ ! -e "${GHCUP_DIR}" ]
# make sure nuke doesn't resolve symlinks
[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]

View File

@@ -18,10 +18,8 @@ mkdir -p "${GHCUP_BIN}"
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}" cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
cp "out/test-${ARTIFACT}"-* "ghcup-test${ext}" cp "out/test-${ARTIFACT}"-* "ghcup-test${ext}"
cp "out/test-optparse-${ARTIFACT}"-* "ghcup-test-optparse${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}" chmod +x "$GHCUP_BIN/ghcup${ext}"
chmod +x "ghcup-test${ext}" chmod +x "ghcup-test${ext}"
chmod +x "ghcup-test-optparse${ext}"
"$GHCUP_BIN/ghcup${ext}" --version "$GHCUP_BIN/ghcup${ext}" --version
eghcup --version eghcup --version
@@ -31,8 +29,7 @@ sha_sum "$(raw_eghcup --offline whereis ghcup)"
### Haskell test suite ### Haskell test suite
./ghcup-test${ext} ./ghcup-test${ext}
./ghcup-test-optparse${ext} rm ghcup-test${ext}
rm ghcup-test${ext} ghcup-test-optparse${ext}
### manual cli based testing ### manual cli based testing

View File

@@ -25,7 +25,7 @@ jobs:
include: include:
- os: ubuntu-latest - os: ubuntu-latest
DISTRO: Ubuntu DISTRO: Ubuntu
- os: macOS-11 - os: macOS-10.15
DISTRO: na DISTRO: na
- os: windows-latest - os: windows-latest
DISTRO: na DISTRO: na

View File

@@ -1,140 +0,0 @@
name: Test cross bindists
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
schedule:
- cron: '0 2 * * *'
env:
CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
CABAL_CACHE_NONFATAL: yes
jobs:
build:
name: Build linux binary
runs-on: ubuntu-latest
env:
CABAL_VER: 3.10.1.0
JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
ARTIFACT: "x86_64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 64
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Run build
uses: docker://hasufell/alpine-haskell:3.12
with:
args: sh .github/scripts/build.sh
env:
ARTIFACT: ${{ env.ARTIFACT }}
ARCH: ${{ env.ARCH }}
GHC_VER: ${{ env.GHC_VER }}
DISTRO: Alpine
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
- if: always()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: artifacts
path: |
./out/*
test-cross-linux:
name: Test linux cross
needs: "build"
runs-on: [self-hosted, Linux, X64]
container:
image: registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:8d0224e6b2a08157649651e69302380b2bd24e11
options: --user root
env:
CABAL_VER: 3.6.2.0
BUILD_CONF_ARGS: "--enable-unregisterised"
HADRIAN_FLAVOUR: ""
JSON_VERSION: "0.0.7"
GHC_VER: 8.10.6
GHC_TARGET_VERSION: "8.10.7"
ARCH: 64
DISTRO: Debian
ARTIFACT: "x86_64-linux-ghcup"
CROSS: "arm-linux-gnueabihf"
WRAPPER: "run"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run test (64 bit linux)
run: |
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
sudo apt-get install -y gcc-arm-linux-gnueabihf
sudo dpkg --add-architecture armhf
sudo apt-get update -y
sudo apt-get install -y libncurses-dev:armhf
sh .github/scripts/cross.sh
test-cross-js:
name: Test GHC JS cross
needs: "build"
runs-on: [self-hosted, Linux, X64]
container:
image: registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:8d0224e6b2a08157649651e69302380b2bd24e11
options: --user root
env:
CABAL_VER: 3.6.2.0
BUILD_CONF_ARGS: ""
HADRIAN_FLAVOUR: "default+native_bignum"
JSON_VERSION: "0.0.7"
GHC_VER: 9.6.2
GHC_TARGET_VERSION: "9.6.2"
ARCH: 64
DISTRO: Debian
ARTIFACT: "x86_64-linux-ghcup"
CROSS: "javascript-unknown-ghcjs"
WRAPPER: "emconfigure"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run test (64 bit linux)
run: |
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
git clone https://github.com/emscripten-core/emsdk.git
cd emsdk
./emsdk install latest
./emsdk activate latest
. ./emsdk_env.sh
cd ..
bash .github/scripts/cross.sh

View File

@@ -53,7 +53,7 @@ jobs:
platforms: linux/amd64 platforms: linux/amd64
docker-arm32: docker-arm32:
runs-on: [self-hosted, Linux, ARM64] runs-on: [self-hosted, Linux, ARM64, aarch32-linux]
steps: steps:
- uses: docker://arm64v8/ubuntu:focal - uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux) name: Cleanup (aarch64 linux)
@@ -85,7 +85,7 @@ jobs:
with: with:
context: ./docker/arm32v7/focal context: ./docker/arm32v7/focal
push: true push: true
tags: hasufell/arm32v7-ubuntu-haskell:focal tags: hasufell/arm32v7-debian-haskell:10
platforms: linux/arm platforms: linux/arm
docker-aarch: docker-aarch:
@@ -121,5 +121,5 @@ jobs:
with: with:
context: ./docker/arm64v8/focal context: ./docker/arm64v8/focal
push: true push: true
tags: hasufell/arm64v8-ubuntu-haskell:focal tags: hasufell/arm64v8-debian-haskell:10
platforms: linux/arm64 platforms: linux/arm64

View File

@@ -12,16 +12,12 @@ on:
schedule: schedule:
- cron: '0 2 * * *' - cron: '0 2 * * *'
env:
CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
CABAL_CACHE_NONFATAL: yes
jobs: jobs:
build-linux: build-linux:
name: Build linux binary name: Build linux binary
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
@@ -85,7 +81,7 @@ jobs:
name: Build ARM binary name: Build ARM binary
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
@@ -94,7 +90,7 @@ jobs:
fail-fast: true fail-fast: true
matrix: matrix:
include: include:
- os: [self-hosted, Linux, ARM64] - os: [self-hosted, Linux, ARM64, aarch32-linux]
ARTIFACT: "armv7-linux-ghcup" ARTIFACT: "armv7-linux-ghcup"
GHC_VER: 9.2.2 GHC_VER: 9.2.2
ARCH: ARM ARCH: ARM
@@ -158,7 +154,7 @@ jobs:
name: Build binary (Mac/Win) name: Build binary (Mac/Win)
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
MACOSX_DEPLOYMENT_TARGET: 10.13 MACOSX_DEPLOYMENT_TARGET: 10.13
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
@@ -172,7 +168,7 @@ jobs:
ARTIFACT: "aarch64-apple-darwin-ghcup" ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VER: 9.2.6 GHC_VER: 9.2.6
ARCH: ARM64 ARCH: ARM64
- os: macOS-11 - os: macOS-10.15
ARTIFACT: "x86_64-apple-darwin-ghcup" ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.6 GHC_VER: 9.2.6
ARCH: 64 ARCH: 64
@@ -251,7 +247,7 @@ jobs:
needs: "build-linux" needs: "build-linux"
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
strategy: strategy:
matrix: matrix:
@@ -329,12 +325,12 @@ jobs:
needs: "build-arm" needs: "build-arm"
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
strategy: strategy:
matrix: matrix:
include: include:
- os: [self-hosted, Linux, ARM64] - os: [self-hosted, Linux, ARM64, aarch32-linux]
ARTIFACT: "armv7-linux-ghcup" ARTIFACT: "armv7-linux-ghcup"
GHC_VER: 9.2.2 GHC_VER: 9.2.2
ARCH: ARM ARCH: ARM
@@ -396,7 +392,7 @@ jobs:
needs: "build-macwin" needs: "build-macwin"
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
env: env:
CABAL_VER: 3.10.1.0 CABAL_VER: 3.8.1.0
MACOSX_DEPLOYMENT_TARGET: 10.13 MACOSX_DEPLOYMENT_TARGET: 10.13
JSON_VERSION: "0.0.7" JSON_VERSION: "0.0.7"
strategy: strategy:
@@ -407,7 +403,7 @@ jobs:
GHC_VER: 9.2.6 GHC_VER: 9.2.6
ARCH: ARM64 ARCH: ARM64
DISTRO: na DISTRO: na
- os: macOS-11 - os: macOS-10.15
ARTIFACT: "x86_64-apple-darwin-ghcup" ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.6 GHC_VER: 9.2.6
ARCH: 64 ARCH: 64

View File

@@ -1,18 +1,5 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.19.5 -- ????-?-??
* support JS cross compilers wrt [#838](https://github.com/haskell/ghcup-hs/issues/838)
## 0.1.19.4 -- 2023-7-02
* fix missing TUI for aarch64 linux binaries
## 0.1.19.3 -- 2023-6-29
* Implement support for nightlies, wrt [#824](https://github.com/haskell/ghcup-hs/issues/824)
* Fix GC with XDG dirs, fixes [#810](https://github.com/haskell/ghcup-hs/issues/810)
## 0.1.19.2 -- 2023-2-24 ## 0.1.19.2 -- 2023-2-24
* Follow-up fix for JFS/ReiserFS and other filesystem that don't support `d_type`, fixes [#787](https://github.com/haskell/ghcup-hs/issues/787) * Follow-up fix for JFS/ReiserFS and other filesystem that don't support `d_type`, fixes [#787](https://github.com/haskell/ghcup-hs/issues/787)

View File

@@ -11,7 +11,6 @@ module BrickMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.OptParse.Common (logGHCPostRm) import GHCup.OptParse.Common (logGHCPostRm)
@@ -20,6 +19,7 @@ import GHCup.Prelude.File
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prompts import GHCup.Prompts
import GHCup.Types.Optics hiding ( getGHCupInfo )
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@@ -53,6 +53,7 @@ import System.Exit
import System.IO.Unsafe import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import Optics ( view )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder as B
@@ -73,8 +74,8 @@ data BrickData = BrickData
deriving Show deriving Show
data BrickSettings = BrickSettings data BrickSettings = BrickSettings
{ showAllVersions :: Bool { showAllVersions :: Bool
, showAllTools :: Bool , showAllTools :: Bool
} }
deriving Show deriving Show
@@ -156,10 +157,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags") <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes") <+> padLeft (Pad 5) (str "Notes")
renderList' bis@BrickInternalState{..} = renderList' bis@BrickInternalState{..} =
let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr let getMinLength = length . intercalate "," . fmap tagToString
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr minLength = V.maximum $ V.map (getMinLength . lTag) clr
in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis in withDefAttr listAttr . drawListElements (renderItem minLength) True $ bis
renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = renderItem minTagSize _ b listResult@ListResult{lTag = lTag', ..} =
let marks = if let marks = if
| lSet -> (withAttr (attrName "set") $ str "✔✔") | lSet -> (withAttr (attrName "set") $ str "✔✔")
| lInstalled -> (withAttr (attrName "installed") $ str "") | lInstalled -> (withAttr (attrName "installed") $ str "")
@@ -184,7 +185,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
( minHSize 6 ( minHSize 6
(printTool lTool) (printTool lTool)
) )
<+> minHSize minVerSize (str ver) <+> minHSize 15 (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag' <+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l in padLeft (Pad 1) $ minHSize minTagSize $ if null l
then emptyWidget then emptyWidget
@@ -202,11 +203,9 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTag Recommended = Just $ withAttr (attrName "recommended") $ str "recommended" printTag Recommended = Just $ withAttr (attrName "recommended") $ str "recommended"
printTag Latest = Just $ withAttr (attrName "latest") $ str "latest" printTag Latest = Just $ withAttr (attrName "latest") $ str "latest"
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease" printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease"
printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing printTag Old = Nothing
printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease" printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease"
printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly"
printTag (UnknownTag t) = Just $ str t printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal" printTool Cabal = str "cabal"
@@ -218,10 +217,8 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printNotes ListResult {..} = printNotes ListResult {..} =
(if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty (if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty
) )
++ (if fromSrc then [withAttr (attrName "compiled") $ str "compiled"] else mempty)
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty) ++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [withAttr (attrName "day") $ str (show d)])
-- | Draws the list elements. -- | Draws the list elements.
-- --
@@ -276,22 +273,19 @@ app attrs dimAttrs =
defaultAttributes :: Bool -> AttrMap defaultAttributes :: Bool -> AttrMap
defaultAttributes no_color = attrMap defaultAttributes no_color = attrMap
Vty.defAttr Vty.defAttr
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) [ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue)
, (attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red) , (attrName "not-installed", Vty.defAttr `withForeColor` Vty.red)
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green) , (attrName "set" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green) , (attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green) , (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green) , (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow) , (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
, (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red) , (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red) , (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red) , (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red) , (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue) , (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue) , (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
] ]
where where
withForeColor | no_color = const withForeColor | no_color = const
@@ -418,17 +412,13 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True filterVisible v t e | lInstalled e = True
| v | v
, not t , not t
, Nightly `notElem` lTag e
, lTool e `notElem` hiddenTools = True , lTool e `notElem` hiddenTools = True
| not v | not v
, t , t
, Old `notElem` lTag e , Old `notElem` lTag e = True
, Nightly `notElem` lTag e = True
| v | v
, Nightly `notElem` lTag e
, t = True , t = True
| otherwise = (Old `notElem` lTag e) && | otherwise = (Old `notElem` lTag e) &&
(Nightly `notElem` lTag e) &&
(lTool e `notElem` hiddenTools) (lTool e `notElem` hiddenTools)
@@ -471,24 +461,24 @@ install' _ (_, ListResult {..}) = do
dirs <- lift getDirs dirs <- lift getDirs
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
) )
>>= \case >>= \case
VRight (vi, Dirs{..}, Just ce) -> do VRight (vi, Dirs{..}, Just ce) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
case lTool of case lTool of
GHCup -> do GHCup -> do
up <- liftIO $ fmap (either (const Nothing) Just) up <- liftIO $ fmap (either (const Nothing) Just)
@@ -500,7 +490,7 @@ install' _ (_, ListResult {..}) = do
_ -> pure () _ -> pure ()
pure $ Right () pure $ Right ()
VRight (vi, _, _) -> do VRight (vi, _, _) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
logInfo "Please restart 'ghcup' for the changes to take effect" logInfo "Please restart 'ghcup' for the changes to take effect"
pure $ Right () pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
@@ -564,7 +554,7 @@ del' _ (_, ListResult {..}) = do
let run = runE @'[NotInstalled, UninstallFailed] let run = runE @'[NotInstalled, UninstallFailed]
run (do run (do
let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls let vi = getVersionInfo lVer lTool dls
case lTool of case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi Cabal -> liftE $ rmCabalVer lVer $> vi
@@ -574,8 +564,8 @@ del' _ (_, ListResult {..}) = do
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) logGHCPostRm (mkTVer lVer)
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (view viPostRemove =<< vi) $ \msg ->
logInfo msg logInfo msg
pure $ Right () pure $ Right ()
VLeft e -> pure $ Left (prettyHFError e) VLeft e -> pure $ Left (prettyHFError e)
@@ -587,7 +577,7 @@ changelog' :: (MonadReader AppState m, MonadIO m)
-> m (Either String ()) -> m (Either String ())
changelog' _ (_, ListResult {..}) = do changelog' _ (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (ToolVersion lVer) of case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left $ Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
Just uri -> do Just uri -> do
@@ -667,5 +657,5 @@ getAppData mgi = runExceptT $ do
settings <- liftIO $ readIORef settings' settings <- liftIO $ readIORef settings'
flip runReaderT settings $ do flip runReaderT settings $ do
lV <- listVersions Nothing [] False True (Nothing, Nothing) lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV) pure $ BrickData (reverse lV)

View File

@@ -244,8 +244,7 @@ com =
<> command <> command
"list" "list"
(info (List <$> listOpts <**> helper) (info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools" (progDesc "Show available GHCs and other tools")
<> footerDoc (Just $ text listToolFooter))
) )
<> command <> command
"upgrade" "upgrade"

View File

@@ -35,6 +35,7 @@ import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import Data.Versions
import URI.ByteString (serializeURIRef') import URI.ByteString (serializeURIRef')
import Data.Char (toLower) import Data.Char (toLower)
@@ -49,7 +50,7 @@ data ChangeLogOptions = ChangeLogOptions
{ clOpen :: Bool { clOpen :: Bool
, clTool :: Maybe Tool , clTool :: Maybe Tool
, clToolVer :: Maybe ToolVersion , clToolVer :: Maybe ToolVersion
} deriving (Eq, Show) }
@@ -75,12 +76,12 @@ changelogP =
e -> Left e e -> Left e
) )
) )
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup|stack>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help
"Open changelog for given tool (default: ghc)" "Open changelog for given tool (default: ghc)"
<> completer toolCompleter <> completer toolCompleter
) )
) )
<*> optional (toolVersionTagArgument [] Nothing) <*> optional (toolVersionTagArgument Nothing Nothing)
@@ -114,15 +115,20 @@ changelog :: ( Monad m
changelog ChangeLogOptions{..} runAppState runLogger = do changelog ChangeLogOptions{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool let tool = fromMaybe GHC clTool
ver' = fromMaybe ver' = maybe
(ToolTag Latest) (Right Latest)
(\case
GHCVersion tv -> Left (_tvVersion tv)
ToolVersion tv -> Left tv
ToolTag t -> Right t
)
clToolVer clToolVer
muri = getChangeLog dls tool ver' muri = getChangeLog dls tool ver'
case muri of case muri of
Nothing -> do Nothing -> do
runLogger runLogger
(logWarn $ (logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> T.pack (prettyShow ver') "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
) )
pure ExitSuccess pure ExitSuccess
Just uri -> do Just uri -> do

View File

@@ -5,7 +5,6 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Common where module GHCup.OptParse.Common where
@@ -46,8 +45,6 @@ import Data.Functor
import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix ) import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix )
import Data.Maybe import Data.Maybe
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Time.Calendar ( Day )
import Data.Time.Format ( parseTimeM, defaultTimeLocale )
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Data.Void import Data.Void
import qualified Data.Vector as V import qualified Data.Vector as V
@@ -60,6 +57,7 @@ import System.Process ( readProcess )
import System.FilePath import System.FilePath
import Text.HTML.TagSoup hiding ( Tag ) import Text.HTML.TagSoup hiding ( Tag )
import URI.ByteString import URI.ByteString
import Optics ( view )
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@@ -75,27 +73,26 @@ import qualified Cabal.Config as CC
--[ Types ]-- --[ Types ]--
------------- -------------
data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag
-- a superset of ToolVersion -- a superset of ToolVersion
data SetToolVersion = SetGHCVersion GHCTargetVersion data SetToolVersion = SetGHCVersion GHCTargetVersion
| SetToolVersion Version | SetToolVersion Version
| SetToolTag Tag | SetToolTag Tag
| SetToolDay Day
| SetRecommended | SetRecommended
| SetNext | SetNext
deriving (Eq, Show)
prettyToolVer :: ToolVersion -> String prettyToolVer :: ToolVersion -> String
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
prettyToolVer (ToolTag t) = show t prettyToolVer (ToolTag t) = show t
prettyToolVer (ToolDay day) = show day
toSetToolVer :: Maybe ToolVersion -> SetToolVersion toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer (Just (ToolDay d')) = SetToolDay d'
toSetToolVer Nothing = SetRecommended toSetToolVer Nothing = SetRecommended
@@ -106,28 +103,28 @@ toSetToolVer Nothing = SetRecommended
-------------- --------------
toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionTagArgument criteria tool = toolVersionTagArgument criteria tool =
argument (eitherReader (parser tool)) argument (eitherReader (parser tool))
(metavar (mv tool) (metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) []) <> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool) <> foldMap (completer . versionCompleter criteria) tool)
where where
mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE" mv (Just GHC) = "GHC_VERSION|TAG"
mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE" mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG|RELEASE_DATE" mv _ = "VERSION|TAG"
parser (Just GHC) = ghcVersionTagEither parser (Just GHC) = ghcVersionTagEither
parser Nothing = ghcVersionTagEither parser Nothing = ghcVersionTagEither
parser _ = toolVersionTagEither parser _ = toolVersionTagEither
versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack)) (eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
@@ -241,23 +238,22 @@ isolateParser f = case isValid f && isAbsolute f of
-- this accepts cross prefix -- this accepts cross prefix
ghcVersionTagEither :: String -> Either String ToolVersion ghcVersionTagEither :: String -> Either String ToolVersion
ghcVersionTagEither s' = ghcVersionTagEither s' =
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
-- this ignores cross prefix -- this ignores cross prefix
toolVersionTagEither :: String -> Either String ToolVersion toolVersionTagEither :: String -> Either String ToolVersion
toolVersionTagEither s' = toolVersionTagEither s' =
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
tagEither :: String -> Either String Tag tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended "recommended" -> Right Recommended
"latest" -> Right Latest "latest" -> Right Latest
"latest-prerelease" -> Right LatestPrerelease "latest-prerelease" -> Right LatestPrerelease
"latest-nightly" -> Right LatestNightly
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x) Right x -> Right (Base x)
Left _ -> Left $ "Invalid PVP version for base " <> ver' Left _ -> Left $ "Invalid PVP version for base " <> ver'
other -> Left $ "Unknown tag " <> other other -> Left $ "Unknown tag " <> other
ghcVersionEither :: String -> Either String GHCTargetVersion ghcVersionEither :: String -> Either String GHCTargetVersion
@@ -266,7 +262,7 @@ ghcVersionEither =
toolVersionEither :: String -> Either String Version toolVersionEither :: String -> Either String Version
toolVersionEither = toolVersionEither =
first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack first (const "Not a valid version") . MP.parse version' "" . T.pack
toolParser :: String -> Either String Tool toolParser :: String -> Either String Tool
@@ -277,22 +273,12 @@ toolParser s' | t == T.pack "ghc" = Right GHC
| otherwise = Left ("Unknown tool: " <> s') | otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s') where t = T.toLower (T.pack s')
dayParser :: String -> Either String Day
dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right
$ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s
criteriaParser :: String -> Either String ListCriteria criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right $ ListSet True | t == T.pack "set" = Right ListSet
| t == T.pack "available" = Right $ ListAvailable True | t == T.pack "available" = Right ListAvailable
| t == T.pack "+installed" = Right $ ListInstalled True | otherwise = Left ("Unknown criteria: " <> s')
| t == T.pack "+set" = Right $ ListSet True
| t == T.pack "+available" = Right $ ListAvailable True
| t == T.pack "-installed" = Right $ ListInstalled False
| t == T.pack "-set" = Right $ ListSet False
| t == T.pack "-available" = Right $ ListAvailable False
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s') where t = T.toLower (T.pack s')
@@ -466,14 +452,14 @@ tagCompleter tool add = listIOCompleter $ do
case mGhcUpInfo of case mGhcUpInfo of
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (/= Old) let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool) $ (view viTags) =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add) VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
versionCompleter :: [ListCriteria] -> Tool -> Completer versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True) versionCompleter criteria tool = versionCompleter' criteria tool (const True)
versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer versionCompleter' :: Maybe ListCriteria -> Tool -> (Version -> Bool) -> Completer
versionCompleter' criteria tool filter' = listIOCompleter $ do versionCompleter' criteria tool filter' = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
@@ -502,7 +488,7 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
runEnv = flip runReaderT appState runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria False False (Nothing, Nothing) installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
@@ -670,7 +656,6 @@ fromVersion :: ( HasLog env
-> Tool -> Tool
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo) ] m (GHCTargetVersion, Maybe VersionInfo)
@@ -689,58 +674,49 @@ fromVersion' :: ( HasLog env
-> Tool -> Tool
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo) ] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
second Just <$> getRecommended dls tool bimap mkTVer Just <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do fromVersion' (SetGHCVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi', mt) -> do Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mt v', Just vi') pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolVersion (mkTVer -> v)) tool = do fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls let vi = getVersionInfo v tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here case pvp $ prettyVer v of -- need to be strict here
Left _ -> pure (v, vi) Left _ -> pure (mkTVer v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi', mt) -> do Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mt v', Just vi') pure (GHCTargetVersion mempty v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (mkTVer v, vi)
fromVersion' (SetToolTag Latest) tool = do fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolDay day) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> case getByReleaseDay dls tool day of
Left ad -> throwE $ DayNotFound day tool ad
Right v -> pure v
fromVersion' (SetToolTag LatestPrerelease) tool = do fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool bimap mkTVer Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
fromVersion' (SetToolTag LatestNightly) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool
fromVersion' (SetToolTag Recommended) tool = do fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of next <- case tool of
@@ -785,7 +761,7 @@ fromVersion' SetNext tool = do
. sort . sort
$ stacks) ?? NoToolVersionSet tool $ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set" GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo next tool dls let vi = getVersionInfo (_tvVersion next) tool dls
pure (next, vi) pure (next, vi)
fromVersion' (SetToolTag t') tool = fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool throwE $ TagNotFound t' tool
@@ -801,15 +777,15 @@ checkForUpdates :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> m [(Tool, GHCTargetVersion)] => m [(Tool, Version)]
checkForUpdates = do checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing
otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
forMM (getLatest dls t) $ \(l, _) -> do forMM (getLatest dls t) $ \(l, _) -> do
@@ -824,7 +800,7 @@ checkForUpdates = do
logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m ()
logGHCPostRm ghcVer = do logGHCPostRm ghcVer = do
cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store")
(runIdentity . CC.cfgStoreDir <$> CC.readConfig) (runIdentity . CC.cfgStoreDir <$> CC.readConfig)
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir

View File

@@ -16,11 +16,11 @@ import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS import qualified GHCup.HLS as HLS
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Types.Optics
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -36,6 +36,7 @@ import Data.Versions ( Version, prettyVer, version, p
import qualified Data.Versions as V import qualified Data.Versions as V
import Data.Text ( Text ) import Data.Text ( Text )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
@@ -57,7 +58,6 @@ import Text.Read (readEither)
data CompileCommand = CompileGHC GHCCompileOptions data CompileCommand = CompileGHC GHCCompileOptions
| CompileHLS HLSCompileOptions | CompileHLS HLSCompileOptions
deriving (Eq, Show)
@@ -67,7 +67,7 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: GHC.GHCVer { targetGhc :: GHC.GHCVer Version
, bootstrapGhc :: Either Version FilePath , bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe FilePath , buildConfig :: Maybe FilePath
@@ -77,9 +77,9 @@ data GHCCompileOptions = GHCCompileOptions
, setCompile :: Bool , setCompile :: Bool
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String , buildFlavour :: Maybe String
, buildSystem :: Maybe BuildSystem , hadrian :: Bool
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
} deriving (Eq, Show) }
data HLSCompileOptions = HLSCompileOptions data HLSCompileOptions = HLSCompileOptions
@@ -94,7 +94,7 @@ data HLSCompileOptions = HLSCompileOptions
, patches :: Maybe (Either FilePath [URI]) , patches :: Maybe (Either FilePath [URI])
, targetGHCs :: [ToolVersion] , targetGHCs :: [ToolVersion]
, cabalArgs :: [Text] , cabalArgs :: [Text]
} deriving (Eq, Show) }
@@ -171,7 +171,7 @@ ghcCompileOpts =
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile" "The tool version to compile"
<> (completer $ versionCompleter [] GHC) <> (completer $ versionCompleter Nothing GHC)
) )
) <|> ) <|>
(GHC.GitDist <$> (GitBranch <$> option (GHC.GitDist <$> (GitBranch <$> option
@@ -206,7 +206,7 @@ ghcCompileOpts =
<> metavar "BOOTSTRAP_GHC" <> metavar "BOOTSTRAP_GHC"
<> help <> help
"The GHC version (or full path) to bootstrap with (must be installed)" "The GHC version (or full path) to bootstrap with (must be installed)"
<> (completer $ versionCompleter [] GHC) <> (completer $ versionCompleter Nothing GHC)
) )
<*> optional <*> optional
(option (option
@@ -259,7 +259,7 @@ ghcCompileOpts =
) )
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help (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'" "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 [] GHC) <> (completer $ versionCompleter Nothing GHC)
) )
) )
<*> optional <*> optional
@@ -269,22 +269,16 @@ ghcCompileOpts =
"Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
) )
) )
<*> ( <*> switch
(\b -> if b then Just Hadrian else Nothing) <$> switch (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
(long "hadrian" <> help "Use the hadrian build system instead of make. Tries to detect by default."
) )
<|>
(\b -> if b then Just Make else Nothing) <$> switch
(long "make" <> help "Use the make build system instead of hadrian. Tries to detect by default."
)
)
<*> optional <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)
( short 'i' ( short 'i'
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory") <> completer (bashCompleter "directory")
) )
) )
@@ -298,7 +292,7 @@ hlsCompileOpts =
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The version to compile (pulled from hackage)" "The version to compile (pulled from hackage)"
<> (completer $ versionCompleter' [] HLS (either (const False) (const True) . V.pvp . V.prettyVer)) <> (completer $ versionCompleter' Nothing HLS (either (const False) (const True) . V.pvp . V.prettyVer))
) )
) )
<|> <|>
@@ -318,7 +312,7 @@ hlsCompileOpts =
) )
(long "source-dist" <> metavar "VERSION" <> help (long "source-dist" <> metavar "VERSION" <> help
"The version to compile (pulled from packaged git sources)" "The version to compile (pulled from packaged git sources)"
<> (completer $ versionCompleter [] HLS) <> (completer $ versionCompleter Nothing HLS)
) )
)) ))
<|> <|>
@@ -350,7 +344,7 @@ hlsCompileOpts =
) )
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help (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'" "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 [] HLS) <> (completer $ versionCompleter Nothing HLS)
) )
) )
<|> <|>
@@ -367,7 +361,7 @@ hlsCompileOpts =
( short 'i' ( short 'i'
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made" <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
<> completer (bashCompleter "directory") <> completer (bashCompleter "directory")
) )
) )
@@ -410,7 +404,7 @@ hlsCompileOpts =
option (eitherReader ghcVersionTagEither) option (eitherReader ghcVersionTagEither)
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)" ( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> completer (versionCompleter [] GHC)) <> completer (versionCompleter Nothing GHC))
) )
<*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)")) <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
@@ -460,7 +454,6 @@ type HLSEffects = '[ AlreadyInstalled
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist , TarDirDoesNotExist
, TagNotFound , TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
, NotInstalled , NotInstalled
@@ -518,8 +511,8 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case targetHLS of case targetHLS of
HLS.SourceDist targetVer -> do HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (mkTVer targetVer) HLS dls let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (view viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
@@ -538,7 +531,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
cabalArgs cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (mkTVer targetVer) HLS dls let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly Nothing setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
@@ -547,7 +540,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
VRight (vi, tv) -> do VRight (vi, tv) -> do
runLogger $ logInfo runLogger $ logInfo
"HLS successfully compiled and installed" "HLS successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ prettyVer tv) liftIO $ putStr (T.unpack $ prettyVer tv)
pure ExitSuccess pure ExitSuccess
@@ -562,21 +555,26 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9 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 {..}) -> (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do runCompileGHC runAppState (do
case targetGhc of case targetGhc of
GHC.SourceDist targetVer -> do GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (mkTVer targetVer) GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (view viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure () _ -> pure ()
targetVer <- liftE $ compileGHC targetVer <- liftE $ compileGHC
targetGhc ((\case
crossTarget GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
ovewrwiteVer ovewrwiteVer
bootstrapGhc bootstrapGhc
jobs jobs
@@ -584,10 +582,10 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
addConfArgs addConfArgs
buildFlavour buildFlavour
buildSystem hadrian
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly Nothing setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
@@ -596,7 +594,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
VRight (vi, tv) -> do VRight (vi, tv) -> do
runLogger $ logInfo runLogger $ logInfo
"GHC successfully compiled and installed" "GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
liftIO $ putStr (T.unpack $ tVerToText tv) liftIO $ putStr (T.unpack $ tVerToText tv)
pure ExitSuccess pure ExitSuccess

View File

@@ -52,7 +52,6 @@ data ConfigCommand
| SetConfig String (Maybe String) | SetConfig String (Maybe String)
| InitConfig | InitConfig
| AddReleaseChannel Bool URI | AddReleaseChannel Bool URI
deriving (Eq, Show)

View File

@@ -47,7 +47,7 @@ data GCOptions = GCOptions
, gcHLSNoGHC :: Bool , gcHLSNoGHC :: Bool
, gcCache :: Bool , gcCache :: Bool
, gcTmp :: Bool , gcTmp :: Bool
} deriving (Eq, Show) }

View File

@@ -23,6 +23,7 @@ import GHCup.Utils.Dirs
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import GHCup.Types.Optics
import Codec.Archive import Codec.Archive
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
@@ -36,6 +37,7 @@ import Data.Maybe
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Optics
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import URI.ByteString hiding ( uriParser ) import URI.ByteString hiding ( uriParser )
@@ -54,7 +56,6 @@ data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions | InstallCabal InstallOptions
| InstallHLS InstallOptions | InstallHLS InstallOptions
| InstallStack InstallOptions | InstallStack InstallOptions
deriving (Eq, Show)
@@ -71,7 +72,7 @@ data InstallOptions = InstallOptions
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, forceInstall :: Bool , forceInstall :: Bool
, addConfArgs :: [T.Text] , addConfArgs :: [T.Text]
} deriving (Eq, Show) }
@@ -185,7 +186,7 @@ installOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool)) <> completer (toolDlCompleter (fromMaybe GHC tool))
) )
) )
<*> (Just <$> toolVersionTagArgument [] tool) <*> (Just <$> toolVersionTagArgument Nothing tool)
) )
<|> pure (Nothing, Nothing) <|> pure (Nothing, Nothing)
) )
@@ -197,7 +198,7 @@ installOpts tool =
( short 'i' ( short 'i'
<> long "isolate" <> long "isolate"
<> metavar "DIR" <> metavar "DIR"
<> help "install in an isolated absolute directory instead of the default one" <> help "install in an isolated dir instead of the default one"
<> completer (bashCompleter "directory") <> completer (bashCompleter "directory")
) )
) )
@@ -242,7 +243,6 @@ type InstallEffects = '[ AlreadyInstalled
, NotInstalled , NotInstalled
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, DayNotFound
, DigestError , DigestError
, ContentLengthError , ContentLengthError
, GPGError , GPGError
@@ -286,7 +286,6 @@ type InstallGHCEffects = '[ AlreadyInstalled
, NotInstalled , NotInstalled
, ProcessError , ProcessError
, TagNotFound , TagNotFound
, DayNotFound
, TarDirDoesNotExist , TarDirDoesNotExist
, UninstallFailed , UninstallFailed
, UnknownArchive , UnknownArchive
@@ -325,7 +324,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
Nothing -> runInstGHC s' $ do Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
v (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs
@@ -336,8 +335,8 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstGHC s'{ settings = settings {noVerify = True}} $ do runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing)
v (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs
@@ -348,7 +347,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ logInfo "GHC installation successful" runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
@@ -406,7 +405,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "" Nothing Nothing) (DownloadInfo uri Nothing "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@@ -416,7 +415,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ logInfo "Cabal installation successful" runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -456,7 +455,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy -- TODO: support legacy
liftE $ runBothE' (installHLSBindist liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing) (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@@ -466,7 +465,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ logInfo "HLS installation successful" runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -505,7 +504,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "" Nothing Nothing) (DownloadInfo uri Nothing "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@@ -515,7 +514,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ logInfo "Stack installation successful" runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (view viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do

View File

@@ -2,7 +2,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
@@ -15,7 +14,6 @@ import GHCup
import GHCup.Prelude import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Prelude.String.QQ
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -26,7 +24,6 @@ import Data.Char
import Data.List ( intercalate, sort ) import Data.List ( intercalate, sort )
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Data.Time.Calendar ( Day )
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Data.Void import Data.Void
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
@@ -53,12 +50,8 @@ import qualified Text.Megaparsec.Char as MPC
data ListOptions = ListOptions data ListOptions = ListOptions
{ loTool :: Maybe Tool { loTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria , lCriteria :: Maybe ListCriteria
, lFrom :: Maybe Day
, lTo :: Maybe Day
, lHideOld :: Bool
, lShowNightly :: Bool
, lRawFormat :: Bool , lRawFormat :: Bool
} deriving (Eq, Show) }
@@ -67,6 +60,7 @@ data ListOptions = ListOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
listOpts :: Parser ListOptions listOpts :: Parser ListOptions
listOpts = listOpts =
ListOptions ListOptions
@@ -75,7 +69,7 @@ listOpts =
(eitherReader toolParser) (eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
"Tool to list versions for. Default is all" "Tool to list versions for. Default is all"
<> completer toolCompleter <> completer (toolCompleter)
) )
) )
<*> optional <*> optional
@@ -84,53 +78,15 @@ listOpts =
( short 'c' ( short 'c'
<> long "show-criteria" <> long "show-criteria"
<> metavar "<installed|set|available>" <> metavar "<installed|set|available>"
<> help "Apply filtering criteria, prefix with + or -" <> help "Show only installed/set/available tool versions"
<> completer (listCompleter <> completer (listCompleter ["installed", "set", "available"])
[ "+installed", "+set", "+available", "-installed", "-set", "-available"])
) )
) )
<*> optional
(option
(eitherReader dayParser)
(short 's' <> long "since" <> metavar "YYYY-MM-DD" <> help
"List only tools with release date starting at YYYY-MM-DD or later"
<> completer toolCompleter
)
)
<*> optional
(option
(eitherReader dayParser)
(short 'u' <> long "until" <> metavar "YYYY-MM-DD" <> help
"List only tools with release date earlier than YYYY-MM-DD"
<> completer toolCompleter
)
)
<*> switch
(short 'o' <> long "hide-old" <> help "Hide 'old' GHC versions (installed ones are always shown)"
)
<*> switch
(short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)"
)
<*> switch <*> switch
(short 'r' <> long "raw-format" <> help "More machine-parsable format" (short 'r' <> long "raw-format" <> help "More machine-parsable format"
) )
--------------
--[ Footer ]--
--------------
listToolFooter :: String
listToolFooter = [s|Discussion:
Lists tool versions with optional criteria.
Nightlies are by default hidden.
Examples:
# query nightlies in a specific range
ghcup list --show-nightly --since 2022-12-07 --until 2022-12-31
# show all installed GHC versions
ghcup list -t ghc -c installed|]
----------------- -----------------
@@ -149,11 +105,9 @@ printListResult no_color raw lr = do
printTag Recommended = color Green "recommended" printTag Recommended = color Green "recommended"
printTag Latest = color Yellow "latest" printTag Latest = color Yellow "latest"
printTag Prerelease = color Red "prerelease" printTag Prerelease = color Red "prerelease"
printTag Nightly = color Red "nightly"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t printTag (UnknownTag t ) = t
printTag LatestPrerelease = color Red "latest-prerelease" printTag LatestPrerelease = color Red "latest-prerelease"
printTag LatestNightly = color Red "latest-nightly"
printTag Old = "" printTag Old = ""
let let
@@ -180,10 +134,8 @@ printListResult no_color raw lr = do
then [color Green "hls-powered"] then [color Green "hls-powered"]
else mempty else mempty
) )
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty) ++ (if lStray then [color Yellow "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [color Blue (show d)])
++ (if lNoBindist ++ (if lNoBindist
then [color Red "no-bindist"] then [color Red "no-bindist"]
else mempty else mempty
@@ -308,7 +260,7 @@ list :: ( Monad m
-> m ExitCode -> m ExitCode
list ListOptions{..} no_color runAppState = list ListOptions{..} no_color runAppState =
runAppState (do runAppState (do
l <- listVersions loTool (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo) l <- listVersions loTool lCriteria
liftIO $ printListResult no_color lRawFormat l liftIO $ printListResult no_color lRawFormat l
pure ExitSuccess pure ExitSuccess
) )

View File

@@ -76,8 +76,8 @@ nuke appState runLogger = do
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀" lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1" lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing [ListInstalled True] False True (Nothing, Nothing) lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
forM_ lInstalled (liftE . rmTool) forM_ lInstalled (liftE . rmTool)

View File

@@ -83,7 +83,7 @@ prefetchP = subparser
<$> (PrefetchGHCOptions <$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionTagArgument [] (Just GHC)) ) <*> optional (toolVersionTagArgument Nothing (Just GHC)) )
( progDesc "Download GHC assets for installation") ( progDesc "Download GHC assets for installation")
) )
<> <>
@@ -92,7 +92,7 @@ prefetchP = subparser
(info (info
(PrefetchCabal (PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper )) <*> ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation") ( progDesc "Download cabal assets for installation")
) )
<> <>
@@ -101,7 +101,7 @@ prefetchP = subparser
(info (info
(PrefetchHLS (PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just HLS)) <**> helper )) <*> ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation") ( progDesc "Download HLS assets for installation")
) )
<> <>
@@ -110,7 +110,7 @@ prefetchP = subparser
(info (info
(PrefetchStack (PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))) <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just Stack)) <**> helper )) <*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation") ( progDesc "Download stack assets for installation")
) )
<> <>
@@ -148,7 +148,6 @@ Examples:
type PrefetchEffects = '[ TagNotFound type PrefetchEffects = '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
, NoDownload , NoDownload
@@ -195,7 +194,7 @@ prefetch prefetchCommand runAppState runLogger =
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC (v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc if pfGHCSrc
then liftE $ fetchGHCSrc v pfCacheDir then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')

View File

@@ -3,7 +3,6 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
@@ -34,6 +33,7 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import Optics
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
@@ -50,7 +50,6 @@ data RmCommand = RmGHC RmOptions
| RmCabal Version | RmCabal Version
| RmHLS Version | RmHLS Version
| RmStack Version | RmStack Version
deriving (Eq, Show)
@@ -62,7 +61,7 @@ data RmCommand = RmGHC RmOptions
data RmOptions = RmOptions data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion { ghcVer :: GHCTargetVersion
} deriving (Eq, Show) }
@@ -81,19 +80,19 @@ rmParser =
<> command <> command
"cabal" "cabal"
( RmCabal ( RmCabal
<$> info (versionParser' [ListInstalled True] (Just Cabal) <**> helper) <$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version") (progDesc "Remove Cabal version")
) )
<> command <> command
"hls" "hls"
( RmHLS ( RmHLS
<$> info (versionParser' [ListInstalled True] (Just HLS) <**> helper) <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version") (progDesc "Remove haskell-language-server version")
) )
<> command <> command
"stack" "stack"
( RmStack ( RmStack
<$> info (versionParser' [ListInstalled True] (Just Stack) <**> helper) <$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
(progDesc "Remove stack version") (progDesc "Remove stack version")
) )
) )
@@ -103,7 +102,7 @@ rmParser =
rmOpts :: Maybe Tool -> Parser RmOptions rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> ghcVersionArgument [ListInstalled True] tool rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool
@@ -171,7 +170,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo ghcVer GHC dls) pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@@ -187,7 +186,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (mkTVer tv) Cabal dls) pure (getVersionInfo tv Cabal dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@@ -202,7 +201,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (mkTVer tv) HLS dls) pure (getVersionInfo tv HLS dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@@ -217,7 +216,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmStackVer tv rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (mkTVer tv) Stack dls) pure (getVersionInfo tv Stack dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@@ -228,5 +227,5 @@ rm rmCommand runAppState runLogger = case rmCommand of
pure $ ExitFailure 15 pure $ ExitFailure 15
postRmLog vi = postRmLog vi =
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (view viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg

View File

@@ -68,7 +68,7 @@ data RunOptions = RunOptions
, runBinDir :: Maybe FilePath , runBinDir :: Maybe FilePath
, runQuick :: Bool , runQuick :: Bool
, runCOMMAND :: [String] , runCOMMAND :: [String]
} deriving (Eq, Show) }
@@ -92,7 +92,7 @@ runOpts =
(eitherReader ghcVersionTagEither) (eitherReader ghcVersionTagEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
<> completer (tagCompleter GHC []) <> completer (tagCompleter GHC [])
<> (completer $ versionCompleter [] GHC) <> (completer $ versionCompleter Nothing GHC)
) )
) )
<*> optional <*> optional
@@ -100,7 +100,7 @@ runOpts =
(eitherReader toolVersionTagEither) (eitherReader toolVersionTagEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
<> completer (tagCompleter Cabal []) <> completer (tagCompleter Cabal [])
<> (completer $ versionCompleter [] Cabal) <> (completer $ versionCompleter Nothing Cabal)
) )
) )
<*> optional <*> optional
@@ -108,7 +108,7 @@ runOpts =
(eitherReader toolVersionTagEither) (eitherReader toolVersionTagEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
<> completer (tagCompleter HLS []) <> completer (tagCompleter HLS [])
<> (completer $ versionCompleter [] HLS) <> (completer $ versionCompleter Nothing HLS)
) )
) )
<*> optional <*> optional
@@ -116,7 +116,7 @@ runOpts =
(eitherReader toolVersionTagEither) (eitherReader toolVersionTagEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version" (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
<> completer (tagCompleter Stack []) <> completer (tagCompleter Stack [])
<> (completer $ versionCompleter [] Stack) <> (completer $ versionCompleter Nothing Stack)
) )
) )
<*> optional <*> optional
@@ -132,7 +132,7 @@ runOpts =
<*> switch <*> switch
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.") (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits.")) <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
@@ -175,7 +175,6 @@ type RunEffects = '[ AlreadyInstalled
, NotInstalled , NotInstalled
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, DayNotFound
, DigestError , DigestError
, ContentLengthError , ContentLengthError
, GPGError , GPGError
@@ -283,7 +282,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
) )
=> Excepts => Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] (ResourceT (ReaderT AppState m)) Toolchain ] (ResourceT (ReaderT AppState m)) Toolchain
@@ -334,7 +332,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
-> FilePath -> FilePath
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
, UnknownArchive , UnknownArchive
@@ -360,7 +357,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
Just v -> do Just v -> do
isInstalled <- lift $ checkIfToolInstalled' GHC v isInstalled <- lift $ checkIfToolInstalled' GHC v
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
v (_tvVersion v)
GHCupInternal GHCupInternal
False False
[] []

View File

@@ -53,7 +53,6 @@ data SetCommand = SetGHC SetOptions
| SetCabal SetOptions | SetCabal SetOptions
| SetHLS SetOptions | SetHLS SetOptions
| SetStack SetOptions | SetStack SetOptions
deriving (Eq, Show)
@@ -65,7 +64,7 @@ data SetCommand = SetGHC SetOptions
data SetOptions = SetOptions data SetOptions = SetOptions
{ sToolVer :: SetToolVersion { sToolVer :: SetToolVersion
} deriving (Eq, Show) }
@@ -140,9 +139,9 @@ setParser =
setOpts :: Tool -> Parser SetOptions setOpts :: Tool -> Parser SetOptions
setOpts tool = SetOptions <$> setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$> (fromMaybe SetRecommended <$>
optional (setVersionArgument [ListInstalled True] tool)) optional (setVersionArgument (Just ListInstalled) tool))
setVersionArgument :: [ListCriteria] -> Tool -> Parser SetToolVersion setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion
setVersionArgument criteria tool = setVersionArgument criteria tool =
argument (eitherReader setEither) argument (eitherReader setEither)
(metavar "VERSION|TAG|next" (metavar "VERSION|TAG|next"
@@ -185,7 +184,6 @@ setFooter = [s|Discussion:
type SetGHCEffects = '[ FileDoesNotExistError type SetGHCEffects = '[ FileDoesNotExistError
, NotInstalled , NotInstalled
, TagNotFound , TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet] , NoToolVersionSet]
@@ -200,7 +198,6 @@ runSetGHC runAppState =
type SetCabalEffects = '[ NotInstalled type SetCabalEffects = '[ NotInstalled
, TagNotFound , TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet] , NoToolVersionSet]
@@ -215,7 +212,6 @@ runSetCabal runAppState =
type SetHLSEffects = '[ NotInstalled type SetHLSEffects = '[ NotInstalled
, TagNotFound , TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet] , NoToolVersionSet]
@@ -230,7 +226,6 @@ runSetHLS runAppState =
type SetStackEffects = '[ NotInstalled type SetStackEffects = '[ NotInstalled
, TagNotFound , TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet] , NoToolVersionSet]

View File

@@ -112,7 +112,7 @@ testOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool)) <> completer (toolDlCompleter (fromMaybe GHC tool))
) )
) )
<*> (Just <$> toolVersionTagArgument [] tool) <*> (Just <$> toolVersionTagArgument Nothing tool)
) )
<|> pure (Nothing, Nothing) <|> pure (Nothing, Nothing)
) )
@@ -140,7 +140,6 @@ type TestGHCEffects = [ DigestError
, TestFailed , TestFailed
, NextVerNotFound , NextVerNotFound
, TagNotFound , TagNotFound
, DayNotFound
, NoToolVersionSet , NoToolVersionSet
] ]
@@ -169,12 +168,12 @@ test testCommand settings getAppState' runLogger = case testCommand of
(case testBindist of (case testBindist of
Nothing -> runTestGHC s' $ do Nothing -> runTestGHC s' $ do
(v, vi) <- liftE $ fromVersion testVer GHC (v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCVer v addMakeArgs liftE $ testGHCVer (_tvVersion v) addMakeArgs
pure vi pure vi
Just uri -> do Just uri -> do
runTestGHC s'{ settings = settings {noVerify = True}} $ do runTestGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion testVer GHC (v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) v addMakeArgs liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing) (_tvVersion v) addMakeArgs
pure vi pure vi
) )
>>= \case >>= \case

View File

@@ -48,7 +48,6 @@ data UnsetCommand = UnsetGHC UnsetOptions
| UnsetCabal UnsetOptions | UnsetCabal UnsetOptions
| UnsetHLS UnsetOptions | UnsetHLS UnsetOptions
| UnsetStack UnsetOptions | UnsetStack UnsetOptions
deriving (Eq, Show)
@@ -60,7 +59,7 @@ data UnsetCommand = UnsetGHC UnsetOptions
data UnsetOptions = UnsetOptions data UnsetOptions = UnsetOptions
{ sToolVer :: Maybe T.Text -- target platform triple { sToolVer :: Maybe T.Text -- target platform triple
} deriving (Eq, Show) }
@@ -69,7 +68,7 @@ data UnsetOptions = UnsetOptions
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
unsetParser :: Parser UnsetCommand unsetParser :: Parser UnsetCommand
unsetParser = unsetParser =
subparser subparser
@@ -114,14 +113,7 @@ unsetParser =
unsetGHCFooter :: String unsetGHCFooter :: String
unsetGHCFooter = [s|Discussion: unsetGHCFooter = [s|Discussion:
Unsets the the current GHC version. That means there won't Unsets the the current GHC version. That means there won't
be a ~/.ghcup/bin/ghc anymore. be a ~/.ghcup/bin/ghc anymore.|]
Examples:
# unset ghc
ghcup unset ghc
# unset ghc for the target version
ghcup unset ghc armv7-unknown-linux-gnueabihf|]
unsetCabalFooter :: String unsetCabalFooter :: String
unsetCabalFooter = [s|Discussion: unsetCabalFooter = [s|Discussion:

View File

@@ -28,6 +28,7 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import Optics ( view )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask)
@@ -50,7 +51,7 @@ import Data.Versions hiding (str)
data UpgradeOpts = UpgradeInplace data UpgradeOpts = UpgradeInplace
| UpgradeAt FilePath | UpgradeAt FilePath
| UpgradeGHCupDir | UpgradeGHCupDir
deriving (Eq, Show) deriving Show
@@ -144,7 +145,7 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
let vi = fromJust $ snd <$> getLatest dls GHCup let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ logInfo $ runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v "Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg -> forM_ (view viPostInstall vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V NoUpdate) -> do VLeft (V NoUpdate) -> do

View File

@@ -54,7 +54,6 @@ data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
| WhereisCacheDir | WhereisCacheDir
| WhereisLogsDir | WhereisLogsDir
| WhereisConfDir | WhereisConfDir
deriving (Eq, Show)
@@ -67,7 +66,7 @@ data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
data WhereisOptions = WhereisOptions { data WhereisOptions = WhereisOptions {
directory :: Bool directory :: Bool
} deriving (Eq, Show) }
@@ -83,7 +82,7 @@ whereisP = subparser
command command
"ghc" "ghc"
(WhereisTool GHC <$> info (WhereisTool GHC <$> info
( optional (toolVersionTagArgument [] (Just GHC)) <**> helper ) ( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper )
( progDesc "Get GHC location" ( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter )) <> footerDoc (Just $ text whereisGHCFooter ))
) )
@@ -91,7 +90,7 @@ whereisP = subparser
command command
"cabal" "cabal"
(WhereisTool Cabal <$> info (WhereisTool Cabal <$> info
( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper ) ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )
( progDesc "Get cabal location" ( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter )) <> footerDoc (Just $ text whereisCabalFooter ))
) )
@@ -99,7 +98,7 @@ whereisP = subparser
command command
"hls" "hls"
(WhereisTool HLS <$> info (WhereisTool HLS <$> info
( optional (toolVersionTagArgument [] (Just HLS)) <**> helper ) ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )
( progDesc "Get HLS location" ( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter )) <> footerDoc (Just $ text whereisHLSFooter ))
) )
@@ -107,7 +106,7 @@ whereisP = subparser
command command
"stack" "stack"
(WhereisTool Stack <$> info (WhereisTool Stack <$> info
( optional (toolVersionTagArgument [] (Just Stack)) <**> helper ) ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )
( progDesc "Get stack location" ( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter )) <> footerDoc (Just $ text whereisStackFooter ))
) )
@@ -223,7 +222,6 @@ type WhereisEffects = '[ NotInstalled
, NoToolVersionSet , NoToolVersionSet
, NextVerNotFound , NextVerNotFound
, TagNotFound , TagNotFound
, DayNotFound
] ]

View File

@@ -240,7 +240,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
_ _
| Just False <- optVerbose -> pure () | Just False <- optVerbose -> pure ()
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, DayNotFound, NextVerNotFound, NoToolVersionSet] $ do Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
newTools <- lift checkForUpdates newTools <- lift checkForUpdates
forM_ newTools $ \newTool@(t, l) -> do forM_ newTools $ \newTool@(t, l) -> do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283 -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
@@ -249,7 +249,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
case t of case t of
GHCup -> runLogger $ GHCup -> runLogger $
logWarn ("New GHCup version available: " logWarn ("New GHCup version available: "
<> tVerToText l <> prettyVer l
<> ". To upgrade, run 'ghcup upgrade'") <> ". To upgrade, run 'ghcup upgrade'")
_ -> runLogger $ _ -> runLogger $
logWarn ("New " logWarn ("New "
@@ -258,7 +258,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
<> "If you want to install this latest version, run 'ghcup install " <> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t) <> T.pack (prettyShow t)
<> " " <> " "
<> tVerToText l <> prettyVer l
<> "'") <> "'")
Just _ -> pure () Just _ -> pure ()
@@ -332,10 +332,9 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, MonadCatch m , MonadCatch m
) )
=> Command => Command
-> (Tool, GHCTargetVersion) -> (Tool, Version)
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m Bool ] m Bool
@@ -368,13 +367,12 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
) )
=> Tool => Tool
-> Maybe ToolVersion -> Maybe ToolVersion
-> GHCTargetVersion -> Version
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m Bool ] m Bool
cmp' tool instVer ver = do cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool (v, _) <- liftE $ fromVersion instVer tool
pure (v == ver) pure (v == mkTVer ver)

View File

@@ -9,7 +9,7 @@ constraints: http-io-streams -brotli,
any.aeson >= 2.0.1.0 any.aeson >= 2.0.1.0
package libarchive package libarchive
flags: -system-libarchive flags: +system-libarchive
package aeson-pretty package aeson-pretty
flags: +lib-only flags: +lib-only
@@ -23,5 +23,3 @@ package aeson
package streamly package streamly
flags: +use-unliftio flags: +use-unliftio
package *
test-show-details: direct

View File

@@ -37,8 +37,8 @@ RUN apk add --no-cache \
xz-dev \ xz-dev \
ncurses-static ncurses-static
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -37,9 +37,8 @@ RUN apk add --no-cache \
xz-dev \ xz-dev \
ncurses-static ncurses-static
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -29,8 +29,8 @@ RUN apt-get update && \
RUN update_opt.sh 11 1 RUN update_opt.sh 11 1
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.17.8
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -29,8 +29,8 @@ RUN apt-get update && \
RUN update_opt.sh 9 1 RUN update_opt.sh 9 1
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.17.8
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -29,8 +29,8 @@ RUN apt-get update && \
RUN update_opt.sh 11 1 RUN update_opt.sh 11 1
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -29,8 +29,8 @@ RUN apt-get update && \
RUN update_opt.sh 9 1 RUN update_opt.sh 9 1
ARG GHCUP_VERSION=0.1.19.4 ARG GHCUP_VERSION=0.1.18.0
ARG GPG_KEY=7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C ARG GPG_KEY=7784930957807690A66EBDBE3786C5262ECB4A3F
# install ghcup # install ghcup
RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys $GPG_KEY && \

View File

@@ -43,12 +43,6 @@ All of the following are valid arguments to `ghcup install ghc`:
If the argument is omitted, the default is `recommended`. If the argument is omitted, the default is `recommended`.
Other tags include:
- `prerelease`: a prerelease version
- `latest-prerelease`: the latest prerelease version
## Manpages ## Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc. For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
@@ -456,48 +450,8 @@ variables and, in the case of Windows, parameters to tweak the script behavior.
### github workflows ### github workflows
On github workflows GHCup itself is pre-installed on all platforms, but may use non-standard install locations. On github workflows you can use [https://github.com/haskell/actions/](https://github.com/haskell/actions/).
Here's an example workflow with a GHC matrix: GHCup itself is also pre-installed on all platforms, but may use non-standard install locations.
```yaml
jobs:
build:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: true
matrix:
os: [ubuntu-22.04, macOS-latest]
ghc: ['9.6', '9.4', '9.2', '9.0', '8.10', '8.8', '8.6']
steps:
- uses: actions/checkout@v3
- name: Setup toolchain
run: |
ghcup install cabal --set recommended
ghcup install ghc --set ${{ matrix.ghc }}
- name: Build
run: |
cabal update
cabal test all --test-show-details=direct
i386:
runs-on: ubuntu-latest
container:
image: i386/ubuntu:bionic
steps:
- name: Install GHCup in container
run: |
apt-get update -y
apt-get install -y autoconf build-essential zlib1g-dev libgmp-dev curl
# we just go with recommended versions of cabal and GHC
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 sh
- uses: actions/checkout@v1
- name: Test
run: |
# in containers we need to fix PATH
source ~/.ghcup/env
cabal update
cabal test all --test-show-details=direct
```
## GPG verification ## GPG verification
@@ -507,10 +461,8 @@ this is cryptographically secure.
First, obtain the gpg keys: First, obtain the gpg keys:
```sh ```sh
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01 gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 88B57FCF7DB53B4DB3BFA4B1588764FBE22D19C4
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys EAF2A9A722C0C96F2B431CA511AAD8CEDEE0CAEF
``` ```
Then verify the gpg key in one of these ways: Then verify the gpg key in one of these ways:

View File

@@ -38,78 +38,47 @@ Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information
### Linux Debian ### Linux Debian
#### Generic
The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5` The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
#### Version >= 11
The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
### Linux Ubuntu ### Linux Ubuntu
#### Generic
The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5` The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
#### Version >= 20.04 && < 20.10
The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
#### Version >= 20.10
The following distro packages are required: `build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
### Linux Fedora ### Linux Fedora
#### Generic
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl` The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
### Linux Mageia
The following distro packages are required: `curl gcc gcc-c++ gmp libffi-devel libffi7 libgmp-devel libgmp10 make libncurses-devel libncurses5 xz perl`
### Linux CentOS ### Linux CentOS
#### Generic
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl` The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
#### Version >= 7 && < 8
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses xz perl`
### Linux Alpine ### Linux Alpine
#### Generic
The following distro packages are required: `binutils-gold curl gcc g++ gmp-dev libc-dev libffi-dev make musl-dev ncurses-dev perl tar xz` The following distro packages are required: `binutils-gold curl gcc g++ gmp-dev libc-dev libffi-dev make musl-dev ncurses-dev perl tar xz`
### Linux VoidLinux
The following distro packages are required: `gcc gmp curl coreutils xz ncurses make ncurses-libtinfo-libs perl tar`
### Linux (generic) ### Linux (generic)
#### Generic
You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages. You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.
### Darwin ### Darwin
#### Generic
On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again. On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again.
On Darwin M1 you might also need a working llvm installed (e.g. via brew) and have the toolchain exposed in PATH. On Darwin M1 you might also need a working llvm installed (e.g. via brew) and have the toolchain exposed in PATH.
### FreeBSD ### FreeBSD
#### Generic
The following distro packages are required: `curl gcc gmp gmake ncurses perl5 libffi libiconv` The following distro packages are required: `curl gcc gmp gmake ncurses perl5 libffi libiconv`
### Windows ### Windows
#### Generic
On Windows, msys2 should already have been set up during the installation, so most users should just proceed. If you are installing manually, make sure to have a working mingw64 toolchain and shell. On Windows, msys2 should already have been set up during the installation, so most users should just proceed. If you are installing manually, make sure to have a working mingw64 toolchain and shell.
## Next steps ## Next steps
@@ -133,19 +102,10 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead> <thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>9.6.2</td><td><span style="color:blue">latest</span>, base-4.18.0.0</td></tr> <tr><td>9.4.3</td><td><span style="color:blue">latest</span>, base-4.17.0.0</td></tr>
<tr><td>9.6.1</td><td>base-4.18.0.0</td></tr>
<tr><td>9.4.7</td><td>base-4.17.2.0</td></tr>
<tr><td>9.4.6</td><td>base-4.17.2.0</td></tr>
<tr><td>9.4.5</td><td>base-4.17.1.0</td></tr>
<tr><td>9.4.4</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.3</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.2</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.2</td><td>base-4.17.0.0</td></tr>
<tr><td>9.4.1</td><td>base-4.17.0.0</td></tr> <tr><td>9.4.1</td><td>base-4.17.0.0</td></tr>
<tr><td>9.2.8</td><td><span style="color:green">recommended</span>, base-4.16.4.0</td></tr> <tr><td>9.2.5</td><td><span style="color:green">recommended</span>, base-4.16.4.0</td></tr>
<tr><td>9.2.7</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.6</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.5</td><td>base-4.16.4.0</td></tr>
<tr><td>9.2.4</td><td>base-4.16.3.0</td></tr> <tr><td>9.2.4</td><td>base-4.16.3.0</td></tr>
<tr><td>9.2.3</td><td>base-4.16.2.0</td></tr> <tr><td>9.2.3</td><td>base-4.16.2.0</td></tr>
<tr><td>9.2.2</td><td>base-4.16.1.0</td></tr> <tr><td>9.2.2</td><td>base-4.16.1.0</td></tr>
@@ -183,8 +143,7 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead> <thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>3.10.1.0</td><td><span style="color:blue">latest</span></td></tr> <tr><td>3.8.1.0</td><td><span style="color:blue">latest</span></td></tr>
<tr><td>3.8.1.0</td><td></td></tr>
<tr><td>3.6.2.0</td><td><span style="color:green">recommended</span></td></tr> <tr><td>3.6.2.0</td><td><span style="color:green">recommended</span></td></tr>
<tr><td>3.6.0.0</td><td></td></tr> <tr><td>3.6.0.0</td><td></td></tr>
<tr><td>3.4.1.0</td><td></td></tr> <tr><td>3.4.1.0</td><td></td></tr>
@@ -200,14 +159,7 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>HLS Version</th><th>Tags</th></tr></thead> <thead><tr><th>HLS Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>2.2.0.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr> <tr><td>1.8.0.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
<tr><td>2.1.0.0</td><td></td></tr>
<tr><td>2.0.0.1</td><td></td></tr>
<tr><td>2.0.0.0</td><td></td></tr>
<tr><td>1.10.0.0</td><td></td></tr>
<tr><td>1.9.1.0</td><td></td></tr>
<tr><td>1.9.0.0</td><td></td></tr>
<tr><td>1.8.0.0</td><td></td></tr>
<tr><td>1.7.0.0</td><td></td></tr> <tr><td>1.7.0.0</td><td></td></tr>
<tr><td>1.6.1.0</td><td></td></tr> <tr><td>1.6.1.0</td><td></td></tr>
<tr><td>1.6.0.0</td><td></td></tr> <tr><td>1.6.0.0</td><td></td></tr>
@@ -225,9 +177,7 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
<table> <table>
<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead> <thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
<tbody> <tbody>
<tr><td>2.11.1</td><td><span style="color:blue">latest</span></td></tr> <tr><td>2.9.1</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
<tr><td>2.9.3</td><td><span style="color:green">recommended</span></td></tr>
<tr><td>2.9.1</td><td></td></tr>
<tr><td>2.7.5</td><td></td></tr> <tr><td>2.7.5</td><td></td></tr>
<tr><td>2.7.3</td><td></td></tr> <tr><td>2.7.3</td><td></td></tr>
<tr><td>2.7.1</td><td></td></tr> <tr><td>2.7.1</td><td></td></tr>
@@ -240,7 +190,7 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
This list may not be exhaustive and specifies support for bindists only. This list may not be exhaustive and specifies support for bindists only.
| Platform | Architecture | ghcup | GHC | cabal | HLS | stack | | Platform | Architecture | ghcup | GHC | cabal | HLS | stack |
| ------ | ------ | ------ | ------ | ------ | ------ | ------ | | ------ | ------ | ------ | ------ | ------ | ------ | ------ |
| Windows 7 | amd64 | ❔ | ✅ | ✅ | ✅ | ✅ | | Windows 7 | amd64 | ❔ | ✅ | ✅ | ✅ | ✅ |
| Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ | | Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
@@ -281,9 +231,8 @@ There are various issues with GHC itself.
### FreeBSD ### FreeBSD
Lacks some upstream bindists and may need compat libs (such as `misc/compat12x`). Lacks some upstream bindists and may need compat libs, since most bindists are built on FreeBSD-12.
HLS bindists are experimental. HLS bindists are experimental.
Only latest FreeBSD is generally supported.
### Linux ARMv7/AARCH64 ### Linux ARMv7/AARCH64
@@ -296,14 +245,7 @@ Lower availability of bindists. Stack and HLS binaries are experimental.
Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/) Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
and place it into your `PATH` anywhere. and place it into your `PATH` anywhere.
If you want to GPG verify the binaries, import the following keys first: If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`.
```sh
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 88B57FCF7DB53B4DB3BFA4B1588764FBE22D19C4
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys EAF2A9A722C0C96F2B431CA511AAD8CEDEE0CAEF
```
Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so: Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
@@ -365,24 +307,6 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
All set. You can run `cabal init` now in an empty directory to start a project. All set. You can run `cabal init` now in an empty directory to start a project.
## Esoteric distros
### Void Linux
Since void linux can be installed with glibc and musl, it's hard to support correctly with ghcup.
One way to make ghcup work on **Void Linux musl** is to follow the [Overriding distro detection](../guide/#overriding-distro-detection)
section and tell it to consider Alpine bindists only. E.g.:
```sh
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_MINIMAL=1 sh
source ~/.ghcup/env
ghcup config set platform-override '{ "arch": "A_64", "platform": { "contents": "Alpine", "tag": "Linux" }, "version": "3.17" }'
ghcup install cabal --set latest
ghcup install ghc --set latest
ghcup install stack --set latest
ghcup install hls --set latest
```
## Vim integration ## Vim integration
See [ghcup.vim](https://github.com/hasufell/ghcup.vim). See [ghcup.vim](https://github.com/hasufell/ghcup.vim).

View File

@@ -328,7 +328,7 @@ see the [Cabal user guide](https://cabal.readthedocs.io/en/stable/getting-starte
<a href="https://hackage.haskell.org/" class="btn btn-primary" role="button">Discover Haskell packages</a> <a href="https://hackage.haskell.org/" class="btn btn-primary" role="button">Discover Haskell packages</a>
<a href="https://hackage.haskell.org/package/base" class="btn btn-primary" role="button">The standard library</a> <a href="https://hackage.haskell.org/package/base" class="btn btn-primary" role="button">The standard library</a>
<a href="https://haskell-language-server.readthedocs.io/en/stable/installation.html" class="btn btn-primary" role="button">Editor setup with HLS</a> <a href="https://haskell-language-server.readthedocs.io/en/stable/installation.html" class="btn btn-primary" role="button">Editor setup with HLS</a>
<a href="https://play.haskell.org/" class="btn btn-primary" role="button">Online playground</a> <a href="https://play-haskell.tomsmeding.com/play" class="btn btn-primary" role="button">Online playground</a>
</div> </div>
## How to learn Haskell proper ## How to learn Haskell proper

View File

@@ -1,6 +1,6 @@
cabal-version: 2.4 cabal-version: 2.4
name: ghcup name: ghcup
version: 0.1.19.5 version: 0.1.19.2
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
@@ -25,10 +25,10 @@ extra-source-files:
cbits/dirutils.h cbits/dirutils.h
data/build_mk/cross data/build_mk/cross
data/build_mk/default data/build_mk/default
test/ghcup-test/data/dir/.keep test/data/dir/.keep
test/ghcup-test/data/file test/data/file
test/ghcup-test/golden/unix/GHCupInfo.json test/golden/unix/GHCupInfo.json
test/ghcup-test/golden/windows/GHCupInfo.json test/golden/windows/GHCupInfo.json
source-repository head source-repository head
type: git type: git
@@ -53,43 +53,6 @@ flag no-exe
default: False default: False
manual: True manual: True
common app-common-depends
build-depends:
, aeson >=1.4
, aeson-pretty ^>=0.8.8
, async ^>=2.2.3
, base >=4.12 && <5
, bytestring >=0.10 && <0.12
, cabal-install-parsers >=0.4.5
, cabal-plan ^>=0.7.2
, containers ^>=0.6
, deepseq ^>=1.4
, directory ^>=1.3.6.0
, filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.3
, mtl ^>=2.2
, optparse-applicative >=0.15.1.0 && <0.18
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, process ^>=1.6.11.0
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, tagsoup ^>=0.14
, template-haskell >=2.7 && <2.20
, temporary ^>=1.3
, text ^>=2.0
, time >=1.9.3 && <1.12
, unordered-containers ^>=0.2
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, vector ^>=0.12
, versions >=4.0.1 && <5.1
, yaml-streamly ^>=0.12.0
library library
exposed-modules: exposed-modules:
GHCup GHCup
@@ -174,7 +137,7 @@ library
, pretty-terminal ^>=0.1.0.0 , pretty-terminal ^>=0.1.0.0
, regex-posix ^>=0.96 , regex-posix ^>=0.96
, resourcet ^>=1.2.2 , resourcet ^>=1.2.2
, retry >=0.8.1.2 && <0.10 , retry ^>=0.8.1.2
, safe ^>=0.3.18 , safe ^>=0.3.18
, safe-exceptions ^>=0.1 , safe-exceptions ^>=0.1
, split ^>=0.2.3.4 , split ^>=0.2.3.4
@@ -183,7 +146,7 @@ library
, template-haskell >=2.7 && <2.20 , template-haskell >=2.7 && <2.20
, temporary ^>=1.3 , temporary ^>=1.3
, text ^>=2.0 , text ^>=2.0
, time >=1.9.3 && <1.12 , time ^>=1.9.3
, transformers ^>=0.5 , transformers ^>=0.5
, unliftio-core ^>=0.2.0.1 , unliftio-core ^>=0.2.0.1
, unordered-containers ^>=0.2.10.0 , unordered-containers ^>=0.2.10.0
@@ -236,11 +199,11 @@ library
if (flag(tui) && !os(windows)) if (flag(tui) && !os(windows))
cpp-options: -DBRICK cpp-options: -DBRICK
build-depends: vty ^>=5.39 build-depends: vty ^>=5.37
library ghcup-optparse executable ghcup
import: app-common-depends main-is: Main.hs
exposed-modules: other-modules:
GHCup.OptParse GHCup.OptParse
GHCup.OptParse.ChangeLog GHCup.OptParse.ChangeLog
GHCup.OptParse.Common GHCup.OptParse.Common
@@ -261,40 +224,6 @@ library ghcup-optparse
GHCup.OptParse.Upgrade GHCup.OptParse.Upgrade
GHCup.OptParse.Whereis GHCup.OptParse.Whereis
hs-source-dirs: lib-opt
default-language: Haskell2010
default-extensions:
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
RecordWildCards
ScopedTypeVariables
StrictData
TupleSections
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates
build-depends: ghcup
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if (flag(tui) && !os(windows))
cpp-options: -DBRICK
if os(windows)
cpp-options: -DIS_WINDOWS
else
build-depends: unix ^>=2.7
executable ghcup
import: app-common-depends
main-is: Main.hs
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
@@ -312,8 +241,41 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded -fwarn-incomplete-record-updates -threaded
build-depends: build-depends:
, aeson >=1.4
, aeson-pretty ^>=0.8.8
, async ^>=2.2.3
, base >=4.12 && <5
, bytestring >=0.10 && <0.12
, cabal-install-parsers >=0.4.5
, cabal-plan ^>=0.7.2
, containers ^>=0.6
, deepseq ^>=1.4
, directory ^>=1.3.6.0
, filepath ^>=1.4.2.1
, ghcup , ghcup
, ghcup-optparse , haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.3
, mtl ^>=2.2
, optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.18
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, process ^>=1.6.11.0
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, tagsoup ^>=0.14
, template-haskell >=2.7 && <2.20
, temporary ^>=1.3
, text ^>=2.0
, unordered-containers ^>=0.2
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, vector ^>=0.12
, versions >=4.0.1 && <5.1
, yaml-streamly ^>=0.12.0
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
@@ -325,7 +287,7 @@ executable ghcup
, brick ^>=1.5 , brick ^>=1.5
, transformers ^>=0.5 , transformers ^>=0.5
, unix ^>=2.7 , unix ^>=2.7
, vty ^>=5.39 , vty ^>=5.37
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
@@ -340,7 +302,7 @@ test-suite ghcup-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Main.hs main-is: Main.hs
build-tool-depends: hspec-discover:hspec-discover -any build-tool-depends: hspec-discover:hspec-discover -any
hs-source-dirs: test/ghcup-test hs-source-dirs: test
other-modules: other-modules:
GHCup.ArbitraryTypes GHCup.ArbitraryTypes
GHCup.Prelude.File.Posix.TraversalsSpec GHCup.Prelude.File.Posix.TraversalsSpec
@@ -375,7 +337,6 @@ test-suite ghcup-test
, quickcheck-arbitrary-adt ^>=0.3.1.0 , quickcheck-arbitrary-adt ^>=0.3.1.0
, streamly ^>=0.8.2 , streamly ^>=0.8.2
, text ^>=2.0 , text ^>=2.0
, time >=1.9.3 && <1.12
, uri-bytestring ^>=0.3.2.2 , uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1 , versions >=4.0.1 && <5.1
@@ -384,39 +345,3 @@ test-suite ghcup-test
else else
build-depends: unix ^>=2.7 build-depends: unix ^>=2.7
test-suite ghcup-optparse-test
type: exitcode-stdio-1.0
hs-source-dirs: test/optparse-test
main-is: Main.hs
other-modules:
ChangeLogTest
CompileTest
ConfigTest
GCTest
InstallTest
ListTest
OtherCommandTest
RmTest
RunTest
SetTest
UnsetTest
UpgradeTest
Utils
WhereisTest
if os(windows)
cpp-options: -DIS_WINDOWS
default-language: Haskell2010
ghc-options: -Wall
build-depends:
, base
, ghcup
, ghcup-optparse
, optparse-applicative
, tasty
, tasty-hunit
, text
, uri-bytestring
, versions

View File

@@ -5,6 +5,4 @@ cradle:
- component: "ghcup:exe:ghcup" - component: "ghcup:exe:ghcup"
path: ./app/ghcup path: ./app/ghcup
- component: "ghcup:test:ghcup-test" - component: "ghcup:test:ghcup-test"
path: ./test/ghcup-test path: ./test
- component: "ghcup:test:ghcup-optparse-test"
path: ./test/optparse-test

View File

@@ -134,24 +134,15 @@ rmTool :: ( MonadReader env m
=> ListResult => ListResult
-> Excepts '[NotInstalled, UninstallFailed] m () -> Excepts '[NotInstalled, UninstallFailed] m ()
rmTool ListResult {lVer, lTool, lCross} = do rmTool ListResult {lVer, lTool, lCross} = do
let printRmTool = logInfo $ "removing " <> T.pack (show lTool) <> " version " <> prettyVer lVer logInfo $ "removing " <> T.pack (show lTool) <> " version " <> prettyVer lVer
case lTool of case lTool of
GHC -> do GHC ->
let ghcTargetVersion = GHCTargetVersion lCross lVer let ghcTargetVersion = GHCTargetVersion lCross lVer
logInfo $ "removing " <> T.pack (show lTool) <> " version " <> tVerToText ghcTargetVersion in rmGHCVer ghcTargetVersion
rmGHCVer ghcTargetVersion HLS -> rmHLSVer lVer
HLS -> do Cabal -> liftE $ rmCabalVer lVer
printRmTool Stack -> liftE $ rmStackVer lVer
rmHLSVer lVer GHCup -> lift rmGhcup
Cabal -> do
printRmTool
liftE $ rmCabalVer lVer
Stack -> do
printRmTool
liftE $ rmStackVer lVer
GHCup -> do
printRmTool
lift rmGhcup
rmGhcupDirs :: ( MonadReader env m rmGhcupDirs :: ( MonadReader env m
@@ -312,7 +303,7 @@ upgradeGHCup mtarget force' fatal = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ logInfo "Upgrading GHCup..." lift $ logInfo "Upgrading GHCup..."
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup)) let latestVer = fst (fromJust (getLatest dls GHCup))
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
@@ -501,7 +492,7 @@ rmOldGHC :: ( MonadReader env m
=> Excepts '[NotInstalled, UninstallFailed] m () => Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let oldGHCs = toListOf (ix GHC % getTagged Old % to fst) dls let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
ghcs <- lift $ fmap rights getInstalledGHCs ghcs <- lift $ fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc

View File

@@ -38,7 +38,6 @@ import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Ord
import Data.Maybe import Data.Maybe
import Data.Versions hiding ( patch ) import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
@@ -178,7 +177,7 @@ installCabalBin :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Version => VersionRev
-> InstallDir -> InstallDir
-> Bool -- force install -> Bool -- force install
-> Excepts -> Excepts
@@ -199,7 +198,7 @@ installCabalBin :: ( MonadMask m
() ()
installCabalBin ver installDir forceInstall = do installCabalBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver installDir forceInstall installCabalBindist dlinfo (vVersion ver) installDir forceInstall
----------------- -----------------
@@ -281,6 +280,6 @@ rmCabalVer ver = do
when (Just ver == cSet) $ do when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
case headMay . sortBy (comparing Down) $ cVers of case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver Just latestver -> setCabal latestver
Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt) Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)

View File

@@ -271,37 +271,25 @@ getBase uri = do
pure f pure f
getDownloadInfo :: ( MonadReader env m getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
) )
=> Tool => Tool
-> Version -> VersionRev
-- ^ tool version -- ^ tool version
-> Excepts -> Excepts
'[NoDownload] '[NoDownload]
m m
DownloadInfo DownloadInfo
getDownloadInfo t v = getDownloadInfo' t (mkTVer v) getDownloadInfo t (VersionRev v vr) = do
(PlatformRequest a p mv) <- lift getPlatformReq
getDownloadInfo' :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> GHCTargetVersion
-- ^ tool version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo' t v = do
pfreq@(PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let distro_preview f g = let distro_preview f g =
let platformVersionSpec = let platformVersionSpec =
preview (ix t % ix v % viArch % ix a % ix (f p)) dls preview (ix t % ix v % viDownload % ix vr % viArch % ix a % ix (f p)) dls
mv' = g mv mv' = g mv
in fmap snd in fmap snd
. find . find
@@ -317,7 +305,7 @@ getDownloadInfo' t v = do
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
maybe maybe
(throwE $ NoDownload v t (Just pfreq)) (throwE NoDownload)
pure pure
(case p of (case p of
-- non-musl won't work on alpine -- non-musl won't work on alpine
@@ -645,9 +633,7 @@ downloadCached dli mfn = do
True -> downloadCached' dli mfn Nothing True -> downloadCached' dli mfn Nothing
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) mfn False
where
outputFileName = mfn <|> _dlOutput dli
downloadCached' :: ( MonadReader env m downloadCached' :: ( MonadReader env m
@@ -666,7 +652,7 @@ downloadCached' :: ( MonadReader env m
downloadCached' dli mfn mDestDir = do downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) outputFileName let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = destDir </> fn let cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
@@ -674,9 +660,7 @@ downloadCached' dli mfn mDestDir = do
forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
liftE $ checkDigest (view dlHash dli) cachfile liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile pure cachfile
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir outputFileName False | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir mfn False
where
outputFileName = mfn <|> _dlOutput dli

View File

@@ -38,7 +38,6 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E import qualified Data.Text.Encoding.Error as E
import Data.Data (Proxy(..)) import Data.Data (Proxy(..))
import Data.Time (Day)
@@ -60,7 +59,6 @@ allHFError = unlines allErrors
, let proxy = Proxy :: Proxy CopyError in format proxy , let proxy = Proxy :: Proxy CopyError in format proxy
, let proxy = Proxy :: Proxy MergeFileTreeError in format proxy , let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
, let proxy = Proxy :: Proxy TagNotFound in format proxy , let proxy = Proxy :: Proxy TagNotFound in format proxy
, let proxy = Proxy :: Proxy DayNotFound in format proxy
, let proxy = Proxy :: Proxy NextVerNotFound in format proxy , let proxy = Proxy :: Proxy NextVerNotFound in format proxy
, let proxy = Proxy :: Proxy AlreadyInstalled in format proxy , let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
, let proxy = Proxy :: Proxy DirNotEmpty in format proxy , let proxy = Proxy :: Proxy DirNotEmpty in format proxy
@@ -206,26 +204,12 @@ instance HFErrorProject NoCompatiblePlatform where
eDesc _ = "No compatible platform could be found" eDesc _ = "No compatible platform could be found"
-- | Unable to find a download for the requested version/distro. -- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest) data NoDownload = NoDownload
| NoDownload' GlobalTool
deriving Show deriving Show
instance Pretty NoDownload where instance Pretty NoDownload where
pPrint (NoDownload tver@(GHCTargetVersion mtarget vv) tool mpfreq) pPrint NoDownload =
| (Just target) <- mtarget text (eDesc (Proxy :: Proxy NoDownload))
, target `elem` (T.pack . prettyShow <$> enumFromTo (minBound :: Tool) (maxBound :: Tool))
= text $ "Unable to find a download for "
<> show tool
<> " version '"
<> T.unpack (tVerToText tver)
<> maybe "'\n" (\pfreq -> "' on detected platform " <> pfReqToString pfreq <> "\n") mpfreq
<> "Perhaps you meant: 'ghcup <command> "
<> T.unpack target
<> " "
<> T.unpack (prettyVer vv)
<> "'"
| otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver)
pPrint (NoDownload' globalTool) = text $ "Unable to find a download for " <> prettyShow globalTool
instance HFErrorProject NoDownload where instance HFErrorProject NoDownload where
eBase _ = 10 eBase _ = 10
@@ -327,21 +311,6 @@ instance HFErrorProject TagNotFound where
eBase _ = 90 eBase _ = 90
eDesc _ = "Unable to find a tag of a tool" eDesc _ = "Unable to find a tag of a tool"
-- | Unable to find a release day of a tool
data DayNotFound = DayNotFound Day Tool (Maybe Day)
deriving Show
instance Pretty DayNotFound where
pPrint (DayNotFound day tool Nothing) =
text "Unable to find release date" <+> text (show day) <+> text "of tool" <+> pPrint tool
pPrint (DayNotFound day tool (Just alternateDay)) =
text "Unable to find release date" <+> text (show day) <+> text "of tool" <+> pPrint tool <+>
text "but found an alternative date" <+> text (show alternateDay)
instance HFErrorProject DayNotFound where
eBase _ = 95
eDesc _ = "Unable to find a release date of a tool"
-- | Unable to find the next version of a tool (the one after the currently -- | Unable to find the next version of a tool (the one after the currently
-- set one). -- set one).
data NextVerNotFound = NextVerNotFound Tool data NextVerNotFound = NextVerNotFound Tool

View File

@@ -78,12 +78,12 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Data.Map.Strict as M
data GHCVer = SourceDist Version data GHCVer v = SourceDist v
| GitDist GitBranch | GitDist GitBranch
| RemoteDist URI | RemoteDist URI
deriving (Eq, Show)
@@ -106,7 +106,7 @@ testGHCVer :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> GHCTargetVersion => VersionRev
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@@ -121,12 +121,12 @@ testGHCVer :: ( MonadFail m
] ]
m m
() ()
testGHCVer ver addMakeArgs = do testGHCVer (VersionRev ver vr) addMakeArgs = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlInfo <- dlInfo <-
preview (ix GHC % ix ver % viTestDL % _Just) dls preview (ix GHC % ix ver % viDownload % to M.toAscList % maybe _last ix vr % to snd % viTestDL % _Just) dls
?? NoDownload ver GHC Nothing ?? NoDownload
liftE $ testGHCBindist dlInfo ver addMakeArgs liftE $ testGHCBindist dlInfo ver addMakeArgs
@@ -146,7 +146,7 @@ testGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo => DownloadInfo
-> GHCTargetVersion -> Version
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@@ -183,7 +183,7 @@ testPackedGHC :: ( MonadMask m
) )
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> GHCTargetVersion -- ^ The GHC version -> Version -- ^ The GHC version
-> [T.Text] -- ^ additional make args -> [T.Text] -- ^ additional make args
-> Excepts -> Excepts
'[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m () '[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
@@ -209,21 +209,19 @@ testUnpackedGHC :: ( MonadReader env m
, MonadIO m , MonadIO m
) )
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides) => GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides)
-> GHCTargetVersion -- ^ The GHC version -> Version -- ^ The GHC version
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
testUnpackedGHC path tver addMakeArgs = do testUnpackedGHC path ver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!" lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!"
ghcDir <- lift $ ghcupGHCDir tver ghcDir <- lift $ ghcupGHCDir (mkTVer ver)
let ghcBinDir = fromGHCupPath ghcDir </> "bin" let ghcBinDir = fromGHCupPath ghcDir </> "bin"
env <- liftIO $ addToPath ghcBinDir False env <- liftIO $ addToPath ghcBinDir False
lEM $ make' (fmap T.unpack addMakeArgs) lEM $ make' (fmap T.unpack addMakeArgs)
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-test" "ghc-test"
(Just $ ("STAGE1_GHC", maybe "" (T.unpack . (<> "-")) (_tvTarget tver) (Just $ ("STAGE1_GHC", "ghc-" <> T.unpack (prettyVer ver)) : env)
<> "ghc-"
<> T.unpack (prettyVer $ _tvVersion tver)) : env)
pure () pure ()
@@ -246,7 +244,7 @@ fetchGHCSrc :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> GHCTargetVersion => VersionRev
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@@ -257,11 +255,11 @@ fetchGHCSrc :: ( MonadFail m
] ]
m m
FilePath FilePath
fetchGHCSrc v mfp = do fetchGHCSrc (VersionRev v vr) mfp = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlInfo <- dlInfo <-
preview (ix GHC % ix v % viSourceDL % _Just) dls preview (ix GHC % ix v % viDownload % to M.toAscList % maybe _last ix vr % to snd % viSourceDL % _Just) dls
?? NoDownload v GHC Nothing ?? NoDownload
liftE $ downloadCached' dlInfo Nothing mfp liftE $ downloadCached' dlInfo Nothing mfp
@@ -286,7 +284,7 @@ installGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo -- ^ where/how to download => DownloadInfo -- ^ where/how to download
-> GHCTargetVersion -- ^ the version to install -> Version -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@@ -309,8 +307,10 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
regularGHCInstalled <- lift $ ghcInstalled tver regularGHCInstalled <- lift $ ghcInstalled tver
@@ -318,7 +318,7 @@ installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do
| not forceInstall | not forceInstall
, regularGHCInstalled , regularGHCInstalled
, GHCupInternal <- installDir -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC (_tvVersion tver) throwE $ AlreadyInstalled GHC ver
| forceInstall | forceInstall
, regularGHCInstalled , regularGHCInstalled
@@ -337,12 +337,12 @@ installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do
case installDir of case installDir of
IsolateDir isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) tver forceInstall addConfArgs liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall addConfArgs
GHCupInternal -> do -- regular install GHCupInternal -> do -- regular install
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) tver forceInstall addConfArgs liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall addConfArgs
-- make symlinks & stuff when regular install, -- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
@@ -376,7 +376,7 @@ installPackedGHC :: ( MonadMask m
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> InstallDirResolved -> InstallDirResolved
-> GHCTargetVersion -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts -> Excepts
@@ -424,22 +424,26 @@ installUnpackedGHC :: ( MonadReader env m
) )
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> InstallDirResolved -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> GHCTargetVersion -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError, MergeFileTreeError] m () -> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC path inst tver forceInstall addConfArgs installUnpackedGHC path inst ver forceInstall addConfArgs
| isWindows = do | isWindows = do
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need -- Windows bindists are relocatable and don't need
-- to run configure. -- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg. -- We also must make sure to preserve mtime to not confuse ghc-pkg.
liftE $ mergeGHCFileTree path inst tver forceInstall liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do
mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest
liftIO $ moveFilePortable source dest
forM_ mtime $ liftIO . setModificationTime dest
| otherwise = do | otherwise = do
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
let ldOverride let ldOverride
| _tvVersion tver >= [vver|8.2.2|] | ver >= [vver|8.2.2|]
, _rPlatform `elem` [Linux Alpine, Darwin] , _rPlatform `elem` [Linux Alpine, Darwin]
= ["--disable-ld-override"] = ["--disable-ld-override"]
| otherwise | otherwise
@@ -448,7 +452,7 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> fromInstallDir inst) ("./configure" : ("--prefix=" <> fromInstallDir inst)
: (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs)) : (ldOverride <> (T.unpack <$> addConfArgs))
) )
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-configure" "ghc-configure"
@@ -456,44 +460,17 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
tmpInstallDest <- lift withGHCupTmpDir tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
liftE $ mergeGHCFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst tver forceInstall liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
pure ()
mergeGHCFileTree :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, MonadResource m
, MonadFail m
)
=> GHCupPath -- ^ Path to the root of the tree
-> InstallDirResolved -- ^ Path to install to
-> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts '[MergeFileTreeError] m ()
mergeGHCFileTree root inst tver forceInstall
| isWindows = do
liftE $ mergeFileTree root inst GHC tver $ \source dest -> do
mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest
liftIO $ moveFilePortable source dest
forM_ mtime $ liftIO . setModificationTime dest
| otherwise = do
liftE $ mergeFileTree root
inst inst
GHC GHC
tver (mkTVer ver)
(\f t -> liftIO $ do (\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall) install f t (not forceInstall)
forM_ mtime $ setModificationTime t) forM_ mtime $ setModificationTime t)
pure ()
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
-- following symlinks in @~\/.ghcup\/bin@: -- following symlinks in @~\/.ghcup\/bin@:
@@ -513,7 +490,7 @@ installGHCBin :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> GHCTargetVersion -- ^ the version to install => Version -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ force install -> Bool -- ^ force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@@ -536,9 +513,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin tver installDir forceInstall addConfArgs = do installGHCBin ver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo' GHC tver dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs
@@ -732,7 +709,7 @@ rmGHCVer ver = do
Just files -> do Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir </> dropDrive f)) forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir </> dropDrive f))
hideError UnsatisfiedConstraints $ removeEmptyDirsRecursive dir removeEmptyDirsRecursive dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
f <- recordedInstallationFile GHC ver f <- recordedInstallationFile GHC ver
lift $ recycleFile f lift $ recycleFile f
@@ -779,8 +756,7 @@ compileGHC :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> GHCVer => GHCVer GHCTargetVersion
-> Maybe Text -- ^ cross target
-> Maybe Version -- ^ overwrite version -> Maybe Version -- ^ overwrite version
-> Either Version FilePath -- ^ version to bootstrap with -> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs -> Maybe Int -- ^ jobs
@@ -788,7 +764,7 @@ compileGHC :: ( MonadMask m
-> Maybe (Either FilePath [URI]) -- ^ patches -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Maybe BuildSystem -> Bool
-> InstallDir -> InstallDir
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@@ -817,21 +793,20 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
= do = do
pfreq@PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
SourceDist ver -> do SourceDist tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball -- download source tarball
let tver = mkTVer ver
dlInfo <- dlInfo <-
preview (ix GHC % ix tver % viSourceDL % _Just) dls preview (ix GHC % ix (tver ^. tvVersion) % viDownload % _last % viSourceDL % _Just) dls
?? NoDownload tver GHC (Just pfreq) ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
@@ -844,7 +819,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
liftE $ applyAnyPatch patches (fromGHCupPath workdir) liftE $ applyAnyPatch patches (fromGHCupPath workdir)
pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver)) pure (workdir, tmpUnpack, Just tver)
RemoteDist uri -> do RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri) lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
@@ -868,7 +843,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
let workdir = appendGHCupPath tmpUnpack (takeDirectory bf) let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver) pure (workdir, tmpUnpack, mkTVer <$> tver)
-- clone from git -- clone from git
GitDist GitBranch{..} -> do GitDist GitBranch{..} -> do
@@ -925,12 +900,12 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
pure tver pure tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver) pure (tmpUnpack, tmpUnpack, mkTVer <$> tver)
-- the version that's installed may differ from the -- the version that's installed may differ from the
-- compiled version, so the user can overwrite it -- compiled version, so the user can overwrite it
installVer <- if | Just ov' <- ov -> pure (GHCTargetVersion crossTarget ov') installVer <- if | Just ov' <- ov -> pure (mkTVer ov')
| Just tver' <- tver -> pure tver' | Just tver' <- tver -> pure tver'
| otherwise -> fail "No GHC version given and couldn't detect version. Giving up..." | otherwise -> fail "Newer GHCs don't support discovering the version in git. Complain to GHC devs: https://gitlab.haskell.org/ghc/ghc/-/issues/22322"
alreadyInstalled <- lift $ ghcInstalled installVer alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
@@ -949,31 +924,16 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
IsolateDir isoDir -> pure $ IsolateDirResolved isoDir IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
mBindist <- liftE $ runBuildAction (mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack tmpUnpack
(do (do
-- prefer 'tver', because the real version carries out compatibility checks b <- if hadrian
-- we don't want the user to do funny things with it -- prefer 'tver', because the real version carries out compatibility checks
let doHadrian = compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir -- we don't want the user to do funny things with it
doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir then compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
case buildSystem of else compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
Just Hadrian -> do bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
lift $ logInfo "Requested to use Hadrian" pure (b, bmk)
liftE doHadrian
Just Make -> do
lift $ logInfo "Requested to use Make"
doMake
Nothing -> do
supportsHadrian <- liftE $ catchE @HadrianNotFound @'[HadrianNotFound] @'[] (\_ -> return False)
$ fmap (const True)
$ findHadrianFile (fromGHCupPath workdir)
if supportsHadrian
then do
lift $ logInfo "Detected Hadrian"
liftE doHadrian
else do
lift $ logInfo "Detected Make"
doMake
) )
case installDir of case installDir of
@@ -989,10 +949,12 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
liftE $ installPackedGHC bindist liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*") (Just $ RegexDir "ghc-.*")
ghcdir ghcdir
installVer (installVer ^. tvVersion)
False -- not a force install, since we already overwrite when compiling. False -- not a force install, since we already overwrite when compiling.
[] []
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
case installDir of case installDir of
-- set and make symlinks for regular (non-isolated) installs -- set and make symlinks for regular (non-isolated) installs
GHCupInternal -> do GHCupInternal -> do
@@ -1015,29 +977,20 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
=> GHCupPath => GHCupPath
-> Excepts '[ProcessError, ParseError] m Version -> Excepts '[ProcessError, ParseError] m Version
getGHCVer tmpUnpack = do getGHCVer tmpUnpack = do
lEM $ execLogged "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" Nothing lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ configureWithGhcBoot Nothing [] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
let versionFile = fromGHCupPath tmpUnpack </> "VERSION" CapturedProcess {..} <- lift $ makeOut
hasVersionFile <- liftIO $ doesFileExist versionFile ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
if hasVersionFile case _exitCode of
then do ExitSuccess -> either (throwE . ParseError . show) pure . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
lift $ logDebug "Detected VERSION file, trying to extract" ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
contents <- liftIO $ readFile versionFile
either (throwE . ParseError . show) pure . MP.parse version' "" . T.pack . stripNewlineEnd $ contents
else do
lift $ logDebug "Didn't detect VERSION file, trying to extract via legacy 'make'"
CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of
ExitSuccess -> either (throwE . ParseError . show) pure . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
defaultConf = defaultConf =
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case crossTarget of in case targetGhc of
Just _ -> cross_mk SourceDist (GHCTargetVersion (Just _) _) -> cross_mk
_ -> default_mk _ -> default_mk
compileHadrianBindist :: ( MonadReader env m compileHadrianBindist :: ( MonadReader env m
, HasDirs env , HasDirs env
@@ -1063,17 +1016,18 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
compileHadrianBindist tver workdir ghcdir = do compileHadrianBindist tver workdir ghcdir = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"
liftE $ configureBindist tver workdir ghcdir liftE $ configureBindist tver workdir ghcdir
lift $ logInfo "Building (this may take a while)..." lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execLogged hadrian_build lEM $ execWithGhcEnv hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs ( maybe [] (\j -> ["-j" <> show j] ) jobs
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
++ ["binary-dist"] ++ ["binary-dist"]
) )
(Just workdir) "ghc-make" (Just workdir) "ghc-make"
Nothing
[tar] <- liftIO $ findFiles [tar] <- liftIO $ findFiles
(workdir </> "_build" </> "bindist") (workdir </> "_build" </> "bindist")
(makeRegexOpts compExtended (makeRegexOpts compExtended
@@ -1106,9 +1060,6 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadMask m
, MonadUnliftIO m
, MonadResource m
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -> FilePath
@@ -1120,7 +1071,6 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
, PatchFailed , PatchFailed
, ProcessError , ProcessError
, NotFoundInPATH , NotFoundInPATH
, MergeFileTreeError
, CopyError] , CopyError]
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
@@ -1142,9 +1092,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
if | isCross tver -> do if | isCross tver -> do
lift $ logInfo "Installing cross toolchain..." lift $ logInfo "Installing cross toolchain..."
tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["install"] (Just workdir)
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just workdir)
liftE $ mergeGHCFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir ghcdir)) ghcdir tver True
pure Nothing pure Nothing
| otherwise -> do | otherwise -> do
lift $ logInfo "Creating bindist..." lift $ logInfo "Creating bindist..."
@@ -1217,8 +1165,8 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
let lines' = fmap T.strip . T.lines $ decUTF8Safe c let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-- for cross, we need Stage1Only -- for cross, we need Stage1Only
case crossTarget of case targetGhc of
Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig (InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
) )
@@ -1262,50 +1210,64 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
() ()
configureBindist tver workdir (fromInstallDir -> ghcdir) = do configureBindist tver workdir (fromInstallDir -> ghcdir) = do
lift $ logInfo [s|configuring build|] lift $ logInfo [s|configuring build|]
lEM $ configureWithGhcBoot (Just tver)
(maybe mempty if | _tvVersion tver >= [vver|8.8.0|] -> do
(\x -> ["--target=" <> T.unpack x]) lEM $ execWithGhcEnv
(_tvTarget tver) "sh"
++ ["--prefix=" <> ghcdir] ("./configure" : maybe mempty
++ (if isWindows then ["--enable-tarballs-autodownload"] else []) (\x -> ["--target=" <> T.unpack x])
++ fmap T.unpack aargs (_tvTarget tver)
) ++ ["--prefix=" <> ghcdir]
(Just workdir) ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
"ghc-conf" ++ fmap T.unpack aargs
)
(Just workdir)
"ghc-conf"
| otherwise -> do
lEM $ execLogged
"sh"
( [ "./configure", "--with-ghc=" <> either id id bghc
]
++ maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)
"ghc-conf"
Nothing
pure () pure ()
configureWithGhcBoot :: ( MonadReader env m execWithGhcEnv :: ( MonadReader env m
, HasSettings env , HasSettings env
, HasDirs env , HasDirs env
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadThrow m) , MonadThrow m)
=> Maybe GHCTargetVersion => FilePath -- ^ thing to execute
-> [String] -- ^ args for configure -> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode) -> FilePath -- ^ log filename (opened in append mode)
-> m (Either ProcessError ()) -> m (Either ProcessError ())
configureWithGhcBoot mtver args dir logf = do execWithGhcEnv fp args dir logf = do
let execNew = execLogged env <- ghcEnv
"sh" execLogged fp args dir logf (Just env)
("./configure" : ("GHC=" <> bghc) : args)
dir
logf
Nothing
execOld = execLogged
"sh"
("./configure" : ("--with-ghc=" <> bghc) : args)
dir
logf
Nothing
if | Just tver <- mtver
, _tvVersion tver >= [vver|8.8.0|] -> execNew
| Nothing <- mtver -> execNew -- need some default for git checkouts where we don't know yet
| otherwise -> execOld
bghc = case bstrap of bghc = case bstrap of
Right g -> g Right g -> Right g
Left bver -> "ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)]
ghcEnv = do
cEnv <- liftIO getEnvironment
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- liftIO getSearchPath
throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)
pure (("GHC", bghcPath) : cEnv)

View File

@@ -43,7 +43,6 @@ import Control.Monad.Trans.Resource
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Ord
import Data.Maybe import Data.Maybe
import Data.String ( fromString ) import Data.String ( fromString )
import Data.Text ( Text ) import Data.Text ( Text )
@@ -75,7 +74,6 @@ data HLSVer = SourceDist Version
| GitDist GitBranch | GitDist GitBranch
| HackageDist Version | HackageDist Version
| RemoteDist URI | RemoteDist URI
deriving (Eq, Show)
@@ -355,7 +353,7 @@ compileHLS :: ( MonadMask m
, NotInstalled , NotInstalled
] m Version ] m Version
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
pfreq@PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
@@ -370,8 +368,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls preview (ix HLS % ix tver % viDownload % _last % viSourceDL % _Just) dls
?? NoDownload (mkTVer tver) HLS (Just pfreq) ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
@@ -706,7 +704,7 @@ rmHLSVer ver = do
when (Just ver == isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- set latest hls -- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . sortBy (comparing Down) $ hlsVers of case headMay . reverse . sort $ hlsVers of
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
Nothing -> pure () Nothing -> pure ()

View File

@@ -36,7 +36,6 @@ import Data.Either
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Time.Calendar ( Day )
import Data.Versions hiding ( patch ) import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
@@ -62,10 +61,10 @@ import qualified Data.Text as T
-- | Filter data type for 'listVersions'. -- | Filter data type for 'listVersions'.
data ListCriteria = ListInstalled Bool data ListCriteria = ListInstalled
| ListSet Bool | ListSet
| ListAvailable Bool | ListAvailable
deriving (Eq, Show) deriving Show
-- | A list result describes a single tool version -- | A list result describes a single tool version
-- and various of its properties. -- and various of its properties.
@@ -76,16 +75,16 @@ data ListResult = ListResult
, lTag :: [Tag] , lTag :: [Tag]
, lInstalled :: Bool , lInstalled :: Bool
, lSet :: Bool -- ^ currently active version , lSet :: Bool -- ^ currently active version
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info , lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool , hlsPowered :: Bool
, lReleaseDay :: Maybe Day
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-- | Extract all available tool versions and their tags. -- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map GHCTargetVersion VersionInfo availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
availableToolVersions av tool = view availableToolVersions av tool = view
(at tool % non Map.empty) (at tool % non Map.empty)
av av
@@ -94,22 +93,19 @@ availableToolVersions av tool = view
-- | List all versions from the download info, as well as stray -- | List all versions from the download info, as well as stray
-- versions. -- versions.
listVersions :: ( MonadCatch m listVersions :: ( MonadCatch m
, HasLog env , HasLog env
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
) )
=> Maybe Tool => Maybe Tool
-> [ListCriteria] -> Maybe ListCriteria
-> Bool -> m [ListResult]
-> Bool listVersions lt' criteria = do
-> (Maybe Day, Maybe Day)
-> m [ListResult]
listVersions lt' criteria hideOld showNightly days = do
-- some annoying work to avoid too much repeated IO -- some annoying work to avoid too much repeated IO
cSet <- cabalSet cSet <- cabalSet
cabals <- getInstalledCabals cabals <- getInstalledCabals
@@ -133,13 +129,13 @@ listVersions lt' criteria hideOld showNightly days = do
slr <- strayGHCs avTools slr <- strayGHCs avTools
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Cabal -> do Cabal -> do
slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals slr <- strayCabals avTools cSet cabals
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
HLS -> do HLS -> do
slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses slr <- strayHLS avTools hlsSet' hlses
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Stack -> do Stack -> do
slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks slr <- strayStacks avTools sSet stacks
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
GHCup -> do GHCup -> do
let cg = maybeToList $ currentGHCup avTools let cg = maybeToList $ currentGHCup avTools
@@ -158,28 +154,42 @@ listVersions lt' criteria hideOld showNightly days = do
, HasLog env , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map GHCTargetVersion VersionInfo => Map.Map Version VersionInfo
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
ghcs <- getInstalledGHCs ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ .. } -> do Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
case Map.lookup tver avTools of case Map.lookup _tvVersion avTools of
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
, lCross = _tvTarget , lCross = Nothing
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup tver avTools) , lStray = isNothing (Map.lookup _tvVersion avTools)
, lNoBindist = False , lNoBindist = False
, lReleaseDay = Nothing
, .. , ..
} }
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = _tvTarget
, lTag = []
, lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist
, lNoBindist = False
, ..
}
Left e -> do Left e -> do
logWarn logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
@@ -211,8 +221,8 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing
, .. , ..
} }
Left e -> do Left e -> do
@@ -245,8 +255,8 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing
, .. , ..
} }
Left e -> do Left e -> do
@@ -280,8 +290,8 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing
, .. , ..
} }
Left e -> do Left e -> do
@@ -289,24 +299,24 @@ listVersions lt' criteria hideOld showNightly days = do
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
currentGHCup av = currentGHCup av =
let currentVer = mkTVer $ fromJust $ pvpToVersion ghcUpVer "" let currentVer = fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in if | Map.member currentVer av -> Nothing in if | Map.member currentVer av -> Nothing
| otherwise -> Just $ ListResult { lVer = _tvVersion currentVer | otherwise -> Just $ ListResult { lVer = currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer , lTag = maybe (if isOld then [Old] else []) (view viTags) listVer
, lCross = Nothing , lCross = Nothing
, lTool = GHCup , lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer , lStray = isNothing listVer
, lSet = True , lSet = True
, lInstalled = True , lInstalled = True
, lNoBindist = False , lNoBindist = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing
} }
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
@@ -325,41 +335,43 @@ listVersions lt' criteria hideOld showNightly days = do
-> [Either FilePath Version] -> [Either FilePath Version]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> (GHCTargetVersion, VersionInfo) -> (Version, VersionInfo)
-> m ListResult -> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, vi) = do
let v = _tvVersion tver let tags = view viTags vi
case t of case t of
GHC -> do GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) fromSrc <- ghcSrcInstalled tver
pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just v let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = tags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay
, .. , ..
} }
GHCup -> do GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet let lInstalled = lSet
pure ListResult { lVer = v pure ListResult { lVer = v
, lTag = _viTags , lTag = tags
, lCross = Nothing , lCross = Nothing
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, lNoBindist = False , lNoBindist = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay
, .. , ..
} }
HLS -> do HLS -> do
@@ -368,11 +380,11 @@ listVersions lt' criteria hideOld showNightly days = do
let lInstalled = elem v $ rights hlses let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = tags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay
, .. , ..
} }
Stack -> do Stack -> do
@@ -381,42 +393,19 @@ listVersions lt' criteria hideOld showNightly days = do
let lInstalled = elem v $ rights stacks let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = tags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay
, .. , ..
} }
filter' :: [ListResult] -> [ListResult] filter' :: [ListResult] -> [ListResult]
filter' = filterNightly . filterOld . filter (\lr -> foldr (\a b -> fromCriteria a lr && b) True criteria) . filterDays filter' lr = case criteria of
Nothing -> lr
filterDays :: [ListResult] -> [ListResult] Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
filterDays lrs = case days of Just ListSet -> filter (\ListResult {..} -> lSet) lr
(Nothing, Nothing) -> lrs Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr
(Just from, Just to') -> filter (\ListResult{..} -> maybe False (\d -> d >= from && d <= to') lReleaseDay) lrs
(Nothing, Just to') -> filter (\ListResult{..} -> maybe False (<= to') lReleaseDay) lrs
(Just from, Nothing) -> filter (\ListResult{..} -> maybe False (>= from) lReleaseDay) lrs
fromCriteria :: ListCriteria -> ListResult -> Bool
fromCriteria lc ListResult{..} = case lc of
ListInstalled b -> f b lInstalled
ListSet b -> f b lSet
ListAvailable b -> f b $ not lNoBindist
where
f b
| b = id
| otherwise = not
filterOld :: [ListResult] -> [ListResult]
filterOld lr
| hideOld = filter (\ListResult {..} -> lInstalled || Old `notElem` lTag) lr
| otherwise = lr
filterNightly :: [ListResult] -> [ListResult]
filterNightly lr
| showNightly = lr
| otherwise = filter (\ListResult {..} -> lInstalled || (Nightly `notElem` lTag && LatestNightly `notElem` lTag)) lr

View File

@@ -77,14 +77,8 @@ runBothE' a1 a2 = do
(_ , VLeft e ) -> throwSomeE e (_ , VLeft e ) -> throwSomeE e
(VRight _, VRight _) -> pure () (VRight _, VRight _) -> pure ()
-- "throwSomeE" function has been upstreamed in haskus-utils-variant-3.3
-- So, only conditionally include this shim if
-- haskus-utils-variant version is < 3.3
#if MIN_VERSION_haskus_utils_variant(3,3,0)
#else
-- | Throw some exception -- | Throw some exception
throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
{-# INLINABLE throwSomeE #-} {-# INLINABLE throwSomeE #-}
throwSomeE = Excepts . pure . VLeft . liftVariant throwSomeE = Excepts . pure . VLeft . liftVariant
#endif

View File

@@ -28,6 +28,8 @@ import System.FilePath
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import Data.Char (digitToInt)
import Data.Data (Proxy(..))
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
@@ -86,7 +88,33 @@ ghcTargetVerP =
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-") <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> ((\ _ x -> x) Nothing <$> mempty) <|> ((\ _ x -> x) Nothing <$> mempty)
) )
<*> (version' <* MP.eof) <*> version'
where
verP' :: MP.Parsec Void Text Text
verP' = do
v <- version'
let startsWithDigists =
and
. take 3
. concatMap
(map
(\case
(Digits _) -> True
(Str _) -> False
) . NE.toList)
. NE.toList
$ _vChunks v
if startsWithDigists && isNothing (_vEpoch v)
then pure $ prettyVer v
else fail "Oh"
ghcTargetVerRevP :: MP.Parsec Void Text GHCTargetVersionRev
ghcTargetVerRevP =
(\x y -> GHCTargetVersionRev x y)
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> ((\ _ x -> x) Nothing <$> mempty)
)
<*> versionRevP
where where
verP' :: MP.Parsec Void Text Text verP' :: MP.Parsec Void Text Text
verP' = do verP' = do
@@ -122,3 +150,44 @@ verP suffix = do
pathSep :: MP.Parsec Void Text Char pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators pathSep = MP.oneOf pathSeparators
versionRevP :: MP.Parsec Void Text VersionRev
versionRevP = MP.label "versionRev" $
MP.try (parseUntil (MP.try (MP.chunk "-r")) >>= versionWithRev) <|> ((`VersionRev` 0) <$> version')
where
versionWithRev ver = do
rest <- MP.getInput
MP.setInput ver
v <- version'
MP.setInput rest
_ <- MP.chunk "-r"
rev <- parseInt
pure $ VersionRev v rev
digit = MP.oneOf ['0'..'9'] MP.<?> "digit"
parseInt :: MP.Parsec Void Text Int
parseInt = MP.label "parseInt" $ do
i <- MP.tokensToChunk (Proxy :: Proxy Text) <$> some digit
pure $ numberValue 10 $ T.unpack i
numberValue :: Int -> String -> Int
numberValue base = foldl (\ x -> ((fromIntegral base * x) +) . fromIntegral . digitToInt) 0
userVersionRevP :: MP.Parsec Void Text UserVersionRev
userVersionRevP = MP.label "userVersionRev" $
((\(VersionRev v r) -> UserVersionRev v (Just r)) <$> MP.try versionRevP) <|> ((`UserVersionRev` Nothing) <$> version')
-- | Read a @VersionRev@ from a String.
--
-- - 3.3.2 -> VersionRev { vVersion = 3.3.3, vRev = 0 }
-- - 2.3.4-r3 -> VersionRev { vVersion = 2.3.4, vRev = 3 }
versionRev :: Text -> Either (MP.ParseErrorBundle Text Void) VersionRev
versionRev = MP.parse versionRevP ""
-- | Read a @UserVersionRev@ from a String.
--
-- - 3.3.2 -> UserVersionRev { vVersion = 3.3.3, vRev = Nothing }
-- - 2.3.4-r3 -> UserVersionRev { vVersion = 2.3.4, vRev = Just 3 }
userVersionRev :: Text -> Either (MP.ParseErrorBundle Text Void) UserVersionRev
userVersionRev = MP.parse userVersionRevP ""

View File

@@ -38,7 +38,6 @@ import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Ord
import Data.Maybe import Data.Maybe
import Data.Versions hiding ( patch ) import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
@@ -280,6 +279,6 @@ rmStackVer ver = do
when (Just ver == sSet) $ do when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks sVers <- lift $ fmap rights getInstalledStacks
case headMay . sortBy (comparing Down) $ sVers of case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver Just latestver -> setStack latestver
Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt) Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)

View File

@@ -31,7 +31,6 @@ import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
import Control.DeepSeq ( NFData, rnf ) import Control.DeepSeq ( NFData, rnf )
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Time.Calendar ( Day )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import GHC.IO.Exception ( ExitCode ) import GHC.IO.Exception ( ExitCode )
@@ -45,8 +44,9 @@ import Graphics.Vty ( Key(..) )
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M
import Data.Foldable (foldMap)
#if !defined(BRICK) #if !defined(BRICK)
data Key = KEsc | KChar Char | KBS | KEnter data Key = KEsc | KChar Char | KBS | KEnter
@@ -105,7 +105,7 @@ instance NFData Requirements
-- | Description of all binary and source downloads. This is a tree -- | Description of all binary and source downloads. This is a tree
-- of nested maps. -- of nested maps.
type GHCupDownloads = Map Tool ToolVersionSpec type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map GHCTargetVersion VersionInfo type ToolVersionSpec = Map Version VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
@@ -133,15 +133,24 @@ data GlobalTool = ShimGen
instance NFData GlobalTool instance NFData GlobalTool
instance Pretty GlobalTool where
pPrint ShimGen = text "shimgen"
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
-- source download and per-architecture downloads. -- source download and per-architecture downloads.
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ _viTags :: [Tag] -- ^ version specific tag { _viTags :: [Tag] -- ^ version specific tag
, _viReleaseDay :: Maybe Day , _viChangeLog :: Maybe URI
, _viDownload :: Map Int VersionDownload
-- informative messages
, _viPostInstall :: Maybe Text
, _viPostRemove :: Maybe Text
, _viPreCompile :: Maybe Text
}
deriving (Eq, GHC.Generic, Show)
instance NFData VersionInfo
data VersionInfoLegacy = VersionInfoLegacy
{ _viTags :: [Tag] -- ^ version specific tag
, _viChangeLog :: Maybe URI , _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viTestDL :: Maybe DownloadInfo -- ^ test tarball , _viTestDL :: Maybe DownloadInfo -- ^ test tarball
@@ -153,21 +162,55 @@ data VersionInfo = VersionInfo
} }
deriving (Eq, GHC.Generic, Show) deriving (Eq, GHC.Generic, Show)
instance NFData VersionInfo data VersionDownload = VersionDownload
{ _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viTestDL :: Maybe DownloadInfo -- ^ test tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, GHC.Generic, Show)
instance NFData VersionDownload
fromVersionInfoLegacy :: VersionInfoLegacy -> VersionInfo
fromVersionInfoLegacy VersionInfoLegacy{..} =
VersionInfo {_viDownload = M.singleton 0 $ VersionDownload { _viSourceDL = _viSourceDL
, _viTestDL = _viTestDL
, _viArch = _viArch
}
, ..}
-- | A version with a revision, denoting bindist 'versions' that are purely distribution specific.
--
-- The revision starts at 0.
data VersionRev = VersionRev { vVersion :: Version, vRev :: Int }
deriving (Ord, Eq, GHC.Generic, Show)
showVersionRev :: VersionRev -> Text
showVersionRev (VersionRev v 0) = prettyVer v
showVersionRev (VersionRev v r) = prettyVer v <> "-r" <> T.pack (show r)
-- | Similar to @VersionRev@, except that revision is optional. The absence of a revision has
-- a particular meaning:
--
-- * for install/prefetch: we want the latest available revision
-- * for compile: it depends
-- * for rm/set/unset/whereis/changelog: we want the revision that is installed (there can be only one)
--
-- Translating @UserVersionRev@ to @VersionRev@ requires context of the GHCup metadata,
-- installed versions and the to be executed command.
data UserVersionRev = UserVersionRev { uvVersion :: Version, uvRev :: Maybe Int }
deriving (Ord, Eq, GHC.Generic, Show)
-- | A tag. These are currently attached to a version of a tool. -- | A tag. These are currently attached to a version of a tool.
data Tag = Latest -- ^ the latest version of a tool (unique per tool) data Tag = Latest
| Recommended -- ^ the recommended version of a tool (unique per tool) | Recommended
| Prerelease -- ^ denotes a prerelease version | Prerelease
-- (a version should either be 'Prerelease' or | LatestPrerelease
-- 'LatestPrerelease', but not both) | Base PVP
| LatestPrerelease -- ^ the latest prerelease (unique per tool)
| Nightly -- ^ denotes a nightly version
-- (a version should either be 'Nightly' or
-- 'LatestNightly', but not both)
| LatestNightly -- ^ the latest nightly (unique per tool)
| Base PVP -- ^ the base version shipped with GHC
| Old -- ^ old versions are hidden by default in TUI | Old -- ^ old versions are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat | UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
@@ -178,22 +221,18 @@ tagToString :: Tag -> String
tagToString Recommended = "recommended" tagToString Recommended = "recommended"
tagToString Latest = "latest" tagToString Latest = "latest"
tagToString Prerelease = "prerelease" tagToString Prerelease = "prerelease"
tagToString Nightly = "nightly"
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
tagToString (UnknownTag t ) = t tagToString (UnknownTag t ) = t
tagToString LatestPrerelease = "latest-prerelease" tagToString LatestPrerelease = "latest-prerelease"
tagToString LatestNightly = "latest-nightly"
tagToString Old = "" tagToString Old = ""
instance Pretty Tag where instance Pretty Tag where
pPrint Recommended = text "recommended" pPrint Recommended = text "recommended"
pPrint Latest = text "latest" pPrint Latest = text "latest"
pPrint Prerelease = text "prerelease" pPrint Prerelease = text "prerelease"
pPrint Nightly = text "nightly"
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp'')) pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t pPrint (UnknownTag t ) = text t
pPrint LatestPrerelease = text "latest-prerelease" pPrint LatestPrerelease = text "latest-prerelease"
pPrint LatestNightly = text "latest-prerelease"
pPrint Old = mempty pPrint Old = mempty
data Architecture = A_64 data Architecture = A_64
@@ -249,8 +288,6 @@ data LinuxDistro = Debian
| RedHat | RedHat
| Alpine | Alpine
| AmazonLinux | AmazonLinux
| RockyLinux
| VoidLinux
-- rolling -- rolling
| Gentoo | Gentoo
| Exherbo | Exherbo
@@ -270,8 +307,6 @@ distroToString CentOS = "centos"
distroToString RedHat = "redhat" distroToString RedHat = "redhat"
distroToString Alpine = "alpine" distroToString Alpine = "alpine"
distroToString AmazonLinux = "amazon" distroToString AmazonLinux = "amazon"
distroToString RockyLinux = "rocky"
distroToString VoidLinux = "void"
distroToString Gentoo = "gentoo" distroToString Gentoo = "gentoo"
distroToString Exherbo = "exherbo" distroToString Exherbo = "exherbo"
distroToString UnknownLinux = "unknown" distroToString UnknownLinux = "unknown"
@@ -287,7 +322,6 @@ data DownloadInfo = DownloadInfo
, _dlSubdir :: Maybe TarDir , _dlSubdir :: Maybe TarDir
, _dlHash :: Text , _dlHash :: Text
, _dlCSize :: Maybe Integer , _dlCSize :: Maybe Integer
, _dlOutput :: Maybe FilePath
} }
deriving (Eq, Ord, GHC.Generic, Show) deriving (Eq, Ord, GHC.Generic, Show)
@@ -605,14 +639,6 @@ data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text { _tvTarget :: Maybe Text
, _tvVersion :: Version , _tvVersion :: Version
} }
deriving (Ord, Eq, Show, GHC.Generic)
instance NFData GHCTargetVersion
data GitBranch = GitBranch
{ ref :: String
, repo :: Maybe String
}
deriving (Ord, Eq, Show) deriving (Ord, Eq, Show)
mkTVer :: Version -> GHCTargetVersion mkTVer :: Version -> GHCTargetVersion
@@ -622,10 +648,30 @@ tVerToText :: GHCTargetVersion -> Text
tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v' tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
tVerToText (GHCTargetVersion Nothing v') = prettyVer v' tVerToText (GHCTargetVersion Nothing v') = prettyVer v'
-- | A GHC identified by the target platform triple
-- and the version.
data GHCTargetVersionRev = GHCTargetVersionRev
{ _tvTargetRev :: Maybe Text
, _tvVersionRev :: VersionRev
}
deriving (Ord, Eq, Show)
mkTVerRev :: VersionRev -> GHCTargetVersionRev
mkTVerRev = GHCTargetVersionRev Nothing
tVerRevToText :: GHCTargetVersionRev -> Text
tVerRevToText (GHCTargetVersionRev (Just t) v') = t <> "-" <> showVersionRev v'
tVerRevToText (GHCTargetVersionRev Nothing v') = showVersionRev v'
-- | Assembles a path of the form: <target-triple>-<version> -- | Assembles a path of the form: <target-triple>-<version>
instance Pretty GHCTargetVersion where instance Pretty GHCTargetVersion where
pPrint = text . T.unpack . tVerToText pPrint = text . T.unpack . tVerToText
data GitBranch = GitBranch
{ ref :: String
, repo :: Maybe String
}
deriving (Ord, Eq, Show)
-- | A comparator and a version. -- | A comparator and a version.
data VersionCmp = VR_gt Versioning data VersionCmp = VR_gt Versioning
@@ -646,17 +692,6 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
instance NFData VersionRange instance NFData VersionRange
instance Pretty VersionCmp where
pPrint (VR_gt v) = text "> " <> pPrint v
pPrint (VR_gteq v) = text ">= " <> pPrint v
pPrint (VR_lt v) = text "< " <> pPrint v
pPrint (VR_lteq v) = text "<= " <> pPrint v
pPrint (VR_eq v) = text "= " <> pPrint v
instance Pretty VersionRange where
pPrint (SimpleRange xs) = foldl1 (\x y -> x <> text " && " <> y) $ NE.map pPrint xs
pPrint (OrRange xs vr) = foldMap pPrint xs <> " || " <> pPrint vr
instance Pretty Versioning where instance Pretty Versioning where
pPrint = text . T.unpack . prettyV pPrint = text . T.unpack . prettyV
@@ -728,21 +763,3 @@ type PromptQuestion = Text
data PromptResponse = PromptYes | PromptNo data PromptResponse = PromptYes | PromptNo
deriving (Show, Eq) deriving (Show, Eq)
data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag
| ToolDay Day
deriving (Eq, Show)
instance Pretty ToolVersion where
pPrint (GHCVersion v) = pPrint v
pPrint (ToolVersion v) = pPrint v
pPrint (ToolTag t) = pPrint t
pPrint (ToolDay d) = text (show d)
data BuildSystem = Hadrian
| Make
deriving (Show, Eq)

View File

@@ -64,11 +64,9 @@ instance ToJSON Tag where
toJSON Latest = String "Latest" toJSON Latest = String "Latest"
toJSON Recommended = String "Recommended" toJSON Recommended = String "Recommended"
toJSON Prerelease = String "Prerelease" toJSON Prerelease = String "Prerelease"
toJSON Nightly = String "Nightly"
toJSON Old = String "old" toJSON Old = String "old"
toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'') toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'')
toJSON LatestPrerelease = String "LatestPrerelease" toJSON LatestPrerelease = String "LatestPrerelease"
toJSON LatestNightly = String "LatestNightly"
toJSON (UnknownTag x ) = String (T.pack x) toJSON (UnknownTag x ) = String (T.pack x)
instance FromJSON Tag where instance FromJSON Tag where
@@ -76,9 +74,7 @@ instance FromJSON Tag where
"Latest" -> pure Latest "Latest" -> pure Latest
"Recommended" -> pure Recommended "Recommended" -> pure Recommended
"Prerelease" -> pure Prerelease "Prerelease" -> pure Prerelease
"Nightly" -> pure Nightly
"LatestPrerelease" -> pure LatestPrerelease "LatestPrerelease" -> pure LatestPrerelease
"LatestNightly" -> pure LatestNightly
"old" -> pure Old "old" -> pure Old
('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of ('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
Right x -> pure $ Base x Right x -> pure $ Base x
@@ -95,29 +91,13 @@ instance FromJSON URI where
Right x -> pure x Right x -> pure x
Left e -> fail . show $ e Left e -> fail . show $ e
instance ToJSON GHCTargetVersion where
toJSON = toJSON . tVerToText
instance FromJSON GHCTargetVersion where
parseJSON = withText "GHCTargetVersion" $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
instance ToJSONKey GHCTargetVersion where
toJSONKey = toJSONKeyText $ \x -> tVerToText x
instance FromJSONKey GHCTargetVersion where
fromJSONKey = FromJSONKeyTextParser $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e
instance ToJSON Versioning where instance ToJSON Versioning where
toJSON = toJSON . prettyV toJSON = toJSON . prettyV
instance FromJSON Versioning where instance FromJSON Versioning where
parseJSON = withText "Versioning" $ \t -> case versioning t of parseJSON = withText "Versioning" $ \t -> case versioning t of
Right x -> pure x Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e Left e -> fail $ "Failure in Version (FromJSON)" <> show e
instance ToJSONKey Versioning where instance ToJSONKey Versioning where
toJSONKey = toJSONKeyText $ \x -> prettyV x toJSONKey = toJSONKeyText $ \x -> prettyV x
@@ -340,11 +320,18 @@ instance FromJSONKey (Maybe VersionRange) where
Right x -> pure $ Just x Right x -> pure $ Just x
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfoLegacy
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionDownload
instance FromJSON VersionInfo where
parseJSON v = parseLegacy v <|> parseNew v
where
parseLegacy = fmap fromVersionInfoLegacy . parseJSON @VersionInfoLegacy
parseNew = genericParseJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel }
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key

View File

@@ -37,6 +37,7 @@ makeLenses ''PlatformResult
makeLenses ''DownloadInfo makeLenses ''DownloadInfo
makeLenses ''Tag makeLenses ''Tag
makeLenses ''VersionInfo makeLenses ''VersionInfo
makeLenses ''VersionDownload
makeLenses ''GHCTargetVersion makeLenses ''GHCTargetVersion

View File

@@ -62,6 +62,7 @@ import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit ) import Data.Char ( isHexDigit )
import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
@@ -93,7 +94,6 @@ import qualified Streamly.Prelude as S
import Control.DeepSeq (force) import Control.DeepSeq (force)
import GHC.IO (evaluate) import GHC.IO (evaluate)
import System.Environment (getEnvironment, setEnv) import System.Environment (getEnvironment, setEnv)
import Data.Time (Day(..), diffDays, addDays)
-- $setup -- $setup
@@ -160,7 +160,7 @@ rmMinorGHCSymlinks :: ( MonadReader env m
rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz let fullF = binDir </> f_xyz
@@ -181,7 +181,7 @@ rmPlainGHC :: ( MonadReader env m
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlainGHC target = do rmPlainGHC target = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
@@ -228,7 +228,7 @@ rmMinorHLSSymlinks :: ( MonadReader env m
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
) )
=> Version => VersionRev
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks ver = do rmMinorHLSSymlinks ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
@@ -281,18 +281,25 @@ rmPlainHLS = do
----------------------------------- -----------------------------------
-- | Whether the given GHC versin is installed. -- | Whether the given GHC version is installed.
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersionRev)
ghcSet mtarget = do ghcSet mtarget = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
@@ -304,7 +311,7 @@ ghcSet mtarget = do
link <- liftIO $ getLinkTarget ghcBin link <- liftIO $ getLinkTarget ghcBin
Just <$> ghcLinkVersion link Just <$> ghcLinkVersion link
where where
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersionRev
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where where
parser = parser =
@@ -314,7 +321,7 @@ ghcSet mtarget = do
r <- parseUntil1 pathSep r <- parseUntil1 pathSep
rest <- MP.getInput rest <- MP.getInput
MP.setInput r MP.setInput r
x <- ghcTargetVerP x <- ghcTargetVerRevP
MP.setInput rest MP.setInput rest
pure x pure x
) )
@@ -340,13 +347,13 @@ getInstalledCabals :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
) )
=> m [Either FilePath Version] => m [Either FilePath VersionRev]
getInstalledCabals = do getInstalledCabals = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of vs <- forM bins $ \f -> case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
@@ -354,14 +361,14 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver vers pure $ elem ver vers
-- Return the currently set cabal version, if any. -- Return the currently set cabal version, if any.
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
cabalSet = do cabalSet = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
@@ -388,7 +395,7 @@ cabalSet = do
-- We try to be extra permissive with link destination parsing, -- We try to be extra permissive with link destination parsing,
-- because of: -- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119 -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
linkVersion :: MonadThrow m => FilePath -> m Version linkVersion :: MonadThrow m => FilePath -> m VersionRev
linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt
parser parser
@@ -396,7 +403,7 @@ cabalSet = do
<|> MP.try (stripRelativePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse <|> cabalParse
-- parses the version of "cabal-3.2.0.0" -> "3.2.0.0" -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
cabalParse = MP.chunk "cabal-" *> version' cabalParse = MP.chunk "cabal-" *> versionRevP
-- parses any path component ending with path separator, -- parses any path component ending with path separator,
-- e.g. "foo/" -- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
@@ -413,7 +420,7 @@ cabalSet = do
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@, -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
-- as well as @~\/.ghcup\/hls\/<\hlsver\>@ -- as well as @~\/.ghcup\/hls\/<\hlsver\>@
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version] => m [Either FilePath VersionRev]
getInstalledHLSs = do getInstalledHLSs = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -424,7 +431,7 @@ getInstalledHLSs = do
) )
legacy <- forM bins $ \f -> legacy <- forM bins $ \f ->
case case
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f) versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
of of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
@@ -441,7 +448,7 @@ getInstalledHLSs = do
-- | Get all installed stacks, by matching on -- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@. -- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version] => m [Either FilePath VersionRev]
getInstalledStacks = do getInstalledStacks = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -451,7 +458,7 @@ getInstalledStacks = do
([s|^stack-.*$|] :: ByteString) ([s|^stack-.*$|] :: ByteString)
) )
forM bins $ \f -> forM bins $ \f ->
case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
@@ -502,13 +509,13 @@ stackSet = do
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
-- | Whether the given Stack version is installed. -- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
stackInstalled ver = do stackInstalled ver = do
vers <- fmap rights getInstalledStacks vers <- fmap rights getInstalledStacks
pure $ elem ver vers pure $ elem ver vers
-- | Whether the given HLS version is installed. -- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
hlsInstalled ver = do hlsInstalled ver = do
vers <- fmap rights getInstalledHLSs vers <- fmap rights getInstalledHLSs
pure $ elem ver vers pure $ elem ver vers
@@ -520,7 +527,7 @@ isLegacyHLS ver = do
-- Return the currently set hls version, if any. -- Return the currently set hls version, if any.
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
hlsSet = do hlsSet = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
@@ -533,7 +540,7 @@ hlsSet = do
link <- liftIO $ getLinkTarget hlsBin link <- liftIO $ getLinkTarget hlsBin
Just <$> linkVersion link Just <$> linkVersion link
where where
linkVersion :: MonadThrow m => FilePath -> m Version linkVersion :: MonadThrow m => FilePath -> m VersionRev
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where where
parser parser
@@ -541,7 +548,7 @@ hlsSet = do
<|> MP.try (stripRelativePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse <|> cabalParse
-- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0" -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' cabalParse = MP.chunk "haskell-language-server-wrapper-" *> versionRevP
-- parses any path component ending with path separator, -- parses any path component ending with path separator,
-- e.g. "foo/" -- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
@@ -560,7 +567,7 @@ hlsGHCVersions :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
) )
=> m [Version] => m [VersionRev]
hlsGHCVersions = do hlsGHCVersions = do
h <- hlsSet h <- hlsSet
fromMaybe [] <$> forM h hlsGHCVersions' fromMaybe [] <$> forM h hlsGHCVersions'
@@ -572,12 +579,12 @@ hlsGHCVersions' :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
) )
=> Version => VersionRev
-> m [Version] -> m [VersionRev]
hlsGHCVersions' v' = do hlsGHCVersions' v' = do
bins <- hlsServerBinaries v' Nothing bins <- hlsServerBinaries v' Nothing
let vers = fmap let vers = fmap
(version (versionRev
. T.pack . T.pack
. fromJust . fromJust
. stripPrefix "haskell-language-server-" . stripPrefix "haskell-language-server-"
@@ -590,10 +597,10 @@ hlsGHCVersions' v' = do
-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any. -- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version => VersionRev
-> Maybe Version -- ^ optional GHC version -> Maybe Version -- ^ optional GHC version
-> m [FilePath] -> m [FilePath]
hlsServerBinaries ver mghcVer = do hlsServerBinaries (VersionRev ver rv) mghcVer = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
@@ -604,6 +611,7 @@ hlsServerBinaries ver mghcVer = do
<> maybe [s|.*|] escapeVerRex mghcVer <> maybe [s|.*|] escapeVerRex mghcVer
<> [s|~|] <> [s|~|]
<> escapeVerRex ver <> escapeVerRex ver
<> E.encodeUtf8 (T.pack ("-r" <> show rv))
<> E.encodeUtf8 (T.pack exeExt) <> E.encodeUtf8 (T.pack exeExt)
<> [s|$|] :: ByteString <> [s|$|] :: ByteString
) )
@@ -650,16 +658,20 @@ hlsInternalServerLibs ver ghcVer = do
-- | Get the wrapper binary for an hls version, if any. -- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Version => VersionRev
-> m (Maybe FilePath) -> m (Maybe FilePath)
hlsWrapperBinary ver = do hlsWrapperBinary (VersionRev ver rv) = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
compExtended compExtended
execBlank execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString ([s|^haskell-language-server-wrapper-|]
<> escapeVerRex ver
<> E.encodeUtf8 (T.pack ("-r" <> show rv))
<> E.encodeUtf8 (T.pack exeExt)
<> [s|$|] :: ByteString
) )
) )
case wrapper of case wrapper of
@@ -670,7 +682,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any. -- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => VersionRev -> m [FilePath]
hlsAllBinaries ver = do hlsAllBinaries ver = do
hls <- hlsServerBinaries ver Nothing hls <- hlsServerBinaries ver Nothing
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
@@ -766,16 +778,16 @@ getGHCForPVP' pvpIn ghcs' mt = do
-- Just (PVP {_pComponents = 8 :| [8,4]}) -- Just (PVP {_pComponents = 8 :| [8,4]})
getLatestToolFor :: MonadThrow m getLatestToolFor :: MonadThrow m
=> Tool => Tool
-> Maybe Text
-> PVP -> PVP
-> GHCupDownloads -> GHCupDownloads
-> m (Maybe (PVP, VersionInfo, Maybe Text)) -> m (Maybe (PVP, VersionInfo))
getLatestToolFor tool target pvpIn dls = do getLatestToolFor tool pvpIn dls = do
let ls :: [(GHCTargetVersion, VersionInfo)] let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
let ps :: [((PVP, Text), VersionInfo, Maybe Text)] pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
ps = catMaybes $ fmap (\(v, vi) -> (,vi, _tvTarget v) <$> versionToPVP (_tvVersion v)) ls
pure . fmap (\((pv', _), vi, mt) -> (pv', vi, mt)) . headMay . filter (\((v, _), _, t) -> matchPVPrefix pvpIn v && t == target) $ ps -- type ToolVersionSpec = Map Version ToolRevisionSpec
-- type ToolRevisionSpec = Map Int VersionInfo
@@ -880,41 +892,23 @@ intoSubdir bdir tardir = case tardir of
-- | Get the tool version that has this tag. If multiple have it, -- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version. -- picks the greatest version.
getTagged :: Tag getTagged :: Tag
-> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo) -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag = getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id % folding id
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo) getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m ->
maybe m (\d -> let diff = diffDays d day
in Map.insert (abs diff) (diff, (k, vi)) m) _viReleaseDay)
Map.empty mvv
in case headMay (Map.toAscList mdv) of
Nothing -> Left Nothing
Just (absDiff, (diff, (k, vi)))
| absDiff == 0 -> Right (k, vi)
| otherwise -> Left (Just (addDays diff day))
getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) av getLatest av tool = headOf (ix tool % getTagged Latest) av
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo) getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo) getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) av getRecommended av tool = headOf (ix tool % getTagged Recommended) av
-- | Gets the latest GHC with a given base version. -- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo) getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
getLatestBaseVersion av pvpVer = getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer)) av headOf (ix GHC % getTagged (Base pvpVer)) av
@@ -941,7 +935,7 @@ ghcInternalBinDir ver = do
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersionRev
-> Excepts '[NotInstalled] m [FilePath] -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do ghcToolFiles ver = do
bindir <- ghcInternalBinDir ver bindir <- ghcInternalBinDir ver
@@ -968,6 +962,11 @@ ghcToolFiles ver = do
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make. -- | Calls gmake if it exists in PATH, otherwise make.
make :: ( MonadThrow m make :: ( MonadThrow m
@@ -1090,15 +1089,11 @@ darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog dls tool (GHCVersion v') = getChangeLog dls tool (Left v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolVersion (mkTVer -> v')) = getChangeLog dls tool (Right tag) =
preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolTag tag) =
preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls
getChangeLog dls tool (ToolDay day) =
preview (ix tool % pre (getByReleaseDayFold day) % to snd % viChangeLog % _Just) dls
-- | Execute a build action while potentially cleaning up: -- | Execute a build action while potentially cleaning up:
@@ -1182,7 +1177,7 @@ rmBDir dir = withRunInIO (\run -> run $
$ rmPathForcibly dir) $ rmPathForcibly dir)
getVersionInfo :: GHCTargetVersion getVersionInfo :: Version
-> Tool -> Tool
-> GHCupDownloads -> GHCupDownloads
-> Maybe VersionInfo -> Maybe VersionInfo
@@ -1212,7 +1207,7 @@ ensureGlobalTools
(GHCupInfo _ _ gTools) <- lift getGHCupInfo (GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
@@ -1298,7 +1293,7 @@ warnAboutHlsCompatibility :: ( MonadReader env m
=> m () => m ()
warnAboutHlsCompatibility = do warnAboutHlsCompatibility = do
supportedGHC <- hlsGHCVersions supportedGHC <- hlsGHCVersions
currentGHC <- fmap _tvVersion <$> ghcSet Nothing currentGHC <- fmap _tvVersionRev <$> ghcSet Nothing
currentHLS <- hlsSet currentHLS <- hlsSet
case (currentGHC, currentHLS) of case (currentGHC, currentHLS) of

View File

@@ -279,7 +279,7 @@ ghcupCacheDir
Nothing -> do Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ".cache") pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup" </> "cache")) pure (GHCupPath (bdir </> "ghcup"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache")) else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
@@ -308,7 +308,19 @@ ghcupLogsDir
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec. -- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO GHCupPath ghcupDbDir :: IO GHCupPath
ghcupDbDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db")) ghcupDbDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (GHCupPath (bdir </> "ghcup" </> "db"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
-- | '~/.ghcup/trash'. -- | '~/.ghcup/trash'.
@@ -405,9 +417,9 @@ parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) = parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp throwEither $ MP.parse ghcTargetVerP "" fp
parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version parseGHCupHLSDir :: MonadThrow m => FilePath -> m VersionRev
parseGHCupHLSDir (T.pack -> fp) = parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp throwEither $ versionRev fp
-- TODO: inlined from GHCup.Prelude -- TODO: inlined from GHCup.Prelude
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b throwEither :: (Exception a, MonadThrow m) => Either a b -> m b

View File

@@ -52,7 +52,7 @@ versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
versionCmp ver1 (VR_eq ver2) = ver1 == ver2 versionCmp ver1 (VR_eq ver2) = ver1 == ver2
versionRange :: V.Versioning -> VersionRange -> Bool versionRange :: V.Versioning -> VersionRange -> Bool
versionRange ver' (SimpleRange cmps) = all (versionCmp ver') cmps versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
versionRange ver' (OrRange cmps range) = versionRange ver' (OrRange cmps range) =
versionRange ver' (SimpleRange cmps) || versionRange ver' range versionRange ver' (SimpleRange cmps) || versionRange ver' range

View File

@@ -28,7 +28,7 @@
plat="$(uname -s)" plat="$(uname -s)"
arch=$(uname -m) arch=$(uname -m)
ghver="0.1.19.4" ghver="0.1.19.2"
: "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}" : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}"
export GHCUP_SKIP_UPDATE_CHECK=yes export GHCUP_SKIP_UPDATE_CHECK=yes
@@ -851,8 +851,8 @@ case $ask_stack_answer in
;; ;;
2) 2)
(_eghcup --cache install stack) || die "Stack installation failed" (_eghcup --cache install stack) || die "Stack installation failed"
edo mkdir -p "${STACK_ROOT:-$HOME/.stack}"/hooks edo mkdir -p "${STACK_ROOOT:-$HOME/.stack}"/hooks
hook_exe="${STACK_ROOT:-$HOME/.stack}"/hooks/ghc-install.sh hook_exe="${STACK_ROOOT:-$HOME/.stack}"/hooks/ghc-install.sh
hook_url="https://www.haskell.org/ghcup/sh/hooks/stack/ghc-install.sh" hook_url="https://www.haskell.org/ghcup/sh/hooks/stack/ghc-install.sh"
if [ -e "${hook_exe}" ] ; then if [ -e "${hook_exe}" ] ; then

View File

@@ -40,13 +40,10 @@ param (
# Whether to disable use of curl.exe # Whether to disable use of curl.exe
[switch]$DisableCurl, [switch]$DisableCurl,
# The Msys2 version to download (e.g. 20221216) # The Msys2 version to download (e.g. 20221216)
[string]$Msys2Version, [string]$Msys2Version
# The Msys2 sha256sum hash
[string]$Msys2Hash
) )
$DefaultMsys2Version = "20221216" $DefaultMsys2Version = "20221216"
$DefaultMsys2Hash = "18370d32b0264915c97e3d7c618f7b32d48ad80858923883fde5145acd32ca0f"
$Silent = !$Interactive $Silent = !$Interactive
@@ -433,12 +430,9 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
if (!($Msys2Version)) { if (!($Msys2Version)) {
$Msys2Version = $DefaultMsys2Version $Msys2Version = $DefaultMsys2Version
} }
if (!($Msys2Hash)) {
$Msys2Hash = $DefaultMsys2Hash
}
Print-Msg -msg ('Downloading Msys2 archive {0}...' -f $Msys2Version) Print-Msg -msg ('Downloading Msys2 archive {0}...' -f $Msys2Version)
$archive = ('msys2-base-x86_64-{0}.sfx.exe' -f $Msys2Version) $archive = ('msys2-base-x86_64-{0}.sfx.exe' -f $Msys2Version)
$msysUrl = ('https://downloads.haskell.org/ghcup/msys2/{0}' -f "$archive") $msysUrl = ('https://repo.msys2.org/distrib/x86_64/{0}' -f "$archive")
$archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive") $archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive")
if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) { if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) {
@@ -446,11 +440,6 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
} else { } else {
Get-FileWCSynchronous -url "$msysUrl" -destinationFolder ([IO.Path]::GetTempPath()) -includeStats Get-FileWCSynchronous -url "$msysUrl" -destinationFolder ([IO.Path]::GetTempPath()) -includeStats
} }
$Msys2HashChecked = Get-FileHash -Algorithm SHA256 "${archivePath}"
if (!($Msys2HashChecked.Hash -eq $Msys2Hash)) {
Print-Msg -color Red -msg ("Hashes don't match, got {0}, but expected {1}" -f $Msys2HashChecked, $Msys2Hash)
Exit 1
}
Print-Msg -msg 'Extracting Msys2 archive...' Print-Msg -msg 'Extracting Msys2 archive...'
$null = & "$archivePath" '-y' ('-o{0}' -f $GhcupDir) # Extract $null = & "$archivePath" '-y' ('-o{0}' -f $GhcupDir) # Extract
@@ -459,7 +448,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -msg 'Processing MSYS2 bash for first time use...' Print-Msg -msg 'Processing MSYS2 bash for first time use...'
Exec "$Bash" '-lc' 'exit' Exec "$Bash" '-lc' 'exit'
Exec "$env:windir\system32\taskkill.exe" /F /FI "MODULES eq msys-2.0.dll" Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`"
Print-Msg -msg 'Upgrading full system...' Print-Msg -msg 'Upgrading full system...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu' Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'

View File

@@ -1,67 +0,0 @@
#!/bin/bash
set -eu
set -o pipefail
RELEASE=$1
get_sha() {
sha256sum "$1" | awk '{ print $1 }'
}
cd "gh-release-artifacts/v${RELEASE}"
cat <<EOF > /dev/stdout
GHCup:
${RELEASE}:
viTags:
- Recommended
- Latest
viChangeLog: https://github.com/haskell/ghcup-hs/blob/master/CHANGELOG.md
viSourceDL:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/ghcup-${RELEASE}-src.tar.gz
dlSubdir: ghcup-${RELEASE}
dlHash: $(get_sha "ghcup-${RELEASE}-src.tar.gz")
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/x86_64-linux-ghcup-${RELEASE}
dlHash: $(get_sha "x86_64-linux-ghcup-${RELEASE}")
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/x86_64-apple-darwin-ghcup-${RELEASE}
dlHash: $(get_sha "x86_64-apple-darwin-ghcup-${RELEASE}")
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/x86_64-portbld-freebsd-ghcup-${RELEASE}
dlHash: $(get_sha "x86_64-portbld-freebsd-ghcup-${RELEASE}")
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/x86_64-mingw64-ghcup-${RELEASE}.exe
dlHash: $(get_sha "x86_64-mingw64-ghcup-${RELEASE}.exe")
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/i386-linux-ghcup-${RELEASE}
dlHash: $(get_sha "i386-linux-ghcup-${RELEASE}")
Linux_Alpine:
unknown_versioning: *ghcup-32
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/aarch64-linux-ghcup-${RELEASE}
dlHash: $(get_sha "aarch64-linux-ghcup-${RELEASE}")
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/aarch64-apple-darwin-ghcup-${RELEASE}
dlHash: $(get_sha "aarch64-apple-darwin-ghcup-${RELEASE}")
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/${RELEASE}/armv7-linux-ghcup-${RELEASE}
dlHash: $(get_sha "armv7-linux-ghcup-${RELEASE}")
EOF

View File

@@ -29,7 +29,7 @@ gh release download "$RELEASE"
# cirrus # cirrus
curl -L -o "x86_64-portbld-freebsd-ghcup-${TAG}" \ curl -L -o "x86_64-portbld-freebsd-ghcup-${TAG}" \
"https://api.cirrus-ci.com/v1/artifact/github/haskell/ghcup-hs/build/binaries/out/x86_64-portbld-freebsd-ghcup-${TAG}?branch=${RELEASE}" "https://api.cirrus-ci.com/v1/artifact/github/haskell/ghcup-hs/build/binaries/out/x86_64-portbld-freebsd-ghcup-${RELEASE}?branch=${RELEASE}"
sha256sum ./*-ghcup-* > SHA256SUMS sha256sum ./*-ghcup-* > SHA256SUMS
gpg --detach-sign -u "${SIGNER}" SHA256SUMS gpg --detach-sign -u "${SIGNER}" SHA256SUMS

View File

@@ -1,36 +1,52 @@
resolver: lts-20.26 resolver: lts-18.28
packages: packages:
- . - .
extra-deps: extra-deps:
- Cabal-3.6.3.0 - Cabal-3.6.2.0@sha256:e2266e14758c1f799220fad7f0d4b0b4ec567d81b7ba3faea17ff76d4c31de95,12437
- Cabal-syntax-3.10.1.0 - IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
- aeson-2.1.2.1 - ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
- cabal-install-parsers-0.6.1 - base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231
- brick-0.64@sha256:f03fa14607c22cf48af99e24c44f79a0fb073f7ec229f15e969fed9ff73c93f6,16530
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
- chs-cabal-0.1.1.1 - chs-cabal-0.1.1.1
- chs-deps-0.1.0.0 - chs-deps-0.1.0.0@sha256:0cdada6d2c682c41b20331b8c63c2ecfc7e806928585195fd544c9d41f3074fd,2496
- generic-arbitrary-0.2.2@sha256:202ffbf2032672a51318f2e80d7e75b72f8950e690346b4314f38bc7e39215f7,1189 - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
- generically-0.1.1
- haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466 - haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298 - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.2.1 - haskus-utils-variant-3.2.1@sha256:791f4cf1e786eb578f4d37aef60986641f84c36e130164321f7d01542584066a,2200
- libarchive-3.0.3.2 - heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
- hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
- hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- libarchive-3.0.3.0
- libyaml-streamly-0.2.1 - libyaml-streamly-0.2.1
- lzma-static-5.2.5.5 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- os-release-1.0.2.1 - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- parsec-3.1.15.0 - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7
- streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500 - streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500
- strict-base-0.4.0.0 - unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123
- text-2.0.2 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- yaml-streamly-0.12.2 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- yaml-streamly-0.12.1
flags: flags:
http-io-streams: http-io-streams:
brotli: false brotli: false
libarchive: libarchive:
system-libarchive: true system-libarchive: false
regex-posix: regex-posix:
_regex-posix-clib: true _regex-posix-clib: true

View File

@@ -11,7 +11,6 @@ import GHCup.Types
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Versions import Data.Versions
import Data.List.NonEmpty import Data.List.NonEmpty
import Data.Time.Calendar ( Day(..) )
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary ) import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
@@ -77,9 +76,6 @@ instance Arbitrary Port where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Arbitrary Day where
arbitrary = ModifiedJulianDay . fromIntegral <$> (chooseAny :: Gen Int)
instance Arbitrary (URIRef Absolute) where instance Arbitrary (URIRef Absolute) where
arbitrary = arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> pure (Query []) <*> pure Nothing URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> pure (Query []) <*> pure Nothing
@@ -151,6 +147,10 @@ instance Arbitrary Architecture where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Arbitrary VersionDownload where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionInfo where instance Arbitrary VersionInfo where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
@@ -183,10 +183,6 @@ instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Arbitrary GHCTargetVersion where
arbitrary = GHCTargetVersion Nothing <$> arbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram -- our maps are nested... the default size easily blows up most ppls ram

View File

@@ -24,7 +24,7 @@ spec = do
-- https://github.com/haskell/ghcup-hs/issues/415 -- https://github.com/haskell/ghcup-hs/issues/415
describe "GHCup.Prelude.File.Posix.Traversals" $ do describe "GHCup.Prelude.File.Posix.Traversals" $ do
it "readDirEnt" $ do it "readDirEnt" $ do
dirstream <- liftIO $ openDirStreamPortable "test/ghcup-test/data" dirstream <- liftIO $ openDirStreamPortable "test/data"
(dt1, fp1) <- readDirEntPortable dirstream (dt1, fp1) <- readDirEntPortable dirstream
(dt2, fp2) <- readDirEntPortable dirstream (dt2, fp2) <- readDirEntPortable dirstream
(dt3, fp3) <- readDirEntPortable dirstream (dt3, fp3) <- readDirEntPortable dirstream

View File

@@ -17,6 +17,6 @@ spec = do
roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName goldenDir }) (Proxy @GHCupInfo) roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName goldenDir }) (Proxy @GHCupInfo)
where where
goldenDir goldenDir
| isWindows = "test/ghcup-test/golden/windows" | isWindows = "test/golden/windows"
| otherwise = "test/ghcup-test/golden/unix" | otherwise = "test/golden/unix"

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,49 +0,0 @@
module ChangeLogTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import Test.Tasty.HUnit
import Control.Monad.IO.Class
import GHCup.Types
import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|)))
changeLogTests :: TestTree
changeLogTests = testGroup "changelog" $ map (uncurry check) checkList
where
check :: String -> ChangeLogOptions -> TestTree
check args expected = testCase args $ do
res <- changeLogParseWith (words args)
liftIO $ res @?= expected
checkList :: [(String, ChangeLogOptions)]
checkList =
[ ("changelog", ChangeLogOptions False Nothing Nothing)
, ("changelog -o", ChangeLogOptions True Nothing Nothing)
, ("changelog -t ghc", ChangeLogOptions False (Just GHC) Nothing)
, ("changelog -t cabal", ChangeLogOptions False (Just Cabal) Nothing)
, ("changelog -t hls", ChangeLogOptions False (Just HLS) Nothing)
, ("changelog -t stack", ChangeLogOptions False (Just Stack) Nothing)
, ("changelog -t ghcup", ChangeLogOptions False (Just GHCup) Nothing)
, ("changelog 9.2", ChangeLogOptions False Nothing
(Just $ GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []]))
)
, ("changelog recommended", ChangeLogOptions False Nothing (Just $ ToolTag Recommended))
, ("changelog -t cabal recommended", ChangeLogOptions False (Just Cabal) (Just $ ToolTag Recommended))
, ("changelog -t cabal 3.10.1.0", ChangeLogOptions False (Just Cabal)
(Just $ GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Digits 3 :| []) :| [Digits 10 :| [],Digits 1 :| [],Digits 0 :| []]))
)
, ("changelog 2023-07-22", ChangeLogOptions False Nothing (Just (ToolDay (read "2023-07-22"))))
]
changeLogParseWith :: [String] -> IO ChangeLogOptions
changeLogParseWith args = do
ChangeLog a <- parseWith args
pure a

View File

@@ -1,190 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
module CompileTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import Data.Versions
import GHCup.Types
import URI.ByteString.QQ
import qualified GHCup.OptParse.Compile as GHC (GHCCompileOptions(..))
import qualified GHCup.OptParse.Compile as HLS (HLSCompileOptions(..))
import GHCup.GHC as GHC
import GHCup.HLS as HLS
compileTests :: TestTree
compileTests = testGroup "compile"
$ map (buildTestTree compileParseWith)
[ ("ghc", compileGhcCheckList)
, ("hls", compileHlsCheckList)
]
mkDefaultGHCCompileOptions :: GHCVer -> Either Version FilePath -> GHCCompileOptions
mkDefaultGHCCompileOptions target boot =
GHCCompileOptions
target
boot
Nothing
Nothing
(Just $ Right [])
Nothing
[]
False
Nothing
Nothing
Nothing
Nothing
mkDefaultHLSCompileOptions :: HLSVer -> [ToolVersion] -> HLSCompileOptions
mkDefaultHLSCompileOptions target ghcs =
HLSCompileOptions
target
Nothing
True
False
(Left False)
Nothing
Nothing
Nothing
(Just $ Right [])
ghcs
[]
compileGhcCheckList :: [(String, CompileCommand)]
compileGhcCheckList = mapSecond CompileGHC
[ ("compile ghc -v 9.4.5 -b 9.2.8", baseOptions)
, ("compile ghc -g a32db0b -b 9.2.8", mkDefaultGHCCompileOptions
(GHC.GitDist $ GitBranch "a32db0b" Nothing)
(Left $ mkVersion' "9.2.8")
)
, ("compile ghc -g a32db0b -b 9.2.8 -r https://gitlab.haskell.org/ghc/ghc.git",
mkDefaultGHCCompileOptions
(GHC.GitDist $ GitBranch "a32db0b" (Just "https://gitlab.haskell.org/ghc/ghc.git"))
(Left $ mkVersion' "9.2.8")
)
, ("compile ghc -g a32db0b -r https://gitlab.haskell.org/ghc/ghc.git -b /usr/bin/ghc-9.2.2",
mkDefaultGHCCompileOptions
(GHC.GitDist $ GitBranch "a32db0b" (Just "https://gitlab.haskell.org/ghc/ghc.git"))
(Right "/usr/bin/ghc-9.2.2")
)
, ("compile ghc --remote-source-dist https://gitlab.haskell.org/ghc/ghc.git -b 9.2.8", mkDefaultGHCCompileOptions
(GHC.RemoteDist [uri|https://gitlab.haskell.org/ghc/ghc.git|])
(Left $ mkVersion' "9.2.8")
)
, (baseCmd <> "-j20", baseOptions{GHC.jobs = Just 20})
, (baseCmd <> "--jobs 10", baseOptions{GHC.jobs = Just 10})
, (baseCmd <> "-c build.mk", baseOptions{GHC.buildConfig = Just "build.mk"})
, (baseCmd <> "--config build.mk", baseOptions{GHC.buildConfig = Just "build.mk"})
, (baseCmd <> "--patch file:///example.patch", baseOptions{GHC.patches = Just $ Right [[uri|file:///example.patch|]]})
, (baseCmd <> "-p patch_dir", baseOptions{GHC.patches = Just (Left "patch_dir")})
, (baseCmd <> "--patchdir patch_dir", baseOptions{GHC.patches = Just (Left "patch_dir")})
, (baseCmd <> "-x armv7-unknown-linux-gnueabihf", baseOptions{GHC.crossTarget = Just "armv7-unknown-linux-gnueabihf"})
, (baseCmd <> "--cross-target armv7-unknown-linux-gnueabihf", baseOptions{GHC.crossTarget = Just "armv7-unknown-linux-gnueabihf"})
, (baseCmd <> "-- --enable-unregisterised", baseOptions{GHC.addConfArgs = ["--enable-unregisterised"]})
, (baseCmd <> "--set", baseOptions{GHC.setCompile = True})
, (baseCmd <> "-o 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $ mkVersion' "9.4.5-p1"})
, (baseCmd <> "--overwrite-version 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $ mkVersion' "9.4.5-p1"})
, (baseCmd <> "-f make", baseOptions{GHC.buildFlavour = Just "make"})
, (baseCmd <> "--flavour make", baseOptions{GHC.buildFlavour = Just "make"})
, (baseCmd <> "--hadrian", baseOptions{GHC.buildSystem = Just Hadrian})
, (baseCmd <> "--make", baseOptions{GHC.buildSystem = Just Make})
#ifdef IS_WINDOWS
, (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{GHC.isolateDir = Just "C:\\\\tmp\\out_dir"})
, (baseCmd <> "--isolate C:\\\\tmp\\out_dir", baseOptions{GHC.isolateDir = Just "C:\\\\tmp\\out_dir"})
#else
, (baseCmd <> "-i /tmp/out_dir", baseOptions{GHC.isolateDir = Just "/tmp/out_dir"})
, (baseCmd <> "--isolate /tmp/out_dir", baseOptions{GHC.isolateDir = Just "/tmp/out_dir"})
#endif
]
where
baseCmd :: String
baseCmd = "compile ghc -v 9.4.5 -b 9.2.8 "
baseOptions :: GHCCompileOptions
baseOptions =
mkDefaultGHCCompileOptions
(GHC.SourceDist $ mkVersion' "9.4.5")
(Left $ mkVersion' "9.2.8")
compileHlsCheckList :: [(String, CompileCommand)]
compileHlsCheckList = mapSecond CompileHLS
[ ("compile hls -v 2.0.0.0 --ghc 9.2.8", baseOptions)
, ("compile hls --version 2.0.0.0 --ghc 9.2.8", baseOptions)
, ("compile hls -g a32db0b --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.GitDist $ GitBranch {ref = "a32db0b", repo = Nothing})
[ghc928]
)
, ("compile hls --git-ref a32db0b --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.GitDist $ GitBranch {ref = "a32db0b", repo = Nothing})
[ghc928]
)
, ("compile hls -g a32db0b -r https://github.com/haskell/haskell-language-server.git --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.GitDist $ GitBranch {ref = "a32db0b", repo = Just "https://github.com/haskell/haskell-language-server.git"})
[ghc928]
)
, ("compile hls -g a32db0b --repository https://github.com/haskell/haskell-language-server.git --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.GitDist $ GitBranch {ref = "a32db0b", repo = Just "https://github.com/haskell/haskell-language-server.git"})
[ghc928]
)
, ("compile hls --source-dist 2.0.0.0 --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.SourceDist $ mkVersion' "2.0.0.0")
[ghc928]
)
, ("compile hls --remote-source-dist https://github.com/haskell/haskell-language-server/archive/refs/tags/2.0.0.1.tar.gz --ghc 9.2.8",
mkDefaultHLSCompileOptions
(HLS.RemoteDist [uri|https://github.com/haskell/haskell-language-server/archive/refs/tags/2.0.0.1.tar.gz|])
[ghc928]
)
, ("compile hls -v 2.0.0.0 --ghc latest",
mkDefaultHLSCompileOptions
(HLS.HackageDist $ mkVersion' "2.0.0.0")
[ToolTag Latest]
)
, (baseCmd <> "-j20", baseOptions{HLS.jobs = Just 20})
, (baseCmd <> "--jobs 10", baseOptions{HLS.jobs = Just 10})
, (baseCmd <> "--no-set", baseOptions{HLS.setCompile = False})
, (baseCmd <> "--cabal-update", baseOptions{HLS.updateCabal = True})
, (baseCmd <> "-o 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $ mkVersion' "2.0.0.0-p1"})
, (baseCmd <> "--overwrite-version 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $ mkVersion' "2.0.0.0-p1"})
, (baseCmd <> "--git-describe-version", baseOptions{HLS.ovewrwiteVer = Left True})
#ifdef IS_WINDOWS
, (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})
, (baseCmd <> "--isolate C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})
#else
, (baseCmd <> "-i /tmp/out_dir", baseOptions{HLS.isolateDir = Just "/tmp/out_dir"})
, (baseCmd <> "--isolate /tmp/out_dir", baseOptions{HLS.isolateDir = Just "/tmp/out_dir"})
#endif
, (baseCmd <> "--cabal-project file:///tmp/cabal.project", baseOptions{HLS.cabalProject = Just $ Right [uri|file:///tmp/cabal.project|]})
, (baseCmd <> "--cabal-project cabal.ghc8107.project", baseOptions{HLS.cabalProject = Just $ Left "cabal.ghc8107.project"})
, (baseCmd <> "--cabal-project-local file:///tmp/cabal.project.local", baseOptions{HLS.cabalProjectLocal = Just [uri|file:///tmp/cabal.project.local|]})
, (baseCmd <> "--patch file:///example.patch", baseOptions{HLS.patches = Just $ Right [[uri|file:///example.patch|]]})
, (baseCmd <> "-p patch_dir", baseOptions{HLS.patches = Just (Left "patch_dir")})
, (baseCmd <> "--patchdir patch_dir", baseOptions{HLS.patches = Just (Left "patch_dir")})
, (baseCmd <> "-- --enable-tests", baseOptions{HLS.cabalArgs = ["--enable-tests"]})
]
where
baseCmd :: String
baseCmd = "compile hls -v 2.0.0.0 --ghc 9.2.8 "
baseOptions :: HLSCompileOptions
baseOptions =
mkDefaultHLSCompileOptions
(HLS.HackageDist $ mkVersion' "2.0.0.0")
[ghc928]
ghc928 :: ToolVersion
ghc928 = GHCVersion $ GHCTargetVersion Nothing (mkVersion' "9.2.8")
compileParseWith :: [String] -> IO CompileCommand
compileParseWith args = do
Compile a <- parseWith args
pure a

View File

@@ -1,34 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module ConfigTest where
import Test.Tasty
import Test.Tasty.HUnit
import GHCup.OptParse
import Utils
import Control.Monad.IO.Class
import URI.ByteString.QQ
configTests :: TestTree
configTests = testGroup "config" $ map (uncurry check) checkList
where
check :: String -> ConfigCommand -> TestTree
check args expected = testCase args $ do
res <- configParseWith (words args)
liftIO $ res @?= expected
checkList :: [(String, ConfigCommand)]
checkList =
[ ("config", ShowConfig)
, ("config init", InitConfig)
, ("config show", ShowConfig)
, ("config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
, AddReleaseChannel False [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|]
)
, ("config set cache true", SetConfig "cache" (Just "true"))
]
configParseWith :: [String] -> IO ConfigCommand
configParseWith args = do
Config a <- parseWith args
pure a

View File

@@ -1,42 +0,0 @@
module GCTest where
import Test.Tasty
import GHCup.OptParse
import Utils
gcTests :: TestTree
gcTests = buildTestTree gcParseWith ("gc", gcCheckList)
defaultOptions :: GCOptions
defaultOptions =
GCOptions
False
False
False
False
False
False
gcCheckList :: [(String, GCOptions)]
gcCheckList =
[ ("gc", defaultOptions)
, ("gc -o", defaultOptions{gcOldGHC = True})
, ("gc --ghc-old", defaultOptions{gcOldGHC = True})
, ("gc -p", defaultOptions{gcProfilingLibs = True})
, ("gc --profiling-libs", defaultOptions{gcProfilingLibs = True})
, ("gc -s", defaultOptions{gcShareDir = True})
, ("gc --share-dir", defaultOptions{gcShareDir = True})
, ("gc -h", defaultOptions{gcHLSNoGHC = True})
, ("gc --hls-no-ghc", defaultOptions{gcHLSNoGHC = True})
, ("gc -c", defaultOptions{gcCache = True})
, ("gc --cache", defaultOptions{gcCache = True})
, ("gc -t", defaultOptions{gcTmp = True})
, ("gc --tmpdirs", defaultOptions{gcTmp = True})
, ("gc -o -p -s -h -c -t", GCOptions True True True True True True)
]
gcParseWith :: [String] -> IO GCOptions
gcParseWith args = do
GC a <- parseWith args
pure a

View File

@@ -1,223 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module InstallTest where
import Test.Tasty
import GHCup.OptParse hiding (HLSCompileOptions(isolateDir))
import Utils
import GHCup.Types
import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHCup.OptParse.Install as Install
import URI.ByteString.QQ
-- Some interests:
-- install ghc *won't* select `set as activate version` as default
-- install cabal *will* select `set as activate version` as default
-- install hls *will* select `set as activate version` as default
-- install stack *will* select `set as activate version` as default
installTests :: TestTree
installTests = testGroup "install"
$ map
(buildTestTree installParseWith)
[ ("old-style", oldStyleCheckList)
, ("ghc", installGhcCheckList)
, ("cabal", installCabalCheckList)
, ("hls", installHlsCheckList)
, ("stack", installStackCheckList)
]
defaultOptions :: InstallOptions
defaultOptions = InstallOptions Nothing Nothing False Nothing False []
-- | Don't set as active version
mkInstallOptions :: ToolVersion -> InstallOptions
mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False []
-- | Set as active version
mkInstallOptions' :: ToolVersion -> InstallOptions
mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False []
oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)]
oldStyleCheckList =
("install", Right defaultOptions)
: ("install --set", Right defaultOptions{instSet = True})
: ("install --force", Right defaultOptions{forceInstall = True})
#ifdef IS_WINDOWS
: ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"})
#else
: ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"})
#endif
: ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head"
, Right defaultOptions
{ instBindist = Just [uri|https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz|]
, instVer = Just $ GHCVersion $ GHCTargetVersion Nothing (mkVersion $ (Str "head" :| []) :| [])
}
)
: mapSecond
(Right . mkInstallOptions)
[ ("install ghc-9.2", GHCVersion
$ GHCTargetVersion
(Just "ghc")
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
-- invalid
, ("install next", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "next" :| []) :| [])
)
, ("install latest", ToolTag Latest)
, ("install nightly", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "nightly" :| []) :| [])
)
, ("install recommended", ToolTag Recommended)
, ("install prerelease", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "prerelease" :| []) :| [])
)
, ("install latest-prerelease", ToolTag LatestPrerelease)
, ("install latest-nightly", ToolTag LatestNightly)
, ("install ghc-javascript-unknown-ghcjs-9.6", GHCVersion
$ GHCTargetVersion
(Just "ghc-javascript-unknown-ghcjs")
(mkVersion $ (Digits 9 :| []) :| [Digits 6 :| []])
)
, ("install base-4.18", ToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("install cabal-3.10", GHCVersion
$ GHCTargetVersion
(Just "cabal")
(mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
)
, ("install hls-2.0.0.0", GHCVersion
$ GHCTargetVersion
(Just "hls")
(mkVersion $ (Digits 2 :| []) :| [Digits 0 :| [], Digits 0 :| [], Digits 0 :| []])
)
, ("install stack-2.9.3", GHCVersion
$ GHCTargetVersion
(Just "stack")
(mkVersion $ (Digits 2 :| []) :| [Digits 9 :| [], Digits 3 :| []])
)
]
installGhcCheckList :: [(String, Either InstallCommand InstallOptions)]
installGhcCheckList =
("install ghc", Left $ InstallGHC defaultOptions)
: mapSecond (Left . InstallGHC . mkInstallOptions)
[ ("install ghc 9.2", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
, ("install ghc next", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "next" :| []) :| [])
)
, ("install ghc latest", ToolTag Latest)
, ("install ghc nightly", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "nightly" :| []) :| [])
)
, ("install ghc recommended", ToolTag Recommended)
, ("install ghc prerelease", GHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "prerelease" :| []) :| [])
)
, ("install ghc latest-prerelease", ToolTag LatestPrerelease)
, ("install ghc latest-nightly", ToolTag LatestNightly)
, ("install ghc javascript-unknown-ghcjs-9.6", GHCVersion
$ GHCTargetVersion
(Just "javascript-unknown-ghcjs")
(mkVersion $ (Digits 9 :| []) :| [Digits 6 :| []])
)
, ("install ghc base-4.18", ToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("install ghc ghc-9.2", GHCVersion
$ GHCTargetVersion
(Just "ghc")
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
]
installCabalCheckList :: [(String, Either InstallCommand InstallOptions)]
installCabalCheckList =
("install cabal", Left $ InstallCabal defaultOptions{instSet = True})
: mapSecond (Left . InstallCabal . mkInstallOptions')
[ ("install cabal 3.10", ToolVersion $ mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
, ("install cabal next", ToolVersion $ mkVersion $ (Str "next" :| []) :| [])
, ("install cabal latest", ToolTag Latest)
, ("install cabal nightly", ToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("install cabal recommended", ToolTag Recommended)
, ("install cabal prerelease", ToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("install cabal latest-prerelease", ToolTag LatestPrerelease)
, ("install cabal latest-nightly", ToolTag LatestNightly)
, ("install cabal base-4.18", ToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("install cabal cabal-3.10", ToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "cabal" :| []) :| []
, _vRel = [Digits 3 :| [], Digits 10 :| []]
, _vMeta = Nothing
}
)
]
installHlsCheckList :: [(String, Either InstallCommand InstallOptions)]
installHlsCheckList =
("install hls", Left $ InstallHLS defaultOptions{instSet = True})
: mapSecond (Left . InstallHLS . mkInstallOptions')
[ ("install hls 3.10", ToolVersion $ mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
, ("install hls next", ToolVersion $ mkVersion $ (Str "next" :| []) :| [])
, ("install hls latest", ToolTag Latest)
, ("install hls nightly", ToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("install hls recommended", ToolTag Recommended)
, ("install hls prerelease", ToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("install hls latest-prerelease", ToolTag LatestPrerelease)
, ("install hls latest-nightly", ToolTag LatestNightly)
, ("install hls base-4.18", ToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("install hls hls-2.0", ToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "hls" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 0 :| []]
, _vMeta = Nothing
}
)
]
installStackCheckList :: [(String, Either InstallCommand InstallOptions)]
installStackCheckList =
("install stack", Left $ InstallStack defaultOptions{instSet = True})
: mapSecond (Left . InstallStack . mkInstallOptions')
[ ("install stack 3.10", ToolVersion $ mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
, ("install stack next", ToolVersion $ mkVersion $ (Str "next" :| []) :| [])
, ("install stack latest", ToolTag Latest)
, ("install stack nightly", ToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("install stack recommended", ToolTag Recommended)
, ("install stack prerelease", ToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("install stack latest-prerelease", ToolTag LatestPrerelease)
, ("install stack latest-nightly", ToolTag LatestNightly)
, ("install stack base-4.18", ToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("install stack stack-2.9", ToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "stack" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 9 :| []]
, _vMeta = Nothing
}
)
]
installParseWith :: [String] -> IO (Either InstallCommand InstallOptions)
installParseWith args = do
Install a <- parseWith args
pure a

View File

@@ -1,46 +0,0 @@
module ListTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import GHCup.List
import GHCup.Types
listTests :: TestTree
listTests = buildTestTree listParseWith ("list", listCheckList)
defaultOptions :: ListOptions
defaultOptions = ListOptions Nothing Nothing Nothing Nothing False False False
listCheckList :: [(String, ListOptions)]
listCheckList =
[ ("list", defaultOptions)
, ("list -t ghc", defaultOptions{loTool = Just GHC})
, ("list -t cabal", defaultOptions{loTool = Just Cabal})
, ("list -t hls", defaultOptions{loTool = Just HLS})
, ("list -t stack", defaultOptions{loTool = Just Stack})
, ("list -c installed", defaultOptions{lCriteria = Just $ ListInstalled True})
, ("list -c +installed", defaultOptions{lCriteria = Just $ ListInstalled True})
, ("list -c -installed", defaultOptions{lCriteria = Just $ ListInstalled False})
, ("list -c set", defaultOptions{lCriteria = Just $ ListSet True})
, ("list -c +set", defaultOptions{lCriteria = Just $ ListSet True})
, ("list -c -set", defaultOptions{lCriteria = Just $ ListSet False})
, ("list -c available", defaultOptions{lCriteria = Just $ ListAvailable True})
, ("list -c +available", defaultOptions{lCriteria = Just $ ListAvailable True})
, ("list -c -available", defaultOptions{lCriteria = Just $ ListAvailable False})
, ("list -s 2023-07-22", defaultOptions{lFrom = Just $ read "2023-07-22"})
, ("list -u 2023-07-22", defaultOptions{lTo = Just $ read "2023-07-22"})
, ("list --since 2023-07-22 --until 2023-07-22", defaultOptions{lFrom = Just $ read "2023-07-22", lTo = Just $ read "2023-07-22"})
, ("list -o", defaultOptions{lHideOld = True})
, ("list --hide-old", defaultOptions{lHideOld = True})
, ("list -n", defaultOptions{lShowNightly = True})
, ("list --show-nightly", defaultOptions{lShowNightly = True})
, ("list -r", defaultOptions{lRawFormat = True})
, ("list --raw-format", defaultOptions{lRawFormat = True})
]
listParseWith :: [String] -> IO ListOptions
listParseWith args = do
List a <- parseWith args
pure a

View File

@@ -1,33 +0,0 @@
module Main where
import Test.Tasty
import qualified SetTest
import qualified OtherCommandTest
import qualified ChangeLogTest
import qualified ConfigTest
import qualified InstallTest
import qualified UnsetTest
import qualified RmTest
import qualified ListTest
import qualified UpgradeTest
import qualified CompileTest
import qualified WhereisTest
import qualified GCTest
import qualified RunTest
main :: IO ()
main = defaultMain $ testGroup "ghcup"
[ SetTest.setTests
, OtherCommandTest.otherCommandTests
, ChangeLogTest.changeLogTests
, ConfigTest.configTests
, InstallTest.installTests
, UnsetTest.unsetTests
, RmTest.rmTests
, ListTest.listTests
, UpgradeTest.upgradeTests
, CompileTest.compileTests
, WhereisTest.whereisTests
, GCTest.gcTests
, RunTest.runTests
]

View File

@@ -1,38 +0,0 @@
module OtherCommandTest where
import Test.Tasty
import Test.Tasty.HUnit
import GHCup.OptParse
import Utils
import Control.Monad.IO.Class
otherCommandTests :: TestTree
otherCommandTests = testGroup "other command"
[ testCase "debug-info" $ do
res <- parseWith ["debug-info"]
liftIO $ assertBool "debug-info parse failed" (isDInfo res)
, testCase "tool-requirements" $ do
ToolRequirements opt <- parseWith ["tool-requirements"]
liftIO $ tlrRaw opt @?= False
, testCase "tool-requirements -r" $ do
ToolRequirements opt <- parseWith ["tool-requirements", "--raw-format"]
liftIO $ tlrRaw opt @?= True
, testCase "nuke" $ do
res <- parseWith ["nuke"]
liftIO $ assertBool "nuke parse failed" (isNuke res)
, testCase "test ghc" $ do
res <- parseWith ["test", "ghc"]
liftIO $ assertBool "test parse failed" (isTest res)
]
isDInfo :: Command -> Bool
isDInfo DInfo = True
isDInfo _ = False
isNuke :: Command -> Bool
isNuke Nuke = True
isNuke _ = False
isTest :: Command -> Bool
isTest (Test _) = True
isTest _ = False

View File

@@ -1,80 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module RmTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import GHCup.Types
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Versions
rmTests :: TestTree
rmTests =
testGroup "rm"
$ map (buildTestTree rmParseWith)
[ ("old-style", oldStyleCheckList)
, ("ghc", rmGhcCheckList)
, ("cabal", rmCabalCheckList)
, ("hls", rmHlsCheckList)
, ("stack", rmStackCheckList)
]
oldStyleCheckList :: [(String, Either RmCommand RmOptions)]
oldStyleCheckList = mapSecond (Right . RmOptions)
[ -- failed with ("rm", xxx)
("rm 9.2.8", mkTVer (mkVersion $ (Digits 9 :| []) :| [Digits 2 :| [], Digits 8 :| []]))
, ("rm ghc-9.2.8", GHCTargetVersion (Just "ghc") (mkVersion $ (Digits 9 :| []) :| [Digits 2 :| [], Digits 8 :| []]))
]
rmGhcCheckList :: [(String, Either RmCommand RmOptions)]
rmGhcCheckList = mapSecond (Left . RmGHC . RmOptions)
[ -- failed with ("rm ghc", xxx)
("rm ghc 9.2.8", mkTVer (mkVersion $ (Digits 9 :| []) :| [Digits 2 :| [], Digits 8 :| []]))
, ("rm ghc ghc-9.2.8", GHCTargetVersion (Just "ghc") (mkVersion $ (Digits 9 :| []) :| [Digits 2 :| [], Digits 8 :| []]))
]
rmCabalCheckList :: [(String, Either RmCommand RmOptions)]
rmCabalCheckList = mapSecond (Left . RmCabal)
[ -- failed with ("rm cabal", xxx)
("rm cabal 3.10", mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
, ("rm cabal cabal-3.10", Version
{ _vEpoch = Nothing
, _vChunks = (Str "cabal" :| []) :| []
, _vRel = [Digits 3 :| [], Digits 10 :| []]
, _vMeta = Nothing
}
)
]
rmHlsCheckList :: [(String, Either RmCommand RmOptions)]
rmHlsCheckList = mapSecond (Left . RmHLS)
[ -- failed with ("rm hls", xxx)
("rm hls 2.0", mkVersion $ (Digits 2 :| []) :| [Digits 0 :| []])
, ("rm hls hls-2.0", Version
{ _vEpoch = Nothing
, _vChunks = (Str "hls" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 0 :| []]
, _vMeta = Nothing
}
)
]
rmStackCheckList :: [(String, Either RmCommand RmOptions)]
rmStackCheckList = mapSecond (Left . RmStack)
[ -- failed with ("rm stack", xxx)
("rm stack 2.9.1", mkVersion $ (Digits 2 :| []) :| [Digits 9 :| [], Digits 1 :| []])
, ("rm stack stack-2.9.1", Version
{ _vEpoch = Nothing
, _vChunks = (Str "stack" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 9 :| [], Digits 1 :| []]
, _vMeta = Nothing
}
)
]
rmParseWith :: [String] -> IO (Either RmCommand RmOptions)
rmParseWith args = do
Rm a <- parseWith args
pure a

View File

@@ -1,66 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module RunTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import GHCup.Types
runTests :: TestTree
runTests = buildTestTree runParseWith ("run", runCheckList)
defaultOptions :: RunOptions
defaultOptions =
RunOptions
False
False
False
Nothing
Nothing
Nothing
Nothing
Nothing
False
[]
runCheckList :: [(String, RunOptions)]
runCheckList =
[ ("run", defaultOptions)
, ("run -a", defaultOptions{runAppendPATH = True})
, ("run --append", defaultOptions{runAppendPATH = True})
, ("run -i", defaultOptions{runInstTool' = True})
, ("run --install", defaultOptions{runInstTool' = True})
, ("run -m", defaultOptions{runMinGWPath = True})
, ("run --mingw-path", defaultOptions{runMinGWPath = True})
, ("run --ghc 9.2.8", defaultOptions{runGHCVer = Just $ GHCVersion $ mkTVer $ mkVersion' "9.2.8"})
, ("run --ghc latest", defaultOptions{runGHCVer = Just $ ToolTag Latest})
, ("run --cabal 3.10", defaultOptions{runCabalVer = Just $ ToolVersion $ mkVersion' "3.10"})
, ("run --hls 2.0", defaultOptions{runHLSVer = Just $ ToolVersion $ mkVersion' "2.0"})
, ("run --stack 2.9", defaultOptions{runStackVer = Just $ ToolVersion $ mkVersion' "2.9"})
#ifdef IS_WINDOWS
, ("run -b C:\\\\tmp\\dir", defaultOptions{runBinDir = Just "C:\\\\tmp\\dir"})
, ("run --bindir C:\\\\tmp\\dir", defaultOptions{runBinDir = Just "C:\\\\tmp\\dir"})
#else
, ("run -b /tmp/dir", defaultOptions{runBinDir = Just "/tmp/dir"})
, ("run --bindir /tmp/dir", defaultOptions{runBinDir = Just "/tmp/dir"})
#endif
, ("run -q", defaultOptions{runQuick = True})
, ("run --quick", defaultOptions{runQuick = True})
, ("run --ghc latest --cabal 3.10 --stack 2.9 --hls 2.0 --install",
defaultOptions
{ runGHCVer = Just $ ToolTag Latest
, runCabalVer = Just $ ToolVersion $ mkVersion' "3.10"
, runHLSVer = Just $ ToolVersion $ mkVersion' "2.0"
, runStackVer = Just $ ToolVersion $ mkVersion' "2.9"
, runInstTool' = True
}
)
]
runParseWith :: [String] -> IO RunOptions
runParseWith args = do
Run a <- parseWith args
pure a

View File

@@ -1,176 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module SetTest where
import GHCup.OptParse
import Test.Tasty
import GHCup.Types
import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|)))
import Utils
setTests :: TestTree
setTests =
testGroup "set"
$ map
(buildTestTree setParseWith)
[ ("old-style", oldStyleCheckList)
, ("ghc", setGhcCheckList)
, ("cabal", setCabalCheckList)
, ("hls", setHlsCheckList)
, ("stack", setStackCheckList)
]
oldStyleCheckList :: [(String, Either SetCommand SetOptions)]
oldStyleCheckList = mapSecond (Right . SetOptions)
[ ("set", SetRecommended)
, ("set ghc-9.2", SetGHCVersion
$ GHCTargetVersion
(Just "ghc")
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
, ("set next", SetNext)
, ("set latest", SetToolTag Latest)
, ("set nightly", SetGHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "nightly" :| []) :| [])
)
-- different from `set`
, ("set recommended", SetToolTag Recommended)
, ("set prerelease", SetGHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "prerelease" :| []) :| [])
)
, ("set latest-prerelease", SetToolTag LatestPrerelease)
, ("set latest-nightly", SetToolTag LatestNightly)
, ("set ghc-javascript-unknown-ghcjs-9.6", SetGHCVersion
$ GHCTargetVersion
(Just "ghc-javascript-unknown-ghcjs")
(mkVersion $ (Digits 9 :| []) :| [Digits 6 :| []])
)
, ("set base-4.18", SetToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("set cabal-3.10", SetGHCVersion
$ GHCTargetVersion
(Just "cabal")
(mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
)
, ("set hls-2.0.0.0", SetGHCVersion
$ GHCTargetVersion
(Just "hls")
(mkVersion $ (Digits 2 :| []) :| [Digits 0 :| [], Digits 0 :| [], Digits 0 :| []])
)
, ("set stack-2.9.3", SetGHCVersion
$ GHCTargetVersion
(Just "stack")
(mkVersion $ (Digits 2 :| []) :| [Digits 9 :| [], Digits 3 :| []])
)
]
setGhcCheckList :: [(String, Either SetCommand SetOptions)]
setGhcCheckList = mapSecond (Left . SetGHC . SetOptions)
[ ("set ghc", SetRecommended)
, ("set ghc 9.2", SetGHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
, ("set ghc next", SetNext)
, ("set ghc latest", SetToolTag Latest)
, ("set ghc nightly", SetGHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "nightly" :| []) :| [])
)
, ("set ghc recommended", SetToolTag Recommended)
, ("set ghc prerelease", SetGHCVersion
$ GHCTargetVersion
Nothing
(mkVersion $ (Str "prerelease" :| []) :| [])
)
, ("set ghc latest-prerelease", SetToolTag LatestPrerelease)
, ("set ghc latest-nightly", SetToolTag LatestNightly)
, ("set ghc javascript-unknown-ghcjs-9.6", SetGHCVersion
$ GHCTargetVersion
(Just "javascript-unknown-ghcjs")
(mkVersion $ (Digits 9 :| []) :| [Digits 6 :| []])
)
, ("set ghc base-4.18", SetToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("set ghc ghc-9.2", SetGHCVersion
$ GHCTargetVersion
(Just "ghc")
(mkVersion $ (Digits 9 :| []) :| [Digits 2 :| []])
)
]
setCabalCheckList :: [(String, Either SetCommand SetOptions)]
setCabalCheckList = mapSecond (Left . SetCabal . SetOptions)
[ ("set cabal", SetRecommended)
, ("set cabal 3.10", SetToolVersion $ mkVersion $ (Digits 3 :| []) :| [Digits 10 :| []])
, ("set cabal next", SetNext)
, ("set cabal latest", SetToolTag Latest)
, ("set cabal nightly", SetToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("set cabal recommended", SetToolTag Recommended)
, ("set cabal prerelease", SetToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("set cabal latest-prerelease", SetToolTag LatestPrerelease)
, ("set cabal latest-nightly", SetToolTag LatestNightly)
, ("set cabal base-4.18", SetToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("set cabal cabal-3.10", SetToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "cabal" :| []) :| []
, _vRel = [Digits 3 :| [], Digits 10 :| []]
, _vMeta = Nothing
}
)
]
setHlsCheckList :: [(String, Either SetCommand SetOptions)]
setHlsCheckList = mapSecond (Left . SetHLS . SetOptions)
[ ("set hls", SetRecommended)
, ("set hls 2.0", SetToolVersion $ mkVersion $ (Digits 2 :| []) :| [Digits 0 :| []])
, ("set hls next", SetNext)
, ("set hls latest", SetToolTag Latest)
, ("set hls nightly", SetToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("set hls recommended", SetToolTag Recommended)
, ("set hls prerelease", SetToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("set hls latest-prerelease", SetToolTag LatestPrerelease)
, ("set hls latest-nightly", SetToolTag LatestNightly)
, ("set hls base-4.18", SetToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("set hls hls-2.0", SetToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "hls" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 0 :| []]
, _vMeta = Nothing
}
)
]
setStackCheckList :: [(String, Either SetCommand SetOptions)]
setStackCheckList = mapSecond (Left . SetStack . SetOptions)
[ ("set stack", SetRecommended)
, ("set stack 2.9", SetToolVersion $ mkVersion $ (Digits 2 :| []) :| [Digits 9 :| []])
, ("set stack next", SetNext)
, ("set stack latest", SetToolTag Latest)
, ("set stack nightly", SetToolVersion $ mkVersion $ (Str "nightly" :| []) :| [])
, ("set stack recommended", SetToolTag Recommended)
, ("set stack prerelease", SetToolVersion $ mkVersion $ (Str "prerelease" :| []) :| [])
, ("set stack latest-prerelease", SetToolTag LatestPrerelease)
, ("set stack latest-nightly", SetToolTag LatestNightly)
, ("set stack base-4.18", SetToolTag (Base (PVP {_pComponents = 4 :| [18]})))
, ("set stack stack-2.9", SetToolVersion
$ Version
{ _vEpoch = Nothing
, _vChunks = (Str "stack" :| []) :| []
, _vRel = [Digits 2 :| [], Digits 9 :| []]
, _vMeta = Nothing
}
)
]
setParseWith :: [String] -> IO (Either SetCommand SetOptions)
setParseWith args = do
Set a <- parseWith args
pure a

View File

@@ -1,50 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module UnsetTest where
import Test.Tasty
import GHCup.OptParse
import Utils
unsetTests :: TestTree
unsetTests =
testGroup "unset"
$ map (buildTestTree unsetParseWith)
[ ("ghc", unsetGhcCheckList)
, ("cabal", unsetCabalCheckList)
, ("hls", unsetHlsCheckList)
, ("stack", unsetStackCheckList)
]
unsetGhcCheckList :: [(String, UnsetCommand)]
unsetGhcCheckList = mapSecond (UnsetGHC . UnsetOptions)
[ ("unset ghc", Nothing)
, ("unset ghc armv7-unknown-linux-gnueabihf", Just "armv7-unknown-linux-gnueabihf")
]
unsetCabalCheckList :: [(String, UnsetCommand)]
unsetCabalCheckList = mapSecond (UnsetCabal . UnsetOptions)
[ ("unset cabal", Nothing)
-- This never used
, ("unset cabal armv7-unknown-linux-gnueabihf", Just "armv7-unknown-linux-gnueabihf")
]
unsetHlsCheckList :: [(String, UnsetCommand)]
unsetHlsCheckList = mapSecond (UnsetHLS . UnsetOptions)
[ ("unset hls", Nothing)
-- This never used
, ("unset hls armv7-unknown-linux-gnueabihf", Just "armv7-unknown-linux-gnueabihf")
]
unsetStackCheckList :: [(String, UnsetCommand)]
unsetStackCheckList = mapSecond (UnsetStack . UnsetOptions)
[ ("unset stack", Nothing)
-- This never used
, ("unset stack armv7-unknown-linux-gnueabihf", Just "armv7-unknown-linux-gnueabihf")
]
unsetParseWith :: [String] -> IO UnsetCommand
unsetParseWith args = do
UnSet a <- parseWith args
pure a

View File

@@ -1,38 +0,0 @@
{-# LANGUAGE TupleSections #-}
module UpgradeTest where
import Test.Tasty
import GHCup.OptParse
import Utils
upgradeTests :: TestTree
upgradeTests = buildTestTree upgradeParseWith ("upgrade", upgradeCheckList)
type FullUpgradeOpts =
( UpgradeOpts
, Bool -- ^Force update
, Bool -- ^Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)
)
mkDefaultOptions :: UpgradeOpts -> FullUpgradeOpts
mkDefaultOptions = (, False, False)
upgradeCheckList :: [(String, FullUpgradeOpts)]
upgradeCheckList =
[ ("upgrade", mkDefaultOptions UpgradeGHCupDir)
, ("upgrade -f", (UpgradeGHCupDir, True, False))
, ("upgrade --force", (UpgradeGHCupDir, True, False))
, ("upgrade --fail-if-shadowed", (UpgradeGHCupDir, False, True))
, ("upgrade -i", mkDefaultOptions UpgradeInplace)
, ("upgrade --inplace", mkDefaultOptions UpgradeInplace)
, ("upgrade -t ~", mkDefaultOptions $ UpgradeAt "~")
, ("upgrade --target ~", mkDefaultOptions $ UpgradeAt "~")
, ("upgrade -t ~ -f", (UpgradeAt "~", True, False))
]
upgradeParseWith :: [String] -> IO FullUpgradeOpts
upgradeParseWith args = do
Upgrade a b c <- parseWith args
pure (a, b, c)

View File

@@ -1,45 +0,0 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Utils where
import GHCup.OptParse as GHCup
import Options.Applicative
import Data.Bifunctor
import Data.Versions
import Data.List.NonEmpty (NonEmpty)
import Test.Tasty
import Test.Tasty.HUnit
import Control.Monad.IO.Class
import qualified Data.Text as T
parseWith :: [String] -> IO Command
parseWith args =
optCommand <$> handleParseResult
(execParserPure defaultPrefs (info GHCup.opts fullDesc) args)
padLeft :: Int -> String -> String
padLeft desiredLength s = padding ++ s
where padding = replicate (desiredLength - length s) ' '
mapSecond :: (b -> c) -> [(a,b)] -> [(a,c)]
mapSecond = map . second
mkVersion :: NonEmpty VChunk -> Version
mkVersion chunks = Version Nothing chunks [] Nothing
mkVersion' :: T.Text -> Version
mkVersion' txt =
let Right ver = version txt
in ver
buildTestTree
:: (Eq a, Show a)
=> ([String] -> IO a) -- ^ The parse function
-> (String, [(String, a)]) -- ^ The check list @(test group, [(cli command, expected value)])@
-> TestTree
buildTestTree parse (title, checkList) =
testGroup title
$ zipWith (uncurry . check) [1 :: Int ..] checkList
where
check idx args expected = testCase (padLeft 2 (show idx) ++ "." ++ args) $ do
res <- parse (words args)
liftIO $ res @?= expected

View File

@@ -1,40 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module WhereisTest where
import Test.Tasty
import GHCup.OptParse
import Utils
import GHCup.Types
whereisTests :: TestTree
whereisTests = buildTestTree whereisParseWith ("whereis", whereisCheckList)
whereisCheckList :: [(String, (WhereisOptions, WhereisCommand))]
whereisCheckList = concatMap mk
[ ("whereis ghc", WhereisTool GHC Nothing)
, ("whereis ghc 9.2.8", WhereisTool GHC (Just $ GHCVersion $ mkTVer $ mkVersion' "9.2.8"))
, ("whereis ghc ghc-9.2.8", WhereisTool GHC (Just $ GHCVersion $ GHCTargetVersion (Just "ghc") (mkVersion' "9.2.8")))
, ("whereis ghc latest", WhereisTool GHC (Just $ ToolTag Latest))
, ("whereis cabal", WhereisTool Cabal Nothing)
, ("whereis hls", WhereisTool HLS Nothing)
, ("whereis stack", WhereisTool Stack Nothing)
, ("whereis ghcup", WhereisTool GHCup Nothing)
, ("whereis basedir", WhereisBaseDir)
, ("whereis bindir", WhereisBinDir)
, ("whereis cachedir", WhereisCacheDir)
, ("whereis logsdir", WhereisLogsDir)
, ("whereis confdir", WhereisConfDir)
]
where
mk :: (String, WhereisCommand) -> [(String, (WhereisOptions, WhereisCommand))]
mk (cmd, res) =
[ (cmd, (WhereisOptions False, res))
, (cmd <> " -d", (WhereisOptions True, res))
, (cmd <> " --directory", (WhereisOptions True, res))
]
whereisParseWith :: [String] -> IO (WhereisOptions, WhereisCommand)
whereisParseWith args = do
Whereis a b <- parseWith args
pure (a, b)