Fix recursive deletion in ghcup nuke

This also installs makefile based build system via DESTDIR
into a temporary directory and then merges it into the filesystem.

.gitlab-ci.yml

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

.gitlab/ghcup_env

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

.gitlab/script/brew.sh

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

.gitlab/script/ci.sh

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

.gitlab/script/ghcup_version.sh

@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/usr/bin/env bash
 
 set -eux
 
@@ -8,6 +8,7 @@ mkdir -p "$CI_PROJECT_DIR"/.local/bin
 
 CI_PROJECT_DIR=$(pwd)
 
+
 ecabal() {
 	cabal "$@"
 }
@@ -34,6 +35,8 @@ git describe --always
 
 ### build
 
+rm -rf "${GHCUP_DIR}"/share
+
 ecabal update
 
 if [ "${OS}" = "DARWIN" ] ; then
@@ -94,16 +97,17 @@ rm -rf "${GHCUP_DIR}"
 eghcup --numeric-version
 
 eghcup install ghc ${GHC_VERSION}
-[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
+ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})"
-[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ]
+[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
+[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
 eghcup set ghc ${GHC_VERSION}
 eghcup install cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
+[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
 eghcup unset cabal
-"$GHCUP_BIN"/cabal --version && exit || echo yes
+"$GHCUP_BIN"/cabal --version && exit 1 || echo yes
 eghcup set cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
+[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
-[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ]
+[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
 
 if [ "${OS}" != "FREEBSD" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
@@ -170,12 +174,14 @@ else
 	eghcup set ${GHC_VERSION}
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 	eghcup unset ghc
-    "$GHCUP_BIN"/ghc --numeric-version && exit || echo yes
+    "$GHCUP_BIN"/ghc --numeric-version && exit 1 || echo yes
 	eghcup set ${GHC_VERSION}
 	eghcup --offline rm 8.10.3
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 
 
+	ls -lah "$GHCUP_BIN"
+
 	if [ "${OS}" = "DARWIN" ] ; then
 		eghcup install hls
 		$(eghcup whereis hls) --version
@@ -187,12 +193,12 @@ else
 			eghcup install hls
 			haskell-language-server-wrapper --version
 			eghcup unset hls
-			"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes
+			"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit 1 || echo yes
 
 			eghcup install stack
 			stack --version
-			eghcup unset hls
+			eghcup unset stack
-			"$GHCUP_BIN"/stack --version && exit || echo yes
+			"$GHCUP_BIN"/stack --version && exit 1 || echo yes
 		fi
 	fi
 fi
@@ -215,6 +221,8 @@ if [ "${OS}" = "LINUX" ] ; then
 	fi
 fi
 
+eghcup gc -c
+
 sha_sum() {
 	if [ "${OS}" = "FREEBSD" ] ; then
 		sha256 "$@"
@@ -262,6 +270,19 @@ if [ "${ARCH}" = "64" ] ; then
 		eghcup install hls -i "$(pwd)/isolated" 1.3.0
 		[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] ||
 			[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ]
+
+		# test that isolated installs don't clean up target directory
+		cat <<EOF > "${GHCUP_BIN}/gmake"
+#!/bin/bash
+exit 1
+EOF
+		chmod +x "${GHCUP_BIN}/gmake"
+		mkdir isolated_tainted/
+		touch isolated_tainted/lol
+
+		! eghcup install ghc -i "$(pwd)/isolated_tainted" 8.10.5 --force
+		[ -e "$(pwd)/isolated_tainted/lol" ]
+		rm "${GHCUP_BIN}/gmake"
 	fi
 fi
 

.hlint.yaml

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

CHANGELOG.md

@@ -1,10 +1,35 @@
 # Revision history for ghcup
 
+## 0.1.17.8 -- 2022-05-11
+
+* Fix a serious (but hard to trigger) bug when combining `--isolate <DIR>` with `--force`, please make sure to upgrade or avoid `--force`
+* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361)
+* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353)
+* Re-enable upgrade functionality for all configurations wrt [MR #250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250) and [VSCode haskell issue #601](https://github.com/haskell/vscode-haskell/issues/601)
+* Fix `ghcup run --ghc 8.10` (for short versions) wrt [#360](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/360)
+    - this also introduces a `--quick` switch for `ghcup run`
+
+## 0.1.17.7 -- 2022-04-21
+
+* Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345)
+
+## 0.1.17.6 -- 2022-03-18
+
+* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
+* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
+* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)
+* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)
+* Fix bug with isolated installation of not previously installed versions
+* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)
+* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`
+* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)
+* Fix max path issues on windows with `ghcup run`
+
 ## 0.1.17.5 -- 2022-02-26
 
 * Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137)
 * Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)
-* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/311)
+* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/311)
 * Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson
 * Fix redundant upgrade warnings in `ghcup upgrade`
 * Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)

app/ghcup/BrickMain.hs

@@ -44,7 +44,6 @@ import           Data.Vector                    ( Vector
 import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( appendFile )
-import           System.Directory               ( canonicalizePath )
 import           System.FilePath
 import           System.Exit
 import           System.IO.Unsafe
@@ -437,6 +436,8 @@ install' _ (_, ListResult {..}) = do
               , TarDirDoesNotExist
               , FileAlreadyExistsError
               , ProcessError
+              , GHCupShadowed
+              , UninstallFailed
               ]
 
   run (do
@@ -446,19 +447,19 @@ install' _ (_, ListResult {..}) = do
       case lTool of
         GHC   -> do
           let vi = getVersionInfo lVer GHC dls
-          liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)
+          liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce)
         Cabal -> do
           let vi = getVersionInfo lVer Cabal dls
-          liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
+          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
         GHCup -> do
           let vi = snd <$> getLatest dls GHCup
-          liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
+          liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
         HLS   -> do
           let vi = getVersionInfo lVer HLS dls
-          liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)
+          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
         Stack -> do
           let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)
+          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
     )
     >>= \case
           VRight (vi, Dirs{..}, Just ce) -> do
@@ -511,7 +512,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
 del' _ (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
-  let run = runE @'[NotInstalled]
+  let run = runE @'[NotInstalled, UninstallFailed]
 
   run (do
       let vi = getVersionInfo lVer lTool dls

app/ghcup/GHCup/OptParse.hs

@@ -96,9 +96,9 @@ data Command
   | Config ConfigCommand
   | Whereis WhereisOptions WhereisCommand
 #ifndef DISABLE_UPGRADE
-  | Upgrade UpgradeOpts Bool
+  | Upgrade UpgradeOpts Bool Bool
 #endif
-  | ToolRequirements
+  | ToolRequirements ToolReqOpts
   | ChangeLog ChangeLogOptions
   | Nuke
 #if defined(BRICK)
@@ -113,8 +113,8 @@ data Command
 opts :: Parser Options
 opts =
   Options
-    <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
+    <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
-    <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
+    <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
     <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
     <*> optional
           (option
@@ -124,9 +124,10 @@ opts =
             <> metavar "URL"
             <> help "Alternative ghcup download info url"
             <> internal
+            <> completer fileUri
             )
           )
-    <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
+    <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
     <*> optional (option
           (eitherReader keepOnParser)
           (  long "keep"
@@ -134,6 +135,7 @@ opts =
           <> help
                "Keep build directories? (default: errors)"
           <> hidden
+          <> completer (listCompleter ["always", "errors", "never"])
           ))
     <*> optional (option
           (eitherReader downloaderParser)
@@ -142,20 +144,23 @@ opts =
           <> metavar "<internal|curl|wget>"
           <> help
           "Downloader to use (default: internal)"
+          <> completer (listCompleter ["internal", "curl", "wget"])
 #else
           <> metavar "<curl|wget>"
           <> help
           "Downloader to use (default: curl)"
+          <> completer (listCompleter ["curl", "wget"])
 #endif
           <> hidden
           ))
-    <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
+    <*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.")
     <*> optional (option
           (eitherReader gpgParser)
           (  long "gpg"
           <> metavar "<strict|lax|none>"
           <> help
           "GPG verification (default: none)"
+          <> completer (listCompleter ["strict", "lax", "none"])
           ))
     <*> com
  where
@@ -217,18 +222,18 @@ com =
            (info (List <$> listOpts <**> helper)
                  (progDesc "Show available GHCs and other tools")
            )
-#ifndef DISABLE_UPGRADE
       <> command
            "upgrade"
            (info
              (    (Upgrade <$> upgradeOptsP <*> switch
                     (short 'f' <> long "force" <> help "Force update")
+                    <*> switch
+                    (long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")
                   )
              <**> helper
              )
              (progDesc "Upgrade ghcup")
            )
-#endif
       <> command
            "compile"
            (   Compile
@@ -284,8 +289,8 @@ com =
               ((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
           <> command
                "tool-requirements"
-               (   (\_ -> ToolRequirements)
+               (   ToolRequirements
-               <$> info helper
+               <$> info (toolReqP <**> helper)
                         (progDesc "Show the requirements for ghc/cabal")
                )
           <> command

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -76,6 +76,7 @@ changelogP =
             )
             (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
               "Open changelog for given tool (default: ghc)"
+              <> completer toolCompleter
             )
           )
     <*> optional (toolVersionArgument Nothing Nothing)

app/ghcup/GHCup/OptParse/Common.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NumericUnderscores #-}
 
 module GHCup.OptParse.Common where
 
@@ -14,36 +16,54 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
+import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
 
+import           Control.DeepSeq
+import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
 import           Control.Monad.Reader
+import           Data.Aeson
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key    as KM
+import qualified Data.Aeson.KeyMap as KM
+#else
+import qualified Data.HashMap.Strict as KM
+#endif
+import           Data.ByteString.Lazy           ( ByteString )
 import           Data.Bifunctor
 import           Data.Char
 import           Data.Either
 import           Data.Functor
-import           Data.List                      ( nub, sort, sortBy )
+import           Data.List                      ( nub, sort, sortBy, isPrefixOf, stripPrefix )
 import           Data.Maybe
 import           Data.Text                      ( Text )
 import           Data.Versions           hiding ( str )
 import           Data.Void
+import qualified Data.Vector      as V
+import           GHC.IO.Exception
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           Safe
+import           System.Process                  ( readProcess )
 import           System.FilePath
+import           Text.HTML.TagSoup       hiding ( Tag )
 import           URI.ByteString
 
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
+import qualified System.FilePath.Posix         as FP
 import GHCup.Version
+import Control.Exception (evaluate)
 
 
     -------------
@@ -117,7 +137,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
 -- the help is shown only for --no-recursive.
 invertableSwitch
     :: String              -- ^ long option
-    -> Char                -- ^ short option for the non-default option
+    -> Maybe Char          -- ^ short option for the non-default option
     -> Bool                -- ^ is switch enabled by default?
     -> Mod FlagFields Bool -- ^ option modifier
     -> Parser (Maybe Bool)
@@ -128,14 +148,14 @@ invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shorto
 -- | Allows providing option modifiers for both --foo and --no-foo.
 invertableSwitch'
     :: String              -- ^ long option (eg "foo")
-    -> Char                -- ^ short option for the non-default option
+    -> Maybe Char          -- ^ short option for the non-default option
     -> Bool                -- ^ is switch enabled by default?
     -> Mod FlagFields Bool -- ^ option modifier for --foo
     -> Mod FlagFields Bool -- ^ option modifier for --no-foo
     -> Parser (Maybe Bool)
 invertableSwitch' longopt shortopt defv enmod dismod = optional
-    ( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt)
+    ( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt)
-    <|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
+    <|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty)
     )
   where
     nolongopt = "no-" ++ longopt
@@ -277,6 +297,126 @@ gpgParser s' | t == T.pack "strict" = Right GPGStrict
     --[ Completers ]--
     ------------------
 
+
+toolCompleter :: Completer
+toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
+
+gitFileUri :: [String] -> Completer
+gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
+
+fileUri :: Completer
+fileUri = mkCompleter $ fileUri' []
+
+fileUri' :: [String] -> String -> IO [String]
+fileUri' add = \case
+  "" -> do
+    pwd <- getCurrentDirectory
+    pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add
+  xs
+   | "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>
+      case stripPrefix "file://" xs of
+        Nothing -> pure []
+        Just r ->  do
+          pwd <- getCurrentDirectory
+          dirs  <- compgen "directory" r ["-S", "/"]
+          files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []
+          pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])
+   | xs `isPrefixOf` "file:///" -> pure ["file:///"]
+   | xs `isPrefixOf` "https://" -> pure ["https://"]
+   | xs `isPrefixOf` "http://"  -> pure ["http://"]
+   | otherwise -> pure []
+ where
+  compgen :: String -> String -> [String] -> IO [String]
+  compgen action' r opts = do
+    let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]
+    result <- tryIO $ readProcess "bash" ["-c", cmd] ""
+    return . lines . either (const []) id $ result
+
+  -- | Strongly quote the string we pass to compgen.
+  --
+  -- We need to do this so bash doesn't expand out any ~ or other
+  -- chars we want to complete on, or emit an end of line error
+  -- when seeking the close to the quote.
+  -- 
+  -- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote
+  requote :: String -> String
+  requote s =
+    let
+      -- Bash doesn't appear to allow "mixed" escaping
+      -- in bash completions. So we don't have to really
+      -- worry about people swapping between strong and
+      -- weak quotes.
+      unescaped =
+        case s of
+          -- It's already strongly quoted, so we
+          -- can use it mostly as is, but we must
+          -- ensure it's closed off at the end and
+          -- there's no single quotes in the
+          -- middle which might confuse bash.
+          ('\'': rs) -> unescapeN rs
+
+          -- We're weakly quoted.
+          ('"': rs)  -> unescapeD rs
+
+          -- We're not quoted at all.
+          -- We need to unescape some characters like
+          -- spaces and quotation marks.
+          elsewise   -> unescapeU elsewise
+    in
+      strong unescaped
+
+    where
+      strong ss = '\'' : foldr go "'" ss
+        where
+          -- If there's a single quote inside the
+          -- command: exit from the strong quote and
+          -- emit it the quote escaped, then resume.
+          go '\'' t = "'\\''" ++ t
+          go h t    = h : t
+
+      -- Unescape a strongly quoted string
+      -- We have two recursive functions, as we
+      -- can enter and exit the strong escaping.
+      unescapeN = goX
+        where
+          goX ('\'' : xs) = goN xs
+          goX (x : xs) = x : goX xs
+          goX [] = []
+
+          goN ('\\' : '\'' : xs) = '\'' : goN xs
+          goN ('\'' : xs) = goX xs
+          goN (x : xs) = x : goN xs
+          goN [] = []
+
+      -- Unescape an unquoted string
+      unescapeU = goX
+        where
+          goX [] = []
+          goX ('\\' : x : xs) = x : goX xs
+          goX (x : xs) = x : goX xs
+
+      -- Unescape a weakly quoted string
+      unescapeD = goX
+        where
+          -- Reached an escape character
+          goX ('\\' : x : xs)
+            -- If it's true escapable, strip the
+            -- slashes, as we're going to strong
+            -- escape instead.
+            | x `elem` ("$`\"\\\n" :: String) = x : goX xs
+            | otherwise = '\\' : x : goX xs
+          -- We've ended quoted section, so we
+          -- don't recurse on goX, it's done.
+          goX ('"' : xs)
+            = xs
+          -- Not done, but not a special character
+          -- just continue the fold.
+          goX (x : xs)
+            = x : goX xs
+          goX []
+            = []
+
+
 tagCompleter :: Tool -> [String] -> Completer
 tagCompleter tool add = listIOCompleter $ do
   dirs' <- liftIO getAllDirs
@@ -334,6 +474,150 @@ versionCompleter criteria tool = listIOCompleter $ do
       return $ T.unpack . prettyVer . lVer <$> installedVersions
 
 
+toolDlCompleter :: Tool -> Completer
+toolDlCompleter tool = mkCompleter $ \case
+  "" -> pure (initUrl tool <> ["https://", "http://", "file:///"])
+  word
+    | "file://" `isPrefixOf` word -> fileUri' [] word
+    -- downloads.haskell.org
+    | "https://downloads.haskell.org/" `isPrefixOf` word ->
+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word
+
+    -- github releases
+    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
+    , let xs = splitPath word
+    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
+        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"
+    | "https://github.com/commercialhaskell/stack/releases/download/" == word
+    , let xs = splitPath word
+    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
+        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"
+
+    -- github release assets
+    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
+    , let xs = splitPath word
+    , (length xs == 7 && last word == '/') || length xs == 8
+    , let rel = xs !! 6
+    , length rel > 1 -> do
+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)
+    | "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word
+    , let xs = splitPath word
+    , (length xs == 7 && last word == '/') || length xs == 8
+    , let rel = xs !! 6
+    , length rel > 1 -> do
+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)
+
+    -- github
+    | "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
+    | "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
+    | "https://g" `isPrefixOf` word
+    , tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
+    | "https://g" `isPrefixOf` word
+    , tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
+
+    | "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool
+
+    | "h" `isPrefixOf` word -> pure $ initUrl tool
+
+    | word `isPrefixOf` "file:///" -> pure ["file:///"]
+    | word `isPrefixOf` "https://" -> pure ["https://"]
+    | word `isPrefixOf` "http://"  -> pure ["http://"]
+
+    | otherwise -> pure []
+ where
+  initUrl :: Tool -> [String]
+  initUrl GHC   = [ "https://downloads.haskell.org/~ghc/"
+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"
+                  ]
+  initUrl Cabal = [ "https://downloads.haskell.org/~cabal/"
+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"
+                  ]
+  initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ]
+  initUrl HLS   = [ "https://github.com/haskell/haskell-language-server/releases/download/"
+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"
+                  ]
+  initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/"
+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"
+                  ]
+
+  completePrefix :: String -- ^ url, e.g.    'https://github.com/haskell/haskell-languag'
+                 -> String -- ^ match, e.g.  'haskell-language-server'
+                 -> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'
+  completePrefix url match =
+    let base = FP.takeDirectory url
+        fn   = FP.takeFileName url
+    in if fn `isPrefixOf` match then base <> "/" <> match else url
+
+  prefixMatch :: String -> [String] -> [String]
+  prefixMatch pref = filter (pref `isPrefixOf`)
+
+  fromHRef :: String -> IO [String]
+  fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->
+      pure
+        . fmap (T.unpack . decUTF8Safe' . fromAttrib "href")
+        . filter isTagOpen
+        . filter (~== ("<a href>" :: String))
+        . parseTags
+        $ stdout
+
+  withCurl :: String                      -- ^ url
+           -> Int                         -- ^ delay
+           -> (ByteString -> IO [String]) -- ^ callback
+           -> IO [String]
+  withCurl url delay cb = do
+    let limit = threadDelay delay
+    race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case
+      Right (CapturedProcess {_exitCode, _stdOut}) -> do
+        case _exitCode of
+          ExitSuccess ->
+            (try @_ @SomeException . cb $ _stdOut) >>= \case
+              Left _ ->  pure []
+              Right r' -> do
+                r <- try @_ @SomeException
+                  . evaluate
+                  . force
+                  $ r'
+                either (\_ -> pure []) pure r
+          ExitFailure _ -> pure []
+      Left _ -> pure []
+
+  getGithubReleases :: String
+                    -> String
+                    -> IO [String]
+  getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do
+    Just xs <- pure $ decode' @Array stdout
+    fmap V.toList $ forM xs $ \x -> do
+      (Object r) <- pure x
+      Just (String name) <- pure $ KM.lookup (mkval "tag_name") r
+      pure $ T.unpack name
+   where
+    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"
+
+  getGithubAssets :: String
+                  -> String
+                  -> String
+                  -> IO [String]
+  getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do
+    Just xs <- pure $ decode' @Object stdout
+    Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs
+    as <- fmap V.toList $ forM assets $ \val -> do
+      (Object asset) <- pure val
+      Just (String name) <- pure $ KM.lookup (mkval "name") asset
+      pure $ T.unpack name
+    pure as
+   where
+    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag
+
+
+#if MIN_VERSION_aeson(2,0,0)
+  mkval = KM.fromString
+#else
+  mkval = id
+#endif
+
+
+
+
 
 
     -----------------

app/ghcup/GHCup/OptParse/Compile.hs

@@ -99,7 +99,7 @@ data HLSCompileOptions = HLSCompileOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 compileP :: Parser CompileCommand
 compileP = subparser
   (  command
@@ -165,6 +165,7 @@ ghcCompileOpts =
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
             "The tool version to compile"
+            <> (completer $ versionCompleter Nothing GHC)
           )
           ) <|>
           (Right <$> (GitBranch <$> option
@@ -172,7 +173,10 @@ ghcCompileOpts =
           (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
             "The git commit/branch/ref to build from"
           ) <*>
-          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
+          optional (option str (
+            short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
+            <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
+            ))
           )))
     <*> option
           (eitherReader
@@ -185,12 +189,14 @@ ghcCompileOpts =
           <> metavar "BOOTSTRAP_GHC"
           <> help
                "The GHC version (or full path) to bootstrap with (must be installed)"
+          <> (completer $ versionCompleter Nothing GHC)
           )
     <*> optional
           (option
             (eitherReader (readEither @Int))
             (short 'j' <> long "jobs" <> metavar "JOBS" <> help
               "How many jobs to use for make"
+              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
             )
           )
     <*> optional
@@ -198,6 +204,7 @@ ghcCompileOpts =
             str
             (short 'c' <> long "config" <> metavar "CONFIG" <> help
               "Absolute path to build config file"
+             <> completer (bashCompleter "file")
             )
           )
     <*> (optional
@@ -206,6 +213,7 @@ ghcCompileOpts =
               (eitherReader uriParser)
               (long "patch" <> metavar "PATCH_URI" <> help
                 "URI to a patch (https/http/file)"
+               <> completer fileUri
               )
             )
             <|>
@@ -213,6 +221,7 @@ ghcCompileOpts =
               str
               (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
                 "Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"
+               <> completer (bashCompleter "directory")
               )
             )
           )
@@ -225,12 +234,7 @@ ghcCompileOpts =
             )
           )
     <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
-    <*> flag
+    <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
-          False
-          True
-          (long "set" <> help
-            "Set as active version after install"
-          )
     <*> optional
           (option
             (eitherReader
@@ -238,6 +242,7 @@ ghcCompileOpts =
             )
             (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            <> (completer $ versionCompleter Nothing GHC)
             )
           )
     <*> optional
@@ -257,6 +262,7 @@ ghcCompileOpts =
             <> long "isolate"
             <> metavar "DIR"
             <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
+            <> completer (bashCompleter "directory")
             )
            )
 
@@ -269,6 +275,7 @@ hlsCompileOpts =
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
             "The tool version to compile"
+            <> (completer $ versionCompleter Nothing HLS)
           )
           ) <|>
           (Right <$> (GitBranch <$> option
@@ -276,21 +283,19 @@ hlsCompileOpts =
           (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
             "The git commit/branch/ref to build from"
           ) <*>
-          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
+            <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
+          ))
           )))
     <*> optional
           (option
             (eitherReader (readEither @Int))
             (short 'j' <> long "jobs" <> metavar "JOBS" <> help
               "How many jobs to use for make"
+              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
             )
           )
-    <*> flag
+    <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
-          False
-          True
-          (long "set" <> help
-            "Set as active version after install"
-          )
     <*> optional
           (option
             (eitherReader
@@ -298,6 +303,7 @@ hlsCompileOpts =
             )
             (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            <> (completer $ versionCompleter Nothing HLS)
             )
           )
     <*> optional
@@ -307,6 +313,7 @@ hlsCompileOpts =
             <> long "isolate"
             <> metavar "DIR"
             <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
+            <> completer (bashCompleter "directory")
             )
            )
     <*> optional
@@ -314,6 +321,7 @@ hlsCompileOpts =
             ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
             (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
               "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
+              <> completer fileUri
             )
           )
     <*> optional
@@ -321,6 +329,7 @@ hlsCompileOpts =
             (eitherReader uriParser)
             (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
               "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
+              <> completer fileUri
             )
           )
     <*> (optional
@@ -329,6 +338,7 @@ hlsCompileOpts =
               (eitherReader uriParser)
               (long "patch" <> metavar "PATCH_URI" <> help
                 "URI to a patch (https/http/file)"
+              <> completer fileUri
               )
             )
             <|>
@@ -336,6 +346,7 @@ hlsCompileOpts =
               str
               (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
                 "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              <> completer (bashCompleter "directory")
               )
             )
           )
@@ -377,6 +388,7 @@ type GHCEffects = '[ AlreadyInstalled
                   , ProcessError
                   , CopyError
                   , BuildFailed
+                  , UninstallFailed
                   ]
 type HLSEffects = '[ AlreadyInstalled
                   , BuildFailed
@@ -395,6 +407,7 @@ type HLSEffects = '[ AlreadyInstalled
                   , NotInstalled
                   , DirNotEmpty
                   , ArchiveResult
+                  , UninstallFailed
                   ]
 
 
@@ -458,7 +471,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     ghcs
                     jobs
                     ovewrwiteVer
-                    isolateDir
+                    (maybe GHCupInternal IsolateDir isolateDir)
                     cabalProject
                     cabalProjectLocal
                     patches
@@ -481,7 +494,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                 case keepDirs settings of
                   Never -> runLogger $ logError $ T.pack $ prettyShow err
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
+                        "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9
@@ -513,7 +526,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     addConfArgs
                     buildFlavour
                     hadrian
-                    isolateDir
+                    (maybe GHCupInternal IsolateDir isolateDir)
         GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
         let vi = getVersionInfo (_tvVersion targetVer) GHC dls
         when setCompile $ void $ liftE $
@@ -530,17 +543,17 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                 pure ExitSuccess
               VLeft (V (AlreadyInstalled _ v)) -> do
                 runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
+                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
                 pure ExitSuccess
               VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logWarn $
+                runLogger $ logError $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger $ logError $ T.pack $ prettyShow err
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
+                        "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9

app/ghcup/GHCup/OptParse/Config.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 module GHCup.OptParse.Config where
 
@@ -17,6 +18,7 @@ import           GHCup.Utils
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.Logger
 import           GHCup.Utils.String.QQ
+import           GHCup.OptParse.Common
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -27,10 +29,11 @@ import           Control.Monad.Trans.Resource
 import           Data.Functor
 import           Data.Maybe
 import           Haskus.Utils.Variant.Excepts
-import           Options.Applicative     hiding ( style )
+import           Options.Applicative     hiding ( style, ParseError )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           URI.ByteString          hiding ( uriParser )
 
 import qualified Data.Text                     as T
 import qualified Data.ByteString.UTF8          as UTF8
@@ -49,6 +52,7 @@ data ConfigCommand
   = ShowConfig
   | SetConfig String (Maybe String)
   | InitConfig
+  | AddReleaseChannel URI
 
 
 
@@ -62,6 +66,7 @@ configP = subparser
       (  command "init" initP
       <> command "set"  setP -- [set] KEY VALUE at help lhs
       <> command "show" showP
+      <> command "add-release-channel" addP
       )
     <|> argsP -- add show for a single option
     <|> pure ShowConfig
@@ -70,6 +75,8 @@ configP = subparser
   showP = info (pure ShowConfig) (progDesc "Show current config (default)")
   setP  = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
   argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
+  addP  = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
+    (progDesc "Add a release channel from a URI")
 
 
 
@@ -114,23 +121,18 @@ formatConfig :: UserSettings -> String
 formatConfig = UTF8.toString . Y.encode
 
 
-updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
+updateSettings :: UserSettings -> Settings -> Settings
-updateSettings config' settings = do
+updateSettings UserSettings{..} Settings{..} =
-  settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'
+   let cache'      = fromMaybe cache uCache
-  pure $ mergeConf settings' settings
+       metaCache'  = fromMaybe metaCache uMetaCache
-  where
+       noVerify'   = fromMaybe noVerify uNoVerify
-   mergeConf :: UserSettings -> Settings -> Settings
+       keepDirs'   = fromMaybe keepDirs uKeepDirs
-   mergeConf UserSettings{..} Settings{..} =
+       downloader' = fromMaybe downloader uDownloader
-     let cache'      = fromMaybe cache uCache
+       verbose'    = fromMaybe verbose uVerbose
-         metaCache'  = fromMaybe metaCache uMetaCache
+       urlSource'  = fromMaybe urlSource uUrlSource
-         noVerify'   = fromMaybe noVerify uNoVerify
+       noNetwork'  = fromMaybe noNetwork uNoNetwork
-         keepDirs'   = fromMaybe keepDirs uKeepDirs
+       gpgSetting' = fromMaybe gpgSetting uGPGSetting
-         downloader' = fromMaybe downloader uDownloader
+   in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
-         verbose'    = fromMaybe verbose uVerbose
-         urlSource'  = fromMaybe urlSource uUrlSource
-         noNetwork'  = fromMaybe noNetwork uNoNetwork
-         gpgSetting' = fromMaybe gpgSetting uGPGSetting
-     in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
 
 
 
@@ -140,7 +142,7 @@ updateSettings config' settings = do
 
 
 
-config :: ( Monad m
+config :: forall m. ( Monad m
           , MonadMask m
           , MonadUnliftIO m
           , MonadFail m
@@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
     liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
     pure ExitSuccess
 
-  (SetConfig k (Just v)) ->
+  (SetConfig k mv) -> do
-    case v of
+    r <- runE @'[JSONError, ParseError] $ do
-      "" -> do
+      case mv of
-        runLogger $ logError "Empty values are not allowed"
+        Just "" ->
-        pure $ ExitFailure 55
+          throwE $ ParseError "Empty values are not allowed"
-      _  -> doConfig (k <> ": " <> v <> "\n")
+        Nothing -> do
+          usersettings <- decodeSettings k
+          lift $ doConfig usersettings
+          pure ()
+        Just v -> do
+          usersettings <- decodeSettings (k <> ": " <> v <> "\n")
+          lift $ doConfig usersettings
+          pure ()
+    case r of
+      VRight _ -> pure ExitSuccess
+      VLeft (V (JSONDecodeError e)) -> do
+        runLogger $ logError $ "Error decoding config: " <> T.pack e
+        pure $ ExitFailure 65
+      VLeft _ -> pure $ ExitFailure 65
 
-  (SetConfig json Nothing) -> doConfig json
+  AddReleaseChannel uri -> do
+    case urlSource settings of
+      AddSource xs -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
+        pure ExitSuccess
+      _ -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
+        pure ExitSuccess
 
  where
-  doConfig val = do
+  doConfig :: MonadIO m => UserSettings -> m ()
-    r <- runE @'[JSONError] $ do
+  doConfig usersettings = do
-      settings' <- updateSettings (UTF8.fromString val) settings
+    let settings' = updateSettings usersettings settings
-      path <- liftIO getConfigFilePath
+    path <- liftIO getConfigFilePath
-      liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
+    liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
-      lift $ runLogger $ logDebug $ T.pack $ show settings'
+    runLogger $ logDebug $ T.pack $ show settings'
-      pure ()
+    pure ()
 
-    case r of
+  decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
-        VRight _ -> pure ExitSuccess
-        VLeft (V (JSONDecodeError e)) -> do
-          runLogger $ logError $ "Error decoding config: " <> T.pack e
-          pure $ ExitFailure 65
-        VLeft _ -> pure $ ExitFailure 65

app/ghcup/GHCup/OptParse/GC.hs

@@ -98,7 +98,7 @@ gcFooter = [s|Discussion:
     ---------------------------
 
 
-type GCEffects = '[ NotInstalled ]
+type GCEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runGC :: MonadUnliftIO m
@@ -129,7 +129,7 @@ gc :: ( Monad m
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
 gc GCOptions{..} runAppState runLogger = runGC runAppState (do
-  when gcOldGHC rmOldGHC
+  when gcOldGHC (liftE rmOldGHC)
   lift $ when gcProfilingLibs rmProfilingLibs
   lift $ when gcShareDir rmShareDir
   liftE $ when gcHLSNoGHC rmHLSNoGHC

app/ghcup/GHCup/OptParse/Install.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 module GHCup.OptParse.Install where
 
@@ -17,6 +18,7 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
+import           GHCup.Utils.Dirs
 import           GHCup.Utils.Logger
 import           GHCup.Utils.String.QQ
 
@@ -189,18 +191,15 @@ installOpts tool =
                     (eitherReader uriParser)
                     (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
                       "Install the specified version from this bindist"
+                      <> completer (toolDlCompleter (fromMaybe GHC tool))
                     )
                   )
             <*> (Just <$> toolVersionArgument Nothing tool)
             )
         <|> pure (Nothing, Nothing)
         )
-    <*> flag
+    <*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault
-          False
+      (help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install"))
-          True
-          (long "set" <> help
-            "Set as active version after install"
-          )
     <*> optional
           (option
            (eitherReader isolateParser)
@@ -208,11 +207,17 @@ installOpts tool =
            <> long "isolate"
            <> metavar "DIR"
            <> help "install in an isolated dir instead of the default one"
+           <> completer (bashCompleter "directory")
            )
           )
     <*> switch
-          (short 'f' <> long "force" <> help "Force install")
+          (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
-          
+ where
+  setDefault = case tool of
+    Nothing  -> False
+    Just GHC -> False
+    Just _   -> True
+
 
 
 
@@ -253,6 +258,50 @@ type InstallEffects = '[ AlreadyInstalled
                        , NoToolVersionSet
                        , FileAlreadyExistsError
                        , ProcessError
+                       , UninstallFailed
+
+                       , (AlreadyInstalled, ())
+                       , (UnknownArchive, ())
+                       , (ArchiveResult, ())
+                       , (FileDoesNotExistError, ())
+                       , (CopyError, ())
+                       , (NotInstalled, ())
+                       , (UninstallFailed, ())
+                       , (DirNotEmpty, ())
+                       , (NoDownload, ())
+                       , (BuildFailed, ())
+                       , (TagNotFound, ())
+                       , (DigestError, ())
+                       , (GPGError, ())
+                       , (DownloadFailed, ())
+                       , (TarDirDoesNotExist, ())
+                       , (NextVerNotFound, ())
+                       , (NoToolVersionSet, ())
+                       , (FileAlreadyExistsError, ())
+                       , (ProcessError, ())
+
+                       , (AlreadyInstalled, NotInstalled)
+                       , (UnknownArchive, NotInstalled)
+                       , (ArchiveResult, NotInstalled)
+                       , (FileDoesNotExistError, NotInstalled)
+                       , (CopyError, NotInstalled)
+                       , (NotInstalled, NotInstalled)
+                       , (DirNotEmpty, NotInstalled)
+                       , (NoDownload, NotInstalled)
+                       , (NotInstalled, NotInstalled)
+                       , (UninstallFailed, NotInstalled)
+                       , (BuildFailed, NotInstalled)
+                       , (TagNotFound, NotInstalled)
+                       , (DigestError, NotInstalled)
+                       , (GPGError, NotInstalled)
+                       , (DownloadFailed, NotInstalled)
+                       , (TarDirDoesNotExist, NotInstalled)
+                       , (NextVerNotFound, NotInstalled)
+                       , (NoToolVersionSet, NotInstalled)
+                       , (FileAlreadyExistsError, NotInstalled)
+                       , (ProcessError, NotInstalled)
+
+                       , ((), NotInstalled)
                        ]
 
 
@@ -273,6 +322,7 @@ type InstallGHCEffects = '[ TagNotFound
                           , BuildFailed
                           , DirNotEmpty
                           , AlreadyInstalled
+                          , UninstallFailed
 
                           , (AlreadyInstalled, NotInstalled)
                           , (UnknownArchive, NotInstalled)
@@ -282,6 +332,7 @@ type InstallGHCEffects = '[ TagNotFound
                           , (NotInstalled, NotInstalled)
                           , (DirNotEmpty, NotInstalled)
                           , (NoDownload, NotInstalled)
+                          , (UninstallFailed, NotInstalled)
                           , (BuildFailed, NotInstalled)
                           , (TagNotFound, NotInstalled)
                           , (DigestError, NotInstalled)
@@ -301,6 +352,7 @@ type InstallGHCEffects = '[ TagNotFound
                           , (NotInstalled, ())
                           , (DirNotEmpty, ())
                           , (NoDownload, ())
+                          , (UninstallFailed, ())
                           , (BuildFailed, ())
                           , (TagNotFound, ())
                           , (DigestError, ())
@@ -349,10 +401,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
          (v, vi) <- liftE $ fromVersion instVer GHC
          void $ liftE $ sequenceE (installGHCBin
                      (_tvVersion v)
-                     isolateDir
+                     (maybe GHCupInternal IsolateDir isolateDir)
                      forceInstall
                    )
-                   $ when instSet $ void $ setGHC v SetGHCOnly Nothing
+                   $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
          pure vi
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
@@ -360,10 +412,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
            void $ liftE $ sequenceE (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                        (_tvVersion v)
-                       isolateDir
+                       (maybe GHCupInternal IsolateDir isolateDir)
                        forceInstall
                      )
-                     $ when instSet $ void $ setGHC v SetGHCOnly Nothing
+                     $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
            pure vi
       )
         >>= \case
@@ -375,41 +427,41 @@ install installCommand settings getAppState' runLogger = case installCommand of
 
               VLeft (V (AlreadyInstalled _ v, ())) -> do
                 runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
+                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
                 pure ExitSuccess
               VLeft (V (AlreadyInstalled _ v)) -> do
                 runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
+                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
                 pure ExitSuccess
 
               VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logWarn $
+                runLogger $ logError $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
               VLeft (V (DirNotEmpty fp, ())) -> do
-                runLogger $ logWarn $
+                runLogger $ logError $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
 
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                    "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _, ())) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                    "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
 
               VLeft e -> do
                 runLogger $ do
                   logError $ T.pack $ prettyShow e
-                  logError $ "Also check the logs in " <> T.pack logsDir
+                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
                 pure $ ExitFailure 3
 
 
@@ -418,20 +470,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
     (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
-         (v, vi) <- liftE $ fromVersion instVer Cabal
+         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         liftE $ installCabalBin
+         void $ liftE $ sequenceE (installCabalBin
-                   (_tvVersion v)
+                                    v
-                   isolateDir
+                                    (maybe GHCupInternal IsolateDir isolateDir)
-                   forceInstall
+                                    forceInstall
+                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
-           (v, vi) <- liftE $ fromVersion instVer Cabal
+           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           liftE $ installCabalBindist 
+           void $ liftE $ sequenceE (installCabalBindist
-                     (DownloadInfo uri Nothing "")
+                                      (DownloadInfo uri Nothing "")
-                     (_tvVersion v)
+                                      v
-                     isolateDir
+                                      (maybe GHCupInternal IsolateDir isolateDir)
-                     forceInstall
+                                      forceInstall
+                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
            pure vi
       )
       >>= \case
@@ -448,10 +502,18 @@ install installCommand settings getAppState' runLogger = case installCommand of
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
+              runLogger $ logWarn $
+                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack logsDir
+                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4
 
   installHLS :: InstallOptions -> IO ExitCode
@@ -459,21 +521,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
      s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
      (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
-         (v, vi) <- liftE $ fromVersion instVer HLS
+         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         liftE $ installHLSBin
+         void $ liftE $ sequenceE (installHLSBin
-                   (_tvVersion v)
+                                    v
-                   isolateDir
+                                    (maybe GHCupInternal IsolateDir isolateDir)
-                   forceInstall
+                                    forceInstall
+                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
-           (v, vi) <- liftE $ fromVersion instVer HLS
+           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
            -- TODO: support legacy
-           liftE $ installHLSBindist
+           void $ liftE $ sequenceE (installHLSBindist
-                     (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
+                                      (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
-                     (_tvVersion v)
+                                      v
-                     isolateDir
+                                      (maybe GHCupInternal IsolateDir isolateDir)
-                     forceInstall
+                                      forceInstall
+                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
            pure vi
       )
       >>= \case
@@ -494,10 +558,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
+              runLogger $ logWarn $
+                  "HLS ver "
+                <> prettyVer v
+                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
+                <> prettyVer v
+                <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack logsDir
+                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4
 
   installStack :: InstallOptions -> IO ExitCode
@@ -505,20 +581,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
      s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
      (case instBindist of
         Nothing -> runInstTool s' instPlatform $ do
-          (v, vi) <- liftE $ fromVersion instVer Stack
+          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          liftE $ installStackBin
+          void $ liftE $ sequenceE (installStackBin
-                    (_tvVersion v)
+                                     v
-                    isolateDir
+                                     (maybe GHCupInternal IsolateDir isolateDir)
-                    forceInstall
+                                     forceInstall
+                                   ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
           pure vi
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
-            (v, vi) <- liftE $ fromVersion instVer Stack
+            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            liftE $ installStackBindist
+            void $ liftE $ sequenceE (installStackBindist
-                      (DownloadInfo uri Nothing "")
+                                       (DownloadInfo uri Nothing "")
-                      (_tvVersion v)
+                                       v
-                      isolateDir
+                                       (maybe GHCupInternal IsolateDir isolateDir)
-                      forceInstall
+                                       forceInstall
+                                     ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
             pure vi
       )
       >>= \case
@@ -535,9 +613,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
+              runLogger $ logWarn $
+                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack logsDir
+                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4
 

app/ghcup/GHCup/OptParse/List.hs

@@ -69,6 +69,7 @@ listOpts =
             (eitherReader toolParser)
             (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
               "Tool to list versions for. Default is all"
+              <> completer (toolCompleter)
             )
           )
     <*> optional
@@ -78,6 +79,7 @@ listOpts =
             <> long "show-criteria"
             <> metavar "<installed|set|available>"
             <> help "Show only installed/set/available tool versions"
+              <> completer (listCompleter ["installed", "set", "available"])
             )
           )
     <*> switch
@@ -141,11 +143,11 @@ printListResult no_color raw lr = do
             )
         $ lr
   let cols =
-        foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
+        foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
       lengths = fmap (maximum . fmap strWidth) cols
       padded  = fmap (\xs -> zipWith padTo xs lengths) rows
 
-  forM_ padded $ \row -> putStrLn $ unwords row
+  forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
  where
 
   padTo str' x =

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
     ---------------------------
 
 
-type NukeEffects = '[ NotInstalled ]
+type NukeEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runNuke :: AppState

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -83,7 +83,7 @@ prefetchP = subparser
         (PrefetchGHC
           <$> (PrefetchGHCOptions
                 <$> ( 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/)")))
+                <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
           <*>  optional (toolVersionArgument Nothing (Just GHC)) )
         ( progDesc "Download GHC assets for installation")
       )
@@ -92,7 +92,7 @@ prefetchP = subparser
       "cabal"
       (info 
         (PrefetchCabal
-          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
           <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
         ( progDesc "Download cabal assets for installation")
       )
@@ -101,7 +101,7 @@ prefetchP = subparser
       "hls"
       (info 
         (PrefetchHLS
-          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
           <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
         ( progDesc "Download HLS assets for installation")
       )
@@ -110,7 +110,7 @@ prefetchP = subparser
       "stack"
       (info 
         (PrefetchStack
-          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
           <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
         ( progDesc "Download stack assets for installation")
       )

app/ghcup/GHCup/OptParse/Rm.hs

@@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
     ---------------------------
 
 
-type RmEffects = '[ NotInstalled ]
+type RmEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))

app/ghcup/GHCup/OptParse/Run.hs

@@ -15,7 +15,7 @@ import           GHCup.Utils.File
 import           GHCup.OptParse.Common
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Types.Optics             ( getDirs )
+import           GHCup.Types.Optics
 import           GHCup.Utils.Logger
 import           GHCup.Utils.String.QQ
 
@@ -32,10 +32,8 @@ import           Data.List                      ( intercalate )
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
-import           System.Directory
 import           System.FilePath
 import           System.Environment
-import           System.IO.Temp
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
@@ -62,6 +60,7 @@ data RunOptions = RunOptions
   , runHLSVer     :: Maybe ToolVersion
   , runStackVer   :: Maybe ToolVersion
   , runBinDir     :: Maybe FilePath
+  , runQuick      :: Bool
   , runCOMMAND    :: [String]
   }
 
@@ -71,7 +70,8 @@ data RunOptions = RunOptions
     --[ Parsers ]--
     ---------------
 
-          
+
+
 runOpts :: Parser RunOptions
 runOpts =
   RunOptions
@@ -82,22 +82,34 @@ runOpts =
     <*> optional
           (option
             (eitherReader toolVersionEither)
-            (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version")
+            (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
+            <> completer (tagCompleter GHC [])
+            <> (completer $ versionCompleter Nothing GHC)
+            )
           )
     <*> optional
           (option
             (eitherReader toolVersionEither)
-            (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version")
+            (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
+            <> completer (tagCompleter Cabal [])
+            <> (completer $ versionCompleter Nothing Cabal)
+            )
           )
     <*> optional
           (option
             (eitherReader toolVersionEither)
-            (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version")
+            (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
+            <> completer (tagCompleter HLS [])
+            <> (completer $ versionCompleter Nothing HLS)
+            )
           )
     <*> optional
           (option
             (eitherReader toolVersionEither)
-            (metavar "STACK_VERSION" <> long "stack" <> help "The stack version")
+            (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
+            <> completer (tagCompleter Stack [])
+            <> (completer $ versionCompleter Nothing Stack)
+            )
           )
     <*> optional
           (option
@@ -106,8 +118,11 @@ runOpts =
            <> long "bindir"
            <> metavar "DIR"
            <> help "directory where to create the tool symlinks (default: newly created system temp dir)"
+           <> completer (bashCompleter "directory")
            )
           )
+    <*> switch
+          (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
     <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
           
 
@@ -160,6 +175,7 @@ type RunEffects = '[ AlreadyInstalled
                    , NoToolVersionSet
                    , FileAlreadyExistsError
                    , ProcessError
+                   , UninstallFailed
                    ]
 
 runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@@ -174,14 +190,16 @@ runLeanRUN leanAppstate =
       @RunEffects
 
 runRUN :: MonadUnliftIO m
-      => (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
+      => IO AppState
       -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
       -> m (VEither RunEffects a)
-runRUN runAppState =
+runRUN appState action' = do
-  runAppState
+  s' <- liftIO appState
+  flip runReaderT s'
     . runResourceT
     . runE
       @RunEffects
+    $ action'
 
 
 
@@ -199,110 +217,176 @@ run :: forall m.
        , MonadUnliftIO m
        )
    => RunOptions
-   -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
+   -> IO AppState
    -> LeanAppState
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
 run RunOptions{..} runAppState leanAppstate runLogger = do
-   tmp <- case runBinDir of
+   r <- if not runQuick
-     Just bdir -> do
+        then runRUN runAppState $ do
-       liftIO $ createDirRecursive' bdir
+         toolchain <- liftE resolveToolchainFull
-       liftIO $ canonicalizePath bdir
+         tmp <- liftIO $ createTmpDir toolchain
-     Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup")
+         liftE $ installToolChainFull toolchain tmp
-   r <- do
+         pure tmp
-     addToolsToDir tmp
+        else runLeanRUN leanAppstate $ do
+         toolchain <- resolveToolchain
+         tmp <- liftIO $ createTmpDir toolchain
+         liftE $ installToolChain toolchain tmp
+         pure tmp
    case r of
-     VRight _ -> do
+         VRight tmp -> do
-       case runCOMMAND of
+           case runCOMMAND of
-         [] -> do
+             [] -> do
-           liftIO $ putStr tmp
+               liftIO $ putStr tmp
-           pure ExitSuccess
+               pure ExitSuccess
-         (cmd:args) -> do
+             (cmd:args) -> do
-           newEnv <- liftIO $ addToPath tmp
+               newEnv <- liftIO $ addToPath tmp
 #ifndef IS_WINDOWS
-           void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
+               void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
-           pure ExitSuccess
+               pure ExitSuccess
 #else
-           r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
+               r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
-           case r' of
+               case r' of
-             VRight _ -> pure ExitSuccess
+                 VRight _ -> pure ExitSuccess
-             VLeft e -> do
+                 VLeft e -> do
-               runLogger $ logError $ T.pack $ prettyShow e
+                   runLogger $ logError $ T.pack $ prettyShow e
-               pure $ ExitFailure 28
+                   pure $ ExitFailure 28
 #endif
-     VLeft e -> do
+         VLeft e -> do
-       runLogger $ logError $ T.pack $ prettyShow e
+           runLogger $ logError $ T.pack $ prettyShow e
-       pure $ ExitFailure 27
+           pure $ ExitFailure 27
+
   where
-   isToolTag :: ToolVersion -> Bool
+
-   isToolTag (ToolTag _) = True
+   createTmpDir :: Toolchain -> IO FilePath
-   isToolTag _           = False
+   createTmpDir toolchain =
+     case runBinDir of
+           Just bindir -> do
+             createDirRecursive' bindir
+             canonicalizePath bindir
+           Nothing -> do
+             d <- predictableTmpDir toolchain
+             createDirRecursive' d
+             canonicalizePath d
 
    -- TODO: doesn't work for cross
-   addToolsToDir tmp
+   resolveToolchainFull :: ( MonadFail m
-     | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
+                           , MonadThrow m
-         forM_ runGHCVer $ \ver -> do
+                           , MonadIO m
+                           , MonadCatch m
+                           )
+                        => Excepts
+                             '[ TagNotFound
+                              , NextVerNotFound
+                              , NoToolVersionSet
+                              ] (ResourceT (ReaderT AppState m)) Toolchain
+   resolveToolchainFull = do
+         ghcVer <- forM runGHCVer $ \ver -> do
            (v, _) <- liftE $ fromVersion (Just ver) GHC
-           installTool GHC v
+           pure v
-           setTool GHC v tmp
+         cabalVer <- forM runCabalVer $ \ver -> do
-         forM_ runCabalVer $ \ver -> do
            (v, _) <- liftE $ fromVersion (Just ver) Cabal
-           installTool Cabal v
+           pure v
-           setTool Cabal v tmp
+         hlsVer <- forM runHLSVer $ \ver -> do
-         forM_ runHLSVer $ \ver -> do
            (v, _) <- liftE $ fromVersion (Just ver) HLS
-           installTool HLS v
+           pure v
-           setTool HLS v tmp
+         stackVer <- forM runStackVer $ \ver -> do
-         forM_ runStackVer $ \ver -> do
            (v, _) <- liftE $ fromVersion (Just ver) Stack
-           installTool Stack v
+           pure v
-           setTool Stack v tmp
+         pure Toolchain{..}
-     | otherwise = runLeanRUN leanAppstate $ do
-         case runGHCVer of
-            Just (ToolVersion v) ->
-              setTool GHC v tmp
-            Nothing -> pure ()
-            _ -> fail "Internal error"
-         case runCabalVer of
-            Just (ToolVersion v) ->
-              setTool Cabal v tmp
-            Nothing -> pure ()
-            _ -> fail "Internal error"
-         case runHLSVer of
-            Just (ToolVersion v) ->
-              setTool HLS v tmp
-            Nothing -> pure ()
-            _ -> fail "Internal error"
-         case runStackVer of
-            Just (ToolVersion v) ->
-              setTool Stack v tmp
-            Nothing -> pure ()
-            _ -> fail "Internal error"
 
-   installTool tool v = do
+   resolveToolchain = do
-      isInstalled <- checkIfToolInstalled' tool v
+         ghcVer <- case runGHCVer of
-      case tool of
+            Just (ToolVersion v) -> pure $ Just v
-        GHC -> do
+            Nothing -> pure Nothing
-          unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
+            _ -> fail "Internal error"
-            (_tvVersion v)
+         cabalVer <- case runCabalVer of
-            Nothing
+            Just (ToolVersion v) -> pure $ Just v
-            False
+            Nothing -> pure Nothing
-        Cabal -> do
+            _ -> fail "Internal error"
-          unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
+         hlsVer <- case runHLSVer of
-            (_tvVersion v)
+            Just (ToolVersion v) -> pure $ Just v
-            Nothing
+            Nothing -> pure Nothing
-            False
+            _ -> fail "Internal error"
-        Stack -> do
+         stackVer <- case runStackVer of
-          unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
+            Just (ToolVersion v) -> pure $ Just v
-            (_tvVersion v)
+            Nothing -> pure Nothing
-            Nothing
+            _ -> fail "Internal error"
-            False
+         pure Toolchain{..}
-        HLS -> do
+
-          unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
+   installToolChainFull :: ( MonadFail m
-            (_tvVersion v)
+                           , MonadThrow m
-            Nothing
+                           , MonadIO m
-            False
+                           , MonadCatch m
-        GHCup -> pure ()
+                           )
+                        => Toolchain
+                        -> FilePath
+                        -> Excepts
+                             '[ TagNotFound
+                              , NextVerNotFound
+                              , NoToolVersionSet
+                              , UnknownArchive
+                              , TarDirDoesNotExist
+                              , ProcessError
+                              , NotInstalled
+                              , NoDownload
+                              , GPGError
+                              , DownloadFailed
+                              , DirNotEmpty
+                              , DigestError
+                              , BuildFailed
+                              , ArchiveResult
+                              , AlreadyInstalled
+                              , FileAlreadyExistsError
+                              , CopyError
+                              , UninstallFailed
+                              ] (ResourceT (ReaderT AppState m)) ()
+   installToolChainFull Toolchain{..} tmp = do
+         forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
+           isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
+           case mt of
+             Just (GHC, v) -> do
+               unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
+                 (_tvVersion v)
+                 GHCupInternal
+                 False
+               setTool GHC v tmp
+             Just (Cabal, v) -> do
+               unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
+                 (_tvVersion v)
+                 GHCupInternal
+                 False
+               setTool Cabal v tmp
+             Just (Stack, v) -> do
+               unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
+                 (_tvVersion v)
+                 GHCupInternal
+                 False
+               setTool Stack v tmp
+             Just (HLS, v) -> do
+               unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
+                 (_tvVersion v)
+                 GHCupInternal
+                 False
+               setTool HLS v tmp
+             _ -> pure ()
+
+   installToolChain :: ( MonadFail m
+                       , MonadThrow m
+                       , MonadIO m
+                       , MonadCatch m
+                       )
+                    => Toolchain
+                    -> FilePath
+                    -> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
+   installToolChain Toolchain{..} tmp = do
+         forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
+           case mt of
+             Just (GHC, v)   -> setTool GHC v tmp
+             Just (Cabal, v) -> setTool Cabal v tmp
+             Just (Stack, v) -> setTool Stack v tmp
+             Just (HLS, v)   -> setTool HLS v tmp
+             _ -> pure ()
 
    setTool tool v tmp =
       case tool of
@@ -324,7 +408,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
           if legacy
           then do
             -- TODO: factor this out
-            (Just hlsWrapper) <- hlsWrapperBinary v'
+            hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))
             cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
             lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
             hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
@@ -346,3 +430,31 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
         envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
     liftIO $ setEnv pathVar newPath
     return envWithNewPath
+
+   predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =
+     liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))
+   predictableTmpDir Toolchain{..} = do
+      tmp <- getTemporaryDirectory
+      pure $ tmp
+        </> ("ghcup-" <> intercalate "_"
+              (  maybe [] ( (:[]) . ("ghc-"   <>) . T.unpack . tVerToText) ghcVer
+              <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer
+              <> maybe [] ( (:[]) . ("hls-"   <>) . T.unpack . tVerToText) hlsVer
+              <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer
+              )
+            )
+
+
+
+    -------------------------
+    --[ Other local types ]--
+    -------------------------
+
+
+
+data Toolchain = Toolchain
+  { ghcVer     :: Maybe GHCTargetVersion
+  , cabalVer   :: Maybe GHCTargetVersion
+  , hlsVer     :: Maybe GHCTargetVersion
+  , stackVer   :: Maybe GHCTargetVersion
+  }

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module GHCup.OptParse.ToolRequirements where
 
@@ -11,6 +12,7 @@ module GHCup.OptParse.ToolRequirements where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -34,6 +36,41 @@ import System.IO
 
 
 
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data ToolReqOpts = ToolReqOpts
+  { tlrRaw :: Bool
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+toolReqP :: Parser ToolReqOpts
+toolReqP =
+  ToolReqOpts
+    <$> switch (short 'r' <> long "raw-format" <> help "machine-parsable format")
+
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+toolReqFooter :: String
+toolReqFooter = [s|Discussion:
+  Print tool requirements on the current platform.
+  If you want to pass this to your package manage, use '--raw-format'.|]
+
 
 
     ---------------------------
@@ -66,14 +103,17 @@ toolRequirements :: ( Monad m
                     , MonadFail m
                     , Alternative m
                     )
-                 => (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
+                 => ToolReqOpts
+                 -> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
                  -> (ReaderT LeanAppState m () -> m ())
                  -> m ExitCode
-toolRequirements runAppState runLogger = runToolRequirements runAppState (do
+toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements runAppState (do
     GHCupInfo { .. } <- lift getGHCupInfo
     platform' <- liftE getPlatform
-    req      <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
+    req       <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
-    liftIO $ T.hPutStr stdout (prettyRequirements req)
+    if tlrRaw
+    then liftIO $ T.hPutStr stdout (rawRequirements req)
+    else liftIO $ T.hPutStr stdout (prettyRequirements req)
   )
     >>= \case
           VRight _ -> pure ExitSuccess

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -59,19 +59,21 @@ data UpgradeOpts = UpgradeInplace
     --[ Parsers ]--
     ---------------
 
-          
+
 upgradeOptsP :: Parser UpgradeOpts
 upgradeOptsP =
   flag'
       UpgradeInplace
       (short 'i' <> long "inplace" <> help
-        "Upgrade ghcup in-place (wherever it's at)"
+        "Upgrade ghcup in-place"
       )
-    <|> (   UpgradeAt
+    <|>
+      (   UpgradeAt
         <$> option
               str
               (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
                 "Absolute filepath to write ghcup into"
+                <> completer (bashCompleter "file")
               )
         )
     <|> pure UpgradeGHCupDir
@@ -91,6 +93,7 @@ type UpgradeEffects = '[ DigestError
                        , FileDoesNotExistError
                        , CopyError
                        , DownloadFailed
+                       , GHCupShadowed
                        ]
 
 
@@ -119,18 +122,19 @@ upgrade :: ( Monad m
            )
         => UpgradeOpts
         -> Bool
+        -> Bool
         -> Dirs
         -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
         -> (ReaderT LeanAppState m () -> m ())
         -> m ExitCode
-upgrade uOpts force' Dirs{..} runAppState runLogger = do
+upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
   target <- case uOpts of
     UpgradeInplace  -> Just <$> liftIO getExecutablePath
     (UpgradeAt p)   -> pure $ Just p
     UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
   runUpgrade runAppState (do
-    v' <- liftE $ upgradeGHCup target force'
+    v' <- liftE $ upgradeGHCup target force' fatal
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
     pure (v', dls)
     ) >>= \case

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -17,6 +17,7 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Types
+import           GHCup.Utils
 import           GHCup.Utils.Logger
 import           GHCup.Utils.String.QQ
 
@@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 pure $ ExitFailure 30
 
     (WhereisBaseDir, _) -> do
-      liftIO $ putStr baseDir
+      liftIO $ putStr $ fromGHCupPath baseDir
       pure ExitSuccess
 
     (WhereisBinDir, _) -> do
@@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
       pure ExitSuccess
 
     (WhereisCacheDir, _) -> do
-      liftIO $ putStr cacheDir
+      liftIO $ putStr $ fromGHCupPath cacheDir
       pure ExitSuccess
 
     (WhereisLogsDir, _) -> do
-      liftIO $ putStr logsDir
+      liftIO $ putStr $ fromGHCupPath logsDir
       pure ExitSuccess
 
     (WhereisConfDir, _) -> do
-      liftIO $ putStr confDir
+      liftIO $ putStr $ fromGHCupPath confDir
       pure ExitSuccess

app/ghcup/Main.hs

@@ -82,7 +82,7 @@ toSettings options = do
          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
+         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
      in (Settings {..}, keyBindings)
@@ -141,9 +141,7 @@ main = do
         )
   let listCommands = infoOption
         ("install set rm install-cabal list"
-#ifndef DISABLE_UPGRADE
           <> " upgrade"
-#endif
           <> " compile debug-info tool-requirements changelog"
         )
         (  long "list-commands"
@@ -222,20 +220,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
 
                 race_ (liftIO $ runReaderT cleanupTrash s')
-                      (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
+                      (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually"))
 
                 case optCommand of
                   Nuke -> pure ()
                   Whereis _ _ -> pure ()
                   DInfo -> pure ()
-                  ToolRequirements -> pure ()
+                  ToolRequirements _ -> pure ()
                   ChangeLog _ -> pure ()
                   UnSet _ -> pure ()
 #if defined(BRICK)
                   Interactive -> pure ()
 #endif
                   -- check for new tools
-                  _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
+                  _
+                    | Just False <- optVerbose -> pure ()
+                    | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
                          Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
                            newTools <- lift checkForUpdates 
                            forM_ newTools $ \newTool@(t, l) -> do
@@ -243,14 +243,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                              alreadyInstalling' <- alreadyInstalling optCommand newTool
                              when (not alreadyInstalling') $
                                case t of
-#ifdef DISABLE_UPGRADE
-                                 GHCup -> pure ()
-#else
                                  GHCup -> runLogger $
                                             logWarn ("New GHCup version available: "
                                               <> prettyVer l
                                               <> ". To upgrade, run 'ghcup upgrade'")
-#endif
                                  _ -> runLogger $
                                         logWarn ("New "
                                           <> T.pack (prettyShow t)
@@ -294,26 +290,24 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
               s' <- appState
               liftIO $ brickMain s' >> pure ExitSuccess
 #endif
-            Install installCommand   -> install installCommand settings appState runLogger
+            Install installCommand     -> install installCommand settings appState runLogger
-            InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
+            InstallCabalLegacy iopts   -> install (Left (InstallCabal iopts)) settings appState runLogger
-            Set setCommand           -> set setCommand runAppState runLeanAppState runLogger
+            Set setCommand             -> set setCommand runAppState runLeanAppState runLogger
-            UnSet unsetCommand       -> unset unsetCommand runLeanAppState runLogger
+            UnSet unsetCommand         -> unset unsetCommand runLeanAppState runLogger
-            List lo                  -> list lo no_color runAppState
+            List lo                    -> list lo no_color runAppState
-            Rm rmCommand             -> rm rmCommand runAppState runLogger
+            Rm rmCommand               -> rm rmCommand runAppState runLogger
-            DInfo                    -> dinfo runAppState runLogger
+            DInfo                      -> dinfo runAppState runLogger
-            Compile compileCommand   -> compile compileCommand settings dirs runAppState runLogger
+            Compile compileCommand     -> compile compileCommand settings dirs runAppState runLogger
-            Config configCommand     -> config configCommand settings keybindings runLogger
+            Config configCommand       -> config configCommand settings keybindings runLogger
             Whereis whereisOptions
-                    whereisCommand   -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
+                    whereisCommand     -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
-#ifndef DISABLE_UPGRADE
+            Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
-            Upgrade uOpts force'     -> upgrade uOpts force' dirs runAppState runLogger
+            ToolRequirements topts     -> toolRequirements topts runAppState runLogger
-#endif
+            ChangeLog changelogOpts    -> changelog changelogOpts runAppState runLogger
-            ToolRequirements         -> toolRequirements runAppState runLogger
+            Nuke                       -> nuke appState runLogger
-            ChangeLog changelogOpts  -> changelog changelogOpts runAppState runLogger
+            Prefetch pfCom             -> prefetch pfCom runAppState runLogger
-            Nuke                     -> nuke appState runLogger
+            GC gcOpts                  -> gc gcOpts runAppState runLogger
-            Prefetch pfCom           -> prefetch pfCom runAppState runLogger
+            Run runCommand             -> run runCommand appState leanAppstate runLogger
-            GC gcOpts                -> gc gcOpts runAppState runLogger
-            Run runCommand           -> run runCommand runAppState leanAppstate runLogger
 
           case res of
             ExitSuccess        -> pure ()
@@ -351,9 +345,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
     (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
   alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
     (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
-#ifndef DISABLE_UPGRADE
+  alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
-  alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True
-#endif
   alreadyInstalling _ _ = pure False
 
   cmp' :: ( HasLog env

cabal.ghc8107.project.freeze

@@ -10,8 +10,8 @@ constraints: any.Cabal ==3.6.2.0,
              any.StateVar ==1.2.2,
              any.abstract-deque ==0.3,
              abstract-deque -usecas,
-             any.aeson ==2.0.2.0,
+             any.aeson ==2.0.3.0,
-             aeson -bytestring-builder -cffi +ordered-keymap,
+             aeson -cffi +ordered-keymap,
              any.aeson-pretty ==0.8.9,
              aeson-pretty +lib-only,
              any.alex ==3.2.7.1,
@@ -25,14 +25,14 @@ constraints: any.Cabal ==3.6.2.0,
              async -bench,
              any.atomic-primops ==0.8.4,
              atomic-primops -debug,
-             any.attoparsec ==0.13.2.5,
+             any.attoparsec ==0.14.4,
              attoparsec -developer,
              any.base ==4.14.3.0,
              any.base-compat ==0.12.1,
              any.base-compat-batteries ==0.12.1,
              any.base-orphans ==0.8.6,
              any.base16-bytestring ==1.0.2.0,
-             any.base64-bytestring ==1.1.0.0,
+             any.base64-bytestring ==1.2.1.0,
              any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.8.0,
@@ -69,7 +69,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.cryptohash-sha1 ==0.11.101.0,
              any.cryptohash-sha256 ==0.11.102.1,
              cryptohash-sha256 -exe +use-cbits,
-             any.data-clist ==0.1.2.3,
+             any.data-clist ==0.2,
              any.data-fix ==0.3.2,
              any.deepseq ==1.4.4.0,
              any.directory ==1.3.6.0,
@@ -82,10 +82,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.filepath ==1.4.2.1,
              any.free ==5.1.7,
              any.fusion-plugin-types ==0.1.0,
-             any.generic-arbitrary ==0.1.0,
+             any.generic-arbitrary ==0.2.0,
+             any.ghc ==8.10.7,
+             any.ghc-boot ==8.10.7,
              any.ghc-boot-th ==8.10.7,
              any.ghc-byteorder ==4.11.0.0.10,
+             any.ghc-heap ==8.10.7,
              any.ghc-prim ==0.6.1,
+             any.ghci ==8.10.7,
              any.happy ==1.20.0,
              any.hashable ==1.4.0.2,
              hashable +containers +integer-gmp -random-initial-seed,
@@ -93,11 +97,12 @@ constraints: any.Cabal ==3.6.2.0,
              any.haskus-utils-types ==1.5.1,
              any.haskus-utils-variant ==3.2.1,
              any.heaps ==0.4,
+             any.hpc ==0.6.1.0,
              any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.10,
+             any.hspec ==2.9.4,
-             any.hspec-core ==2.7.10,
+             any.hspec-core ==2.9.4,
-             any.hspec-discover ==2.7.10,
+             any.hspec-discover ==2.9.4,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
              any.http-io-streams ==0.1.6.0,
@@ -118,7 +123,7 @@ constraints: any.Cabal ==3.6.2.0,
              libyaml-streamly -no-unicode -system-libyaml,
              any.lockfree-queue ==0.2.3.1,
              any.lzma-static ==5.2.5.4,
-             any.megaparsec ==9.0.1,
+             any.megaparsec ==9.2.0,
              megaparsec -dev,
              any.microlens ==0.4.12.0,
              any.microlens-mtl ==0.2.0.1,
@@ -134,7 +139,7 @@ constraints: any.Cabal ==3.6.2.0,
              optics-core -explicit-generic-labels,
              any.optics-extra ==0.4,
              any.optics-th ==0.4,
-             any.optparse-applicative ==0.16.1.0,
+             any.optparse-applicative ==0.17.0.0,
              optparse-applicative +process,
              any.os-release ==1.0.2.1,
              os-release -devel,
@@ -173,13 +178,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.splitmix ==0.1.0.4,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.1,
-             any.streamly ==0.8.1.1,
+             any.streamly ==0.8.2,
-             streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -use-c-malloc,
+             streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc -use-unliftio,
              any.strict ==0.4.0.1,
              strict +assoc,
              any.strict-base ==0.4.0.0,
              any.tagged ==0.8.6.1,
              tagged +deepseq +transformers,
+             any.tagsoup ==0.14.8,
              any.template-haskell ==2.16.0.0,
              any.temporary ==1.3,
              any.terminal-progress-bar ==0.4.1,
@@ -211,7 +217,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.unix-compat ==0.5.4,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.16.0,
+             any.unordered-containers ==0.2.17.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -219,15 +225,15 @@ constraints: any.Cabal ==3.6.2.0,
              any.uuid-types ==1.0.5,
              any.vector ==0.12.3.1,
              vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.2,
+             any.versions ==5.0.3,
              any.vty ==5.33,
              any.witherable ==0.4.2,
              any.word-wrap ==0.5,
              any.word8 ==0.1.3,
-             any.xor ==0.0.1.0,
+             any.xor ==0.0.1.1,
              any.yaml-streamly ==0.12.1,
              yaml-streamly +no-examples +no-exe,
              any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2022-02-15T12:16:42Z
+index-state: hackage.haskell.org 2022-03-15T16:43:02Z

cabal.ghc902.project.freeze

@@ -10,8 +10,8 @@ constraints: any.Cabal ==3.6.2.0,
              any.StateVar ==1.2.2,
              any.abstract-deque ==0.3,
              abstract-deque -usecas,
-             any.aeson ==2.0.2.0,
+             any.aeson ==2.0.3.0,
-             aeson -bytestring-builder -cffi +ordered-keymap,
+             aeson -cffi +ordered-keymap,
              any.aeson-pretty ==0.8.9,
              aeson-pretty +lib-only,
              any.alex ==3.2.7.1,
@@ -25,14 +25,14 @@ constraints: any.Cabal ==3.6.2.0,
              async -bench,
              any.atomic-primops ==0.8.4,
              atomic-primops -debug,
-             any.attoparsec ==0.13.2.5,
+             any.attoparsec ==0.14.4,
              attoparsec -developer,
              any.base ==4.15.1.0,
              any.base-compat ==0.12.1,
              any.base-compat-batteries ==0.12.1,
              any.base-orphans ==0.8.6,
              any.base16-bytestring ==1.0.2.0,
-             any.base64-bytestring ==1.1.0.0,
+             any.base64-bytestring ==1.2.1.0,
              any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.8.0,
@@ -69,7 +69,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.cryptohash-sha1 ==0.11.101.0,
              any.cryptohash-sha256 ==0.11.102.1,
              cryptohash-sha256 -exe +use-cbits,
-             any.data-clist ==0.1.2.3,
+             any.data-clist ==0.2,
              any.data-fix ==0.3.2,
              any.deepseq ==1.4.5.0,
              any.directory ==1.3.6.2,
@@ -82,11 +82,15 @@ constraints: any.Cabal ==3.6.2.0,
              any.filepath ==1.4.2.1,
              any.free ==5.1.7,
              any.fusion-plugin-types ==0.1.0,
-             any.generic-arbitrary ==0.1.0,
+             any.generic-arbitrary ==0.2.0,
+             any.ghc ==9.0.2,
              any.ghc-bignum ==1.1,
+             any.ghc-boot ==9.0.2,
              any.ghc-boot-th ==9.0.2,
              any.ghc-byteorder ==4.11.0.0.10,
+             any.ghc-heap ==9.0.2,
              any.ghc-prim ==0.7.0,
+             any.ghci ==9.0.2,
              any.happy ==1.20.0,
              any.hashable ==1.4.0.2,
              hashable +containers +integer-gmp -random-initial-seed,
@@ -94,11 +98,12 @@ constraints: any.Cabal ==3.6.2.0,
              any.haskus-utils-types ==1.5.1,
              any.haskus-utils-variant ==3.2.1,
              any.heaps ==0.4,
+             any.hpc ==0.6.1.0,
              any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.10,
+             any.hspec ==2.9.4,
-             any.hspec-core ==2.7.10,
+             any.hspec-core ==2.9.4,
-             any.hspec-discover ==2.7.10,
+             any.hspec-discover ==2.9.4,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
              any.http-io-streams ==0.1.6.0,
@@ -118,7 +123,7 @@ constraints: any.Cabal ==3.6.2.0,
              libyaml-streamly -no-unicode -system-libyaml,
              any.lockfree-queue ==0.2.3.1,
              any.lzma-static ==5.2.5.4,
-             any.megaparsec ==9.0.1,
+             any.megaparsec ==9.2.0,
              megaparsec -dev,
              any.microlens ==0.4.12.0,
              any.microlens-mtl ==0.2.0.1,
@@ -134,7 +139,7 @@ constraints: any.Cabal ==3.6.2.0,
              optics-core -explicit-generic-labels,
              any.optics-extra ==0.4,
              any.optics-th ==0.4,
-             any.optparse-applicative ==0.16.1.0,
+             any.optparse-applicative ==0.17.0.0,
              optparse-applicative +process,
              any.os-release ==1.0.2.1,
              os-release -devel,
@@ -173,13 +178,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.splitmix ==0.1.0.4,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.0,
-             any.streamly ==0.8.1.1,
+             any.streamly ==0.8.2,
-             streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -use-c-malloc,
+             streamly -debug -dev -fusion-plugin -has-llvm -inspection -limit-build-mem -no-fusion +opt -streamk -streamly-core -use-c-malloc -use-unliftio,
              any.strict ==0.4.0.1,
              strict +assoc,
              any.strict-base ==0.4.0.0,
              any.tagged ==0.8.6.1,
              tagged +deepseq +transformers,
+             any.tagsoup ==0.14.8,
              any.template-haskell ==2.17.0.0,
              any.temporary ==1.3,
              any.terminal-progress-bar ==0.4.1,
@@ -211,7 +217,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.unix-compat ==0.5.4,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.16.0,
+             any.unordered-containers ==0.2.17.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -219,15 +225,15 @@ constraints: any.Cabal ==3.6.2.0,
              any.uuid-types ==1.0.5,
              any.vector ==0.12.3.1,
              vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.2,
+             any.versions ==5.0.3,
              any.vty ==5.33,
              any.witherable ==0.4.2,
              any.word-wrap ==0.5,
              any.word8 ==0.1.3,
-             any.xor ==0.0.1.0,
+             any.xor ==0.0.1.1,
              any.yaml-streamly ==0.12.1,
              yaml-streamly +no-examples +no-exe,
              any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2022-02-15T12:16:42Z
+index-state: hackage.haskell.org 2022-03-15T16:43:02Z

cabal.project

@@ -15,7 +15,9 @@ source-repository-package
 
 constraints: http-io-streams -brotli,
              any.Cabal ==3.6.2.0,
-             any.aeson >= 2.0.1.0
+             any.aeson >= 2.0.1.0,
+             -- https://github.com/typeable/generic-arbitrary/issues/14
+             any.generic-arbitrary < 0.2.1
 
 package libarchive
   flags: -system-libarchive
@@ -29,4 +31,7 @@ package cabal-plan
 package aeson
   flags: +ordered-keymap
 
+package streamly
+  flags: +use-unliftio
+
 allow-newer: base, ghc-prim, template-haskell, language-c

cbits/dirutils.c

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

cbits/dirutils.h

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

data/config.yaml

@@ -48,12 +48,16 @@ url-source:
 
   ## Example 1: Read download info from this location instead
   ## Accepts file/http/https scheme
+  ## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
+  ## which case they are merged right-biased (overwriting duplicate versions).
   # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
 
-  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
+  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
+  ## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
   # AddSource:
     # Left:
-      # toolRequirements: {} # this is ignored
+      # globalTools: {}
+      # toolRequirements: {}
       # ghcupDownloads:
         # GHC:
           # 9.10.2:
@@ -66,6 +70,8 @@ url-source:
                     # dlSubdir: ghc-7.10.3
                     # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
 
-  ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
+  ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
+  ## versions).
   # AddSource:
-    # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
+    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
+    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

docs/css/extra.css

@@ -1,5 +1,8 @@
 :root {
   --theme-purple: #5E5184;
+  --theme-purple-dark: rgba(69, 59, 97, 0.5);
+  --ukraine-top: #0057B8;
+  --ukraine-bottom: #FFD700;
   --link-pink: #9E358F;
 }
 
@@ -108,12 +111,12 @@ body.homepage>div.container div.col-md-9 {
 
 .bg-primary {
   background-image: none;
-  background-color: var(--theme-purple) !important;
+  background-color: var(--ukraine-top) !important;
 }
 
 body .bg-primary {
   background-image: none;
-  background-color: var(--theme-purple);
+  background-color: var(--ukraine-top);
   border: 0px;
 }
 
@@ -125,8 +128,8 @@ body .btn-primary {
 
 .navbar.fixed-top {
   background-image: none;
-  background-color: var(--theme-purple);
+  background-color: var(--ukraine-top);
-  border-bottom: 5px solid rgba(69, 59, 97, 0.5);
+  border-bottom: 40px solid var(--ukraine-bottom);
   padding: 0px;
 }
 

docs/dev.md

@@ -112,7 +112,9 @@ Every subcommand now lives in its own module under [GHCup.OptParse.MyCommand](ht
 
 12. Update the `data/metadata` submodule in ghcup-hs repo to master
 
-13. Post on reddit/discourse/etc. and collect rewards
+13. Do hackage release
+
+14. Post on reddit/discourse/etc. and collect rewards
 
 # Documentation
 

docs/guide.md

@@ -1,6 +1,6 @@
 # User Guide
 
-`ghcup --help` is your friend.
+This is a more in-depth guide specific to GHCup. `ghcup --help` is your friend.
 
 ## Basic usage
 
@@ -43,13 +43,6 @@ All of the following are valid arguments to `ghcup install ghc`:
 
 If the argument is omitted, the default is `recommended`.
 
-## Configuration
-
-A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
-explaining all possible configurations can be found in this repo: [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml).
-
-Partial configuration is fine. Command line options always override the config file settings.
-
 ## Manpages
 
 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.
@@ -64,6 +57,47 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
 and make sure your bashrc sources the startup script
 (`/usr/share/bash-completion/bash_completion` on some distros).
 
+## Portability
+
+`ghcup` is very portable. There are a few exceptions though:
+
+1. `ghcup tui` is only available on non-windows platforms
+2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
+
+# Configuration
+
+A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
+explaining all possible configurations can be found in this repo: [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml).
+
+Partial configuration is fine. Command line options always override the config file settings.
+
+## Env variables
+
+This is the complete list of env variables that change GHCup behavior:
+
+* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
+* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
+* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
+* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
+* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
+* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
+* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
+* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup
+
+### XDG support
+
+To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
+
+Then you can control the locations via XDG environment variables as such:
+
+* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
+* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
+* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
+* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
+
+**Note that `ghcup` makes some assumptions about structure of files in `XDG_BIN_HOME`. So if you have other tools
+installing e.g. stack/cabal/ghc into it, this will likely clash. In that case consider disabling XDG support.**
+
 ## Caching
 
 GHCup has a few caching mechanisms to avoid redownloads. All cached files end up in `~/.ghcup/cache` by default.
@@ -83,6 +117,92 @@ have a 5 minutes cache per default depending on the last access time of the file
 
 If you experience problems, consider clearing the cache via `ghcup gc --cache`.
 
+## Metadata
+
+The metadata are the files that describe tool versions, where to download them etc. and
+can be viewed here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata)
+
+### Mirrors
+
+GHCup allows to use custom mirrors/download-info hosted by yourself or 3rd parties.
+
+To use a mirror, set the following option in `~/.ghcup/config.yaml`:
+
+```yml
+url-source:
+  # Accepts file/http/https scheme
+  OwnSource: "https://some-url/ghcup-0.0.6.yaml"
+```
+
+See [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml)
+for more options.
+
+Alternatively you can do it via a cli switch:
+
+```sh
+ghcup --url-source=https://some-url/ghcup-0.0.6.yaml list
+```
+
+#### Known mirrors
+
+1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
+
+### (Pre-)Release channels
+
+A release channel is basically just a metadata file location. You can add additional release
+channels that complement the default one, such as the **prerelease channel** like so:
+
+```sh
+ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
+```
+
+This will result in `~/.ghcup/config.yaml` to contain this record:
+
+```yml
+url-source:
+  AddSource:
+  - Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
+```
+
+You can add as many channels as you like. They are combined under *Last*, so versions from the prerelease channel
+here overwrite the default ones, if any.
+
+To remove the channel, delete the entire `url-source` section or set it back to the default:
+
+```yml
+url-source:
+  GHCupURL: []
+```
+
+If you want to combine your release channel with a mirror, you'd do it like so:
+
+```yml
+url-source:
+  OwnSource:
+  # base metadata
+  - "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
+  # prerelease channel
+  - "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
+```
+
+# More on installation
+
+## Installing custom bindists
+
+There are a couple of good use cases to install custom bindists:
+
+1. manually built bindists (e.g. with patches)
+    - example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
+2. GHC head CI bindists
+    - example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
+3. DWARF bindists
+    - example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
+
+Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
+and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
+GHCup always needs to know which version the bindist corresponds to (this is not automatically
+detected).
+
 ## Compiling GHC from source
 
 Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`
@@ -106,76 +226,10 @@ For distributions with non-standard locations of cross toolchain and
 libraries, this may need some tweaking of `build.mk` or configure args.
 See `ghcup compile ghc --help` for further information.
 
-## XDG support
-
-To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
-
-Then you can control the locations via XDG environment variables as such:
-
-* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
-* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
-* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
-* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
-
-**Note that `ghcup` makes some assumptions about structure of files in `XDG_BIN_HOME`. So if you have other tools
-installing e.g. stack/cabal/ghc into it, this will likely clash. In that case consider disabling XDG support.**
-
-## Env variables
-
-This is the complete list of env variables that change GHCup behavior:
-
-* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
-* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
-* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
-* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
-* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
-* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
-* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
-* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup
-
-## Installing custom bindists
-
-There are a couple of good use cases to install custom bindists:
-
-1. manually built bindists (e.g. with patches)
-    - example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
-2. GHC head CI bindists
-    - example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
-3. DWARF bindists
-    - example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
-
-Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
-and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
-GHCup always needs to know which version the bindist corresponds to (this is not automatically
-detected).
-
-## Mirrors
-
-GHCup allows to use custom mirrors/download-info hosted by yourself or 3rd parties.
-
-To use a mirror, set the following option in `~/.ghcup/config.yaml`:
-
-```yml
-url-source:
-  # Accepts file/http/https scheme
-  OwnSource: "https://some-url/ghcup-0.0.6.yaml"
-```
-
-See [config.yaml](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/data/config.yaml)
-for more options.
-
-Alternatively you can do it via a cli switch:
-
-```sh
-ghcup --url-source=https://some-url/ghcup-0.0.6.yaml list
-```
-
-### Known mirrors
-
-1. [https://mirror.sjtu.edu.cn/docs/ghcup](https://mirror.sjtu.edu.cn/docs/ghcup)
-
 ## Isolated installs
 
+**Before using isolated installs, make sure to have at least GHCup version 0.1.17.8!**
+
 Ghcup also enables you to install a tool (GHC, Cabal, HLS, Stack) at an isolated location of your choosing.
 These installs, as the name suggests, are separate from your main installs and DO NOT conflict with them.
 
@@ -257,50 +311,16 @@ gpg-setting: GPGLax # GPGStrict | GPGLax | GPGNone
 In `GPGStrict` mode, ghcup will fail if verification fails. In `GPGLax` mode it will just print a warning.
 You can also pass the mode via `ghcup --gpg <strict|lax|none>`.
    
-## Tips and tricks
+# Tips and tricks
 
-### with_ghc wrapper (e.g. for HLS)
+## ghcup run
 
-Due to some HLS [bugs](https://github.com/mpickering/hie-bios/issues/194) it's necessary that the `ghc` in PATH
+If you don't want to explicitly switch the active GHC all the time and are using
-is the one defined in `cabal.project`. With some simple shell functions, we can start our editor with the appropriate
+tools that rely on the plain `ghc` binary, GHCup provides an easy way to execute
-path prepended.
+commands with a certain toolchain prepended to PATH, e.g.:
-
-For bash, in e.g. `~/.bashrc` define:
 
 ```sh
-with_ghc() {
+ghcup run --ghc 8.10.7 --cabal latest --hls latest --stack latest --install -- code Setup.hs
-  local np=$(ghcup --offline whereis -d ghc $1 || { ghcup --cache install ghc $1 && ghcup whereis -d ghc $1 ;})
-  if [ -e "${np}" ] ; then
-    shift
-    PATH="$np:$PATH" "$@"
-  else
-    >&2 echo "Cannot find or install GHC version $1"
-    return 1
-  fi
-}
 ```
 
-For fish shell, in e.g. `~/.config/fish/config.fish` define:
+This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version.
-
-```fish
-function with_ghc
-  set --local np (ghcup --offline whereis -d ghc $argv[1] ; or begin ghcup --cache install ghc $argv[1] ; and ghcup whereis -d ghc $argv[1] ; end)
-  if test -e "$np"
-    PATH="$np:$PATH" $argv[2..-1]
-  else
-    echo "Cannot find or install GHC version $argv[1]" 1>&2
-    return 1
-  end
-end
-```
-
-Then start a new shell and issue:
-
-```sh
-# replace 'code' with your editor
-with_ghc 8.10.5 code path/to/haskell/source
-```
-
-Cabal and HLS will now see `8.10.5` as the primary GHC, without the need to
-run `ghcup set` all the time when switching between projects.
-

docs/index.md

@@ -17,6 +17,7 @@ hide:
 
 <div class="text-center main-buttons">
 <a href="install/" class="btn btn-primary" role="button">Getting Started</a>
+<a href="steps/" class="btn btn-primary" role="button">First steps</a>
 <a href="guide/" class="btn btn-primary" role="button">User Guide</a>
 </div>
 

docs/install.md

@@ -2,7 +2,7 @@
 
 GHCup makes it easy to install specific versions of GHC on GNU/Linux,
 macOS (aka Darwin), FreeBSD and Windows and can also bootstrap a fresh [Haskell developer environment](./install/#supported-tools) from scratch.
-It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
+It follows the UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
 
 ## Installation
 
@@ -22,6 +22,8 @@ For Windows, run this in a PowerShell session:
 Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true
 ```
 
+There's also a [youtube video](https://www.youtube.com/watch?v=bB4fmQiUYPw) explaining installation on windows.
+
 If you want to know what these scripts do, check out the [source code at the repository](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/scripts/bootstrap). Advanced users may want to perform a [manual installation](#manual-install) and GPG verify the binaries.
 
 ### Which versions get installed?
@@ -32,28 +34,101 @@ GHCup has two main channels for every tool: **recommended** and **latest**. By d
 
 Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information.
 
-## First steps
+## Next steps
 
-1. To get started with creating a Haskell project, follow the [Getting Started with Haskell and Cabal](https://cabal.readthedocs.io/en/stable/getting-started.html) guide
+1. Follow the [First steps guide](../steps) on how to build a "Hello world" program, use `ghc`, run an interactive REPL and create a Haskell project
-2. To learn Haskell, try any of those:
+2. To understand the difference and overlap of `stack` and `cabal`, read on [here](https://gist.github.com/merijn/8152d561fb8b011f9313c48d876ceb07)
-    - A beginner friendly [4-lectures course](https://github.com/haskell-beginners-2022/course-plan) with exercises (by [Kowainik](https://kowainik.github.io/))
+3. To learn Haskell proper check out the links at [How to learn Haskell proper](../steps#how-to-learn-haskell-proper)
-    - An in-depth university [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises (by [Brent Yorgey](https://byorgey.wordpress.com/))
+4. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
-3. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
 
 ## Uninstallation
 
 On linux, just run `ghcup nuke`, then make sure any ghcup added lines in your `~/.bashrc` (or similar) are removed.
 
-On windows, double-click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop.
+On windows, right click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop and select *Run with PowerShell*.
 
 ## Supported tools
 
 GHCup supports the following tools, which are also known as the **Haskell Toolchain**:
 
-1. [GHC](https://www.haskell.org/ghc/)
+<details> <summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary>
-2. [cabal-install](https://cabal.readthedocs.io/en/stable/)
+<table>
-3. [haskell-language-server](https://haskell-language-server.readthedocs.io/en/stable/)
+<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
-4. [stack](https://docs.haskellstack.org/en/stable/README/)
+<tbody>
+<tr><td>9.2.2</td><td><span style="color:blue">latest</span>, base-4.16.1.0</td></tr>
+<tr><td>9.2.1</td><td>base-4.16.0.0</td></tr>
+<tr><td>9.0.2</td><td>base-4.15.1.0</td></tr>
+<tr><td>9.0.1</td><td>base-4.15.0.0</td></tr>
+<tr><td>8.10.7</td><td><span style="color:green">recommended</span>, base-4.14.3.0</td></tr>
+<tr><td>8.10.6</td><td>base-4.14.3.0</td></tr>
+<tr><td>8.10.5</td><td>base-4.14.2.0</td></tr>
+<tr><td>8.10.4</td><td>base-4.14.1.0</td></tr>
+<tr><td>8.10.3</td><td>base-4.14.1.0</td></tr>
+<tr><td>8.10.2</td><td>base-4.14.1.0</td></tr>
+<tr><td>8.10.1</td><td>base-4.14.0.0</td></tr>
+<tr><td>8.8.4</td><td>base-4.13.0.0</td></tr>
+<tr><td>8.8.3</td><td>base-4.13.0.0</td></tr>
+<tr><td>8.8.2</td><td>base-4.13.0.0</td></tr>
+<tr><td>8.8.1</td><td>base-4.13.0.0</td></tr>
+<tr><td>8.6.5</td><td>base-4.12.0.0</td></tr>
+<tr><td>8.6.4</td><td>base-4.12.0.0</td></tr>
+<tr><td>8.6.3</td><td>base-4.12.0.0</td></tr>
+<tr><td>8.6.2</td><td>base-4.12.0.0</td></tr>
+<tr><td>8.6.1</td><td>base-4.12.0.0</td></tr>
+<tr><td>8.4.4</td><td>base-4.11.1.0</td></tr>
+<tr><td>8.4.3</td><td>base-4.11.1.0</td></tr>
+<tr><td>8.4.2</td><td>base-4.11.1.0</td></tr>
+<tr><td>8.4.1</td><td>base-4.11.0.0</td></tr>
+<tr><td>8.2.2</td><td>base-4.10.1.0</td></tr>
+<tr><td>8.0.2</td><td>base-4.9.1.0</td></tr>
+<tr><td>7.10.3</td><td>base-4.8.2.0</td></tr>
+</tbody>
+</table>
+</details>
+
+<details> <summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary>
+<table>
+<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
+<tbody>
+<tr><td>3.6.2.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
+<tr><td>3.6.0.0</td><td></td></tr>
+<tr><td>3.4.1.0</td><td></td></tr>
+<tr><td>3.4.0.0</td><td></td></tr>
+<tr><td>3.2.0.0</td><td></td></tr>
+<tr><td>3.0.0.0</td><td></td></tr>
+<tr><td>2.4.1.0</td><td></td></tr>
+</tbody>
+</table>
+</details>
+
+<details> <summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary>
+<table>
+<thead><tr><th>HLS Version</th><th>Tags</th></tr></thead>
+<tbody>
+<tr><td>1.7.0.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
+<tr><td>1.6.1.0</td><td></td></tr>
+<tr><td>1.6.0.0</td><td></td></tr>
+<tr><td>1.5.1</td><td></td></tr>
+<tr><td>1.5.0</td><td></td></tr>
+<tr><td>1.4.0</td><td></td></tr>
+<tr><td>1.3.0</td><td></td></tr>
+<tr><td>1.2.0</td><td></td></tr>
+<tr><td>1.1.0</td><td></td></tr>
+</tbody>
+</table>
+</details>
+
+<details> <summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary>
+<table>
+<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
+<tbody>
+<tr><td>2.7.5</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
+<tr><td>2.7.3</td><td></td></tr>
+<tr><td>2.7.1</td><td></td></tr>
+<tr><td>2.5.1</td><td></td></tr>
+</tbody>
+</table>
+</details>
 
 ## Supported platforms
 

docs/steps.md

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

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.17.5
+version:            0.1.18.0
 license:            LGPL-3.0-only
 license-file:       LICENSE
 copyright:          Julian Ospald 2020
@@ -48,13 +48,6 @@ flag no-exe
   default:     False
   manual:      True
 
-flag disable-upgrade
-  description:
-    Build the brick powered tui (ghcup tui). This is disabled on windows.
-
-  default:     False
-  manual:      True
-
 library
   exposed-modules:
     GHCup
@@ -121,7 +114,7 @@ library
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , lzma-static           ^>=5.2.5.3
-    , megaparsec            >=8.0.0      && <9.1
+    , megaparsec            >=8.0.0      && <9.3
     , mtl                   ^>=2.2
     , optics                ^>=0.4
     , os-release            ^>=1.0.0
@@ -133,6 +126,7 @@ library
     , safe                  ^>=0.3.18
     , safe-exceptions       ^>=0.1
     , split                 ^>=0.2.3.4
+    , streamly              ^>=0.8.2
     , strict-base           ^>=0.4
     , template-haskell      >=2.7        && <2.18
     , temporary             ^>=1.3
@@ -172,9 +166,12 @@ library
   else
     other-modules:
       GHCup.Utils.File.Posix
+      GHCup.Utils.File.Posix.Foreign
+      GHCup.Utils.File.Posix.Traversals
       GHCup.Utils.Posix
       GHCup.Utils.Prelude.Posix
 
+    c-sources:     cbits/dirutils.c
     build-depends:
       , bz2              >=0.5.0.5 && <1.1
       , terminal-size    ^>=0.3.2.1
@@ -204,6 +201,7 @@ executable ghcup
     GHCup.OptParse.Set
     GHCup.OptParse.ToolRequirements
     GHCup.OptParse.UnSet
+    GHCup.OptParse.Upgrade
     GHCup.OptParse.Whereis
 
   hs-source-dirs:     app/ghcup
@@ -236,19 +234,23 @@ executable ghcup
     , ghcup
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
-    , megaparsec            >=8.0.0    && <9.1
+    , megaparsec            >=8.0.0    && <9.3
     , mtl                   ^>=2.2
-    , optparse-applicative  >=0.15.1.0 && <0.17
+    , 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
-    , temporary             ^>=1.3
+    , tagsoup               ^>=0.14
     , template-haskell      >=2.7      && <2.18
+    , temporary             ^>=1.3
     , text                  ^>=1.2.4.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
 
@@ -262,24 +264,17 @@ executable ghcup
       , brick         ^>=0.64
       , transformers  ^>=0.5
       , unix          ^>=2.7
-      , vector        ^>=0.12
       , vty           >=5.28.2 && <5.34
 
   if os(windows)
     cpp-options: -DIS_WINDOWS
+
   else
-    build-depends:
+    build-depends: unix ^>=2.7
-      , unix             ^>=2.7
 
   if flag(no-exe)
     buildable: False
 
-  if (flag(disable-upgrade))
-    cpp-options:   -DDISABLE_UPGRADE
-  else
-    other-modules:
-        GHCup.OptParse.Upgrade
-
 test-suite ghcup-test
   type:               exitcode-stdio-1.0
   main-is:            Main.hs
@@ -288,6 +283,7 @@ test-suite ghcup-test
   other-modules:
     GHCup.ArbitraryTypes
     GHCup.Types.JSONSpec
+    GHCup.Utils.FileSpec
     Spec
 
   default-language:   Haskell2010
@@ -307,12 +303,15 @@ test-suite ghcup-test
     , base                      >=4.12    && <5
     , bytestring                ^>=0.10
     , containers                ^>=0.6
-    , generic-arbitrary         ^>=0.1.0
+    , directory                 ^>=1.3.6.0
+    , filepath                  ^>=1.4.2.1
+    , generic-arbitrary         >=0.1.0   && <0.3
     , ghcup
-    , hspec                     ^>=2.7.10
+    , hspec                     >=2.7.10  && <2.10
     , hspec-golden-aeson        ^>=0.9
     , QuickCheck                ^>=2.14.1
     , quickcheck-arbitrary-adt  ^>=0.3.1.0
+    , streamly                  ^>=0.8.2
     , text                      ^>=1.2.4.0
     , uri-bytestring            ^>=0.3.2.2
     , versions                  >=4.0.1   && <5.1

lib/GHCup/Download.hs

@@ -69,7 +69,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe
-import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
@@ -121,34 +120,31 @@ getDownloadsF = do
   Settings { urlSource } <- lift getSettings
   case urlSource of
     GHCupURL -> liftE $ getBase ghcupURL
-    (OwnSource url) -> liftE $ getBase url
+    (OwnSource exts) -> do
+      ext  <- liftE $ mapM (either pure getBase) exts
+      mergeGhcupInfo ext
     (OwnSpec av) -> pure av
-    (AddSource (Left ext)) -> do
+    (AddSource exts) -> do
       base <- liftE $ getBase ghcupURL
-      pure (mergeGhcupInfo base ext)
+      ext  <- liftE $ mapM (either pure getBase) exts
-    (AddSource (Right uri)) -> do
+      mergeGhcupInfo (base:ext)
-      base <- liftE $ getBase ghcupURL
-      ext  <- liftE $ getBase uri
-      pure (mergeGhcupInfo base ext)
 
-    where
+ where
-
+  mergeGhcupInfo :: MonadFail m
-  mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
+                 => [GHCupInfo]
-                 -> GHCupInfo -- ^ extension overwriting the base
+                 -> m GHCupInfo
-                 -> GHCupInfo
+  mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
-  mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
+  mergeGhcupInfo xs@(GHCupInfo{}: _) =
-    let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
+    let newDownloads   = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads   <$> xs)
-                                        Just a' -> M.union a' a
+        newGlobalTools = M.unionsWith (\_ a2 -> a2              ) (_globalTools      <$> xs)
-                                        Nothing -> a
+        newToolReqs    = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
-                                    ) base
+    in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
-        newGlobalTools = M.union base2 ext2
-    in GHCupInfo tr newDownloads newGlobalTools
 
 
 yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
 yamlFromCache uri = do
   Dirs{..} <- getDirs
-  pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
+  pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
 
 
 etagsFile :: FilePath -> FilePath
@@ -245,7 +241,7 @@ getBase uri = do
     Settings { metaCache } <- lift getSettings
 
        -- for local files, let's short-circuit and ignore access time
-    if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
+    if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True
        | e -> do
           accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
           let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -584,7 +580,7 @@ downloadCached dli mfn = do
     True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
+      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
 
 
 downloadCached' :: ( MonadReader env m
@@ -602,7 +598,7 @@ downloadCached' :: ( MonadReader env m
                 -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
 downloadCached' dli mfn mDestDir = do
   Dirs { cacheDir } <- lift getDirs
-  let destDir = fromMaybe cacheDir mDestDir
+  let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
   let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
   let cachfile = destDir </> fn
   fileExists <- liftIO $ doesFileExist cachfile

lib/GHCup/Errors.hs

@@ -27,6 +27,7 @@ import           Data.CaseInsensitive           ( CI )
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Haskus.Utils.Variant
+import           System.FilePath
 import           Text.PrettyPrint               hiding ( (<>) )
 import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           URI.ByteString
@@ -145,6 +146,13 @@ instance Pretty NotInstalled where
   pPrint (NotInstalled tool ver) =
     text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
 
+data UninstallFailed = UninstallFailed FilePath [FilePath]
+  deriving Show
+
+instance Pretty UninstallFailed where
+  pPrint (UninstallFailed dir files) =
+    text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
+
 -- | An executable was expected to be in PATH, but was not found.
 data NotFoundInPATH = NotFoundInPATH FilePath
   deriving Show
@@ -291,6 +299,24 @@ instance Pretty HadrianNotFound where
   pPrint HadrianNotFound =
     text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
 
+data GHCupShadowed = GHCupShadowed
+                       FilePath  -- shadow binary
+                       FilePath  -- upgraded binary
+                       Version   -- upgraded version
+  deriving Show
+
+instance Pretty GHCupShadowed where
+  pPrint (GHCupShadowed sh up _) =
+    text ("ghcup is shadowed by "
+         <> sh
+         <> ". The upgrade will not be in effect, unless you remove "
+         <> sh
+         <> " or make sure "
+         <> takeDirectory up
+         <> " comes before "
+         <> takeDirectory sh
+         <> " in PATH."
+         )
 
     -------------------------
     --[ High-level errors ]--

lib/GHCup/Platform.hs

@@ -23,6 +23,7 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Dirs
 import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
@@ -46,7 +47,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.Info
-import           System.Directory
 import           System.OsRelease
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix

lib/GHCup/Requirements.hs

@@ -67,3 +67,9 @@ prettyRequirements Requirements {..} =
         else ""
       n = if not . T.null $ _notes then "\n  Note: " <> _notes else ""
   in  "System requirements " <> d <> n
+
+rawRequirements :: Requirements -> T.Text
+rawRequirements Requirements {..} =
+  if not . null $ _distroPKGs
+  then T.intercalate " " _distroPKGs
+  else ""

lib/GHCup/Types.hs

@@ -26,6 +26,9 @@ module GHCup.Types
   )
   where
 
+import {-# SOURCE #-} GHCup.Utils.Dirs          ( fromGHCupPath )
+import {-# SOURCE #-} GHCup.Utils.Dirs          ( GHCupPath )
+
 import           Control.DeepSeq                ( NFData, rnf )
 import           Data.Map.Strict                ( Map )
 import           Data.List.NonEmpty             ( NonEmpty (..) )
@@ -286,9 +289,9 @@ instance Pretty TarDir where
 
 -- | Where to fetch GHCupDownloads from.
 data URLSource = GHCupURL
-               | OwnSource URI
+               | OwnSource [Either GHCupInfo URI] -- ^ complete source list
                | OwnSpec GHCupInfo
-               | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
+               | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
                deriving (GHC.Generic, Show)
 
 instance NFData URLSource
@@ -438,12 +441,13 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
 instance NFData Settings
 
 data Dirs = Dirs
-  { baseDir  :: FilePath
+  { baseDir  :: GHCupPath
   , binDir   :: FilePath
-  , cacheDir :: FilePath
+  , cacheDir :: GHCupPath
-  , logsDir  :: FilePath
+  , logsDir  :: GHCupPath
-  , confDir  :: FilePath
+  , confDir  :: GHCupPath
-  , recycleDir :: FilePath -- mainly used on windows
+  , dbDir    :: GHCupPath
+  , recycleDir :: GHCupPath -- mainly used on windows
   }
   deriving (Show, GHC.Generic)
 
@@ -628,3 +632,18 @@ data CapturedProcess = CapturedProcess
   deriving (Eq, Show)
 
 makeLenses ''CapturedProcess
+
+
+data InstallDir = IsolateDir FilePath
+                | GHCupInternal
+  deriving (Eq, Show)
+
+data InstallDirResolved = IsolateDirResolved FilePath
+                        | GHCupDir GHCupPath
+                        | GHCupBinDir FilePath
+  deriving (Eq, Show)
+
+fromInstallDir :: InstallDirResolved -> FilePath
+fromInstallDir (IsolateDirResolved fp) = fp
+fromInstallDir (GHCupDir fp) = fromGHCupPath fp
+fromInstallDir (GHCupBinDir fp) = fp

lib/GHCup/Types/JSON.hs

@@ -79,6 +79,38 @@ instance FromJSON Tag where
 instance ToJSON URI where
   toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
 
+instance FromJSON URLSource where
+  parseJSON v =
+        parseGHCupURL v
+    <|> parseOwnSourceLegacy v
+    <|> parseOwnSourceNew1 v
+    <|> parseOwnSourceNew2 v
+    <|> parseOwnSpec v
+    <|> legacyParseAddSource v
+    <|> newParseAddSource v
+   where
+    parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
+      r :: URI <- o .: "OwnSource"
+      pure (OwnSource [Right r])
+    parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
+      r :: [URI] <- o .: "OwnSource"
+      pure (OwnSource (fmap Right r))
+    parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "OwnSource"
+      pure (OwnSource r)
+    parseOwnSpec = withObject "URLSource" $ \o -> do
+      r :: GHCupInfo <- o .: "OwnSpec"
+      pure (OwnSpec r)
+    parseGHCupURL = withObject "URLSource" $ \o -> do
+      _ :: [Value] <- o .: "GHCupURL"
+      pure GHCupURL
+    legacyParseAddSource = withObject "URLSource" $ \o -> do
+      r :: Either GHCupInfo URI <- o .: "AddSource"
+      pure (AddSource [r])
+    newParseAddSource = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "AddSource"
+      pure (AddSource r)
+
 instance FromJSON URI where
   parseJSON = withText "URL" $ \t ->
     case parseURI strictURIParserOptions (encodeUtf8 t) of
@@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
-deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
+deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings

lib/GHCup/Utils.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -71,7 +72,6 @@ import           GHC.IO.Exception
 import           Haskus.Utils.Variant.Excepts
 import           Optics
 import           Safe
-import           System.Directory      hiding   ( findFiles )
 import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
@@ -86,6 +86,9 @@ import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
 import qualified Data.List.NonEmpty            as NE
+import qualified Streamly.Prelude              as S
+import Control.DeepSeq (force)
+import GHC.IO (evaluate)
 
 
 -- $setup
@@ -277,14 +280,14 @@ rmPlainHLS = do
 ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
-  liftIO $ doesDirectoryExist 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 (ghcdir </> ghcUpSrcBuiltFile)
+  liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
 
 
 -- | Whether the given GHC version is set as the current.
@@ -317,17 +320,17 @@ ghcSet mtarget = do
            MP.setInput rest
            pure x
          )
-        <* pathSep
+        <* MP.some pathSep
         <* MP.takeRest
         <* MP.eof
-    ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
+    ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep
 
 -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
 -- If a dir cannot be parsed, returns left.
 getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
 getInstalledGHCs = do
   ghcdir <- ghcupGHCBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
+  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir)
   forM fs $ \f -> case parseGHCupGHCDir f of
     Right r -> pure $ Right r
     Left  _ -> pure $ Left f
@@ -398,10 +401,10 @@ cabalSet = do
   cabalParse = MP.chunk "cabal-" *> version'
   -- parses any path component ending with path separator,
   -- e.g. "foo/"
-  stripPathComponet = parseUntil1 pathSep *> pathSep
+  stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
   -- parses an absolute path up until the last path separator,
   -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-  stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
+  stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
   -- parses a relative path up until the last path separator,
   -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
   stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -430,7 +433,7 @@ getInstalledHLSs = do
         Nothing        -> pure $ Left f
 
   hlsdir <- ghcupHLSBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
+  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir)
   new <- forM fs $ \f -> case parseGHCupHLSDir f of
     Right r -> pure $ Right r
     Left  _ -> pure $ Left f
@@ -492,10 +495,10 @@ stackSet = do
     cabalParse = MP.chunk "stack-" *> version'
     -- parses any path component ending with path separator,
     -- e.g. "foo/"
-    stripPathComponet = parseUntil1 pathSep *> pathSep
+    stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
     -- parses an absolute path up until the last path separator,
     -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-    stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
+    stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
     -- parses a relative path up until the last path separator,
     -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
     stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -515,7 +518,7 @@ hlsInstalled ver = do
 isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
 isLegacyHLS ver = do
   bdir <- ghcupHLSDir ver
-  not <$> liftIO (doesDirectoryExist bdir)
+  not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir)
 
 
 -- Return the currently set hls version, if any.
@@ -543,10 +546,10 @@ hlsSet = do
     cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
     -- parses any path component ending with path separator,
     -- e.g. "foo/"
-    stripPathComponet = parseUntil1 pathSep *> pathSep
+    stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
     -- parses an absolute path up until the last path separator,
     -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-    stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
+    stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
     -- parses a relative path up until the last path separator,
     -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
     stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -616,7 +619,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr
                           -> m [FilePath]
 hlsInternalServerScripts ver mghcVer = do
   dir <- ghcupHLSDir ver
-  let bdir = dir </> "bin"
+  let bdir = fromGHCupPath dir </> "bin"
   fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
     <$> liftIO (listDirectory bdir)
 
@@ -627,7 +630,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh
                           -> Maybe Version   -- ^ optional GHC version
                           -> m [FilePath]
 hlsInternalServerBinaries ver mghcVer = do
-  dir <- ghcupHLSDir ver
+  dir <- fromGHCupPath <$> ghcupHLSDir ver
   let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
   (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
   fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
@@ -641,7 +644,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow
                       -> Version   -- ^ GHC version
                       -> m [FilePath]
 hlsInternalServerLibs ver ghcVer = do
-  dir <- ghcupHLSDir ver
+  dir <- fromGHCupPath <$> ghcupHLSDir ver
   let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
   (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
   fmap (bdir </>) <$> liftIO (listDirectory bdir)
@@ -845,21 +848,21 @@ getArchiveFiles av = do
 
 
 intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
-           => FilePath       -- ^ unpacked tar dir
+           => GHCupPath       -- ^ unpacked tar dir
            -> TarDir         -- ^ how to descend
-           -> Excepts '[TarDirDoesNotExist] m FilePath
+           -> Excepts '[TarDirDoesNotExist] m GHCupPath
 intoSubdir bdir tardir = case tardir of
   RealDir pr -> do
-    whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
+    whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr))
           (throwE $ TarDirDoesNotExist tardir)
-    pure (bdir </> pr)
+    pure (bdir `appendGHCupPath` pr)
   RegexDir r -> do
     let rs = split (`elem` pathSeparators) r
     foldlM
       (\y x ->
-        (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
+        (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
           []      -> throwE $ TarDirDoesNotExist tardir
-          (p : _) -> pure (y </> p)) . sort
+          (p : _) -> pure (y `appendGHCupPath` p)) . sort
       )
       bdir
       rs
@@ -905,7 +908,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
                   => GHCTargetVersion
                   -> m FilePath
 ghcInternalBinDir ver = do
-  ghcdir <- ghcupGHCDir ver
+  ghcdir <- fromGHCupPath <$> ghcupGHCDir ver
   pure (ghcdir </> "bin")
 
 
@@ -1029,6 +1032,8 @@ darwinNotarization Darwin path = exec
 darwinNotarization _ _ = pure $ Right ()
 
 
+
+
 getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
 getChangeLog dls tool (Left v') =
   preview (ix tool % ix v' % viChangeLog % _Just) dls
@@ -1039,7 +1044,6 @@ getChangeLog dls tool (Right tag) =
 -- | Execute a build action while potentially cleaning up:
 --
 --   1. the build directory, depending on the KeepDirs setting
---   2. the install destination, depending on whether the build failed
 runBuildAction :: ( MonadReader env m
                   , HasDirs env
                   , HasSettings env
@@ -1050,15 +1054,12 @@ runBuildAction :: ( MonadReader env m
                   , MonadFail m
                   , MonadCatch m
                   )
-               => FilePath        -- ^ build directory (cleaned up depending on Settings)
+               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
-               -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts e m a
-runBuildAction bdir instdir action = do
+runBuildAction bdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
-        forM_ instdir $ \dir ->
-          hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
           $ rmBDir bdir
   v <-
@@ -1080,7 +1081,7 @@ cleanUpOnError :: ( MonadReader env m
                   , MonadFail m
                   , MonadCatch m
                   )
-               => FilePath        -- ^ build directory (cleaned up depending on Settings)
+               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
                -> Excepts e m a
                -> Excepts e m a
 cleanUpOnError bdir action = do
@@ -1089,13 +1090,33 @@ cleanUpOnError bdir action = do
   flip onException (lift exAction) $ onE_ exAction action
 
 
+-- | Clean up the given directory if the action fails,
+-- depending on the Settings.
+cleanFinally :: ( MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadIO m
+                  , MonadMask m
+                  , HasLog env
+                  , MonadUnliftIO m
+                  , MonadFail m
+                  , MonadCatch m
+                  )
+               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
+               -> Excepts e m a
+               -> Excepts e m a
+cleanFinally bdir action = do
+  Settings {..} <- lift getSettings
+  let exAction = when (keepDirs == Never) $ rmBDir bdir
+  flip finally (lift exAction) $ onE_ exAction action
+
 
 -- | Remove a build directory, ignoring if it doesn't exist and gracefully
 -- printing other errors without crashing.
-rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
+rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
 rmBDir dir = withRunInIO (\run -> run $
            liftIO $ handleIO (\e -> run $ logWarn $
-               "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
+               "Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e))
            $ hideError doesNotExistErrorType
            $ rmPathForcibly dir)
 
@@ -1181,7 +1202,7 @@ createLink :: ( MonadMask m
 createLink link exe
   | isWindows = do
       dirs <- getDirs
-      let shimGen = cacheDir dirs </> "gs.exe"
+      let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
 
       let shim = dropExtension exe <.> "shim"
           -- For hardlinks, link needs to be absolute.
@@ -1194,7 +1215,7 @@ createLink link exe
       rmLink exe
 
       logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
-      liftIO $ copyFile shimGen exe
+      liftIO $ copyFile shimGen exe False
       liftIO $ writeFile shim shimContents
   | otherwise = do
       logDebug $ "rm -f " <> T.pack exe
@@ -1225,8 +1246,8 @@ ensureGlobalTools
       let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
       void $ (\DigestError{} -> do
           lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
-          lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
+          lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
-          lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
+          lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
           liftE @'[GPGError, DigestError , DownloadFailed] $ dl
         ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
   | otherwise = pure ()
@@ -1234,14 +1255,15 @@ ensureGlobalTools
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
-  createDirRecursive' baseDir
+  createDirRecursive' (fromGHCupPath baseDir)
-  createDirRecursive' (baseDir </> "ghc")
+  createDirRecursive' (fromGHCupPath baseDir </> "ghc")
   createDirRecursive' binDir
-  createDirRecursive' cacheDir
+  createDirRecursive' (fromGHCupPath cacheDir)
-  createDirRecursive' logsDir
+  createDirRecursive' (fromGHCupPath logsDir)
-  createDirRecursive' confDir
+  createDirRecursive' (fromGHCupPath confDir)
-  createDirRecursive' trashDir
+  createDirRecursive' (fromGHCupPath trashDir)
+  createDirRecursive' (fromGHCupPath dbDir)
   pure ()
 
 
@@ -1264,10 +1286,31 @@ ghcBinaryName (GHCTargetVersion Nothing  _) = T.unpack ("ghc" <> T.pack exeExt)
 --   3. if it exists and is non-empty -> panic and leave the house
 installDestSanityCheck :: ( MonadIO m
                           , MonadCatch m
+                          , MonadMask m
                           ) =>
-                          FilePath ->
+                          InstallDirResolved ->
                           Excepts '[DirNotEmpty] m ()
-installDestSanityCheck isoDir = do
+installDestSanityCheck (IsolateDirResolved isoDir) = do
   hideErrorDef [doesNotExistErrorType] () $ do
-    contents <- liftIO $ getDirectoryContentsRecursive isoDir
+    empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir
-    unless (null contents) (throwE $ DirNotEmpty isoDir)
+    when (not empty') (throwE $ DirNotEmpty isoDir)
+installDestSanityCheck _ = pure ()
+
+
+-- | Returns 'Nothing' for legacy installs.
+getInstalledFiles :: ( MonadIO m
+                     , MonadCatch m
+                     , MonadReader env m
+                     , HasDirs env
+                     , MonadFail m
+                     )
+                  => Tool
+                  -> GHCTargetVersion
+                  -> m (Maybe [FilePath])
+getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
+  f <- recordedInstallationFile t v'
+  (force -> !c) <- liftIO
+    (readFile f >>= evaluate)
+  pure (Just $ lines c)
+
+

lib/GHCup/Utils/Dirs.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE QuasiQuotes           #-}
 
 {-|
 Module      : GHCup.Utils.Dirs
@@ -30,6 +31,74 @@ module GHCup.Utils.Dirs
   , getConfigFilePath
   , useXDG
   , cleanupTrash
+
+  , GHCupPath
+  , appendGHCupPath
+  , fromGHCupPath
+  , createTempGHCupDirectory
+  , getGHCupTmpDirs
+
+  , removeDirectory
+  , removeDirectoryRecursive
+  , removePathForcibly
+
+  -- System.Directory re-exports
+  , createDirectory
+  , createDirectoryIfMissing
+  , renameDirectory
+  , listDirectory
+  , getDirectoryContents
+  , getCurrentDirectory
+  , setCurrentDirectory
+  , withCurrentDirectory
+  , getHomeDirectory
+  , XdgDirectory(..)
+  , getXdgDirectory
+  , XdgDirectoryList(..)
+  , getXdgDirectoryList
+  , getAppUserDataDirectory
+  , getUserDocumentsDirectory
+  , getTemporaryDirectory
+  , removeFile
+  , renameFile
+  , renamePath
+  , getFileSize
+  , canonicalizePath
+  , makeAbsolute
+  , makeRelativeToCurrentDirectory
+  , doesPathExist
+  , doesFileExist
+  , doesDirectoryExist
+  , findExecutable
+  , findExecutables
+  , findExecutablesInDirectories
+  , findFile
+  , findFileWith
+  , findFilesWith
+  , exeExtension
+  , createFileLink
+  , createDirectoryLink
+  , removeDirectoryLink
+  , pathIsSymbolicLink
+  , getSymbolicLinkTarget
+  , Permissions
+  , emptyPermissions
+  , readable
+  , writable
+  , executable
+  , searchable
+  , setOwnerReadable
+  , setOwnerWritable
+  , setOwnerExecutable
+  , setOwnerSearchable
+  , getPermissions
+  , setPermissions
+  , copyPermissions
+  , getAccessTime
+  , getModificationTime
+  , setAccessTime
+  , setModificationTime
+  , isSymbolicLink
   )
 where
 
@@ -41,23 +110,36 @@ import           GHCup.Types.Optics
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.String.QQ
 
+import           Control.DeepSeq (NFData, rnf)
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Unlift
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource hiding (throwM)
+import           Data.List
+import           Data.ByteString                ( ByteString )
 import           Data.Bifunctor
 import           Data.Maybe
 import           Data.Versions
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-import           System.Directory                                                
+import           Safe
-import           System.DiskSpace                                                
+import           System.Directory hiding ( removeDirectory
+                                         , removeDirectoryRecursive
+                                         , removePathForcibly
+                                         , findFiles
+                                         )
+import qualified System.Directory              as SD
+
+import           System.DiskSpace
 import           System.Environment
 import           System.FilePath
 import           System.IO.Temp
+import           Text.Regex.Posix
 
 import qualified Data.ByteString               as BS
 import qualified Data.Text                     as T
@@ -67,6 +149,41 @@ import Control.Concurrent (threadDelay)
 
 
 
+    ---------------------------
+    --[ GHCupPath utilities ]--
+    ---------------------------
+
+-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
+--
+-- The constructor is not exported.
+newtype GHCupPath = GHCupPath FilePath
+  deriving (Show, Eq, Ord)
+
+instance NFData GHCupPath where
+  rnf (GHCupPath fp) = rnf fp
+
+appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
+appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)
+
+fromGHCupPath :: GHCupPath -> FilePath
+fromGHCupPath (GHCupPath gp) = gp
+
+createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
+createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d
+
+
+getGHCupTmpDirs :: IO [GHCupPath]
+getGHCupTmpDirs = do
+  tmpdir <- getCanonicalTemporaryDirectory
+  ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
+    tmpdir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^ghcup-.*$|] :: ByteString)
+    )
+  pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)
+
+
     ------------------------------
     --[ GHCup base directories ]--
     ------------------------------
@@ -76,11 +193,11 @@ import Control.Concurrent (threadDelay)
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
-ghcupBaseDir :: IO FilePath
+ghcupBaseDir :: IO GHCupPath
 ghcupBaseDir
   | isWindows = do
       bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
-      pure (bdir </> "ghcup")
+      pure (GHCupPath (bdir </> "ghcup"))
   | otherwise = do
       xdg <- useXDG
       if xdg
@@ -90,19 +207,19 @@ ghcupBaseDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".local" </> "share")
-          pure (bdir </> "ghcup")
+          pure (GHCupPath (bdir </> "ghcup"))
         else do
           bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
             Just r  -> pure r
             Nothing -> liftIO getHomeDirectory
-          pure (bdir </> ".ghcup")
+          pure (GHCupPath (bdir </> ".ghcup"))
 
 
 -- | ~/.ghcup by default
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
-ghcupConfigDir :: IO FilePath
+ghcupConfigDir :: IO GHCupPath
 ghcupConfigDir
   | isWindows = ghcupBaseDir
   | otherwise = do
@@ -114,12 +231,12 @@ ghcupConfigDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".config")
-          pure (bdir </> "ghcup")
+          pure (GHCupPath (bdir </> "ghcup"))
         else do
           bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
             Just r  -> pure r
             Nothing -> liftIO getHomeDirectory
-          pure (bdir </> ".ghcup")
+          pure (GHCupPath (bdir </> ".ghcup"))
 
 
 -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -127,7 +244,7 @@ ghcupConfigDir
 -- (which, sadly is not strictly xdg spec).
 ghcupBinDir :: IO FilePath
 ghcupBinDir
-  | isWindows = ghcupBaseDir <&> (</> "bin")
+  | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
   | otherwise = do
       xdg <- useXDG
       if xdg
@@ -137,16 +254,16 @@ ghcupBinDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".local" </> "bin")
-        else ghcupBaseDir <&> (</> "bin")
+        else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
 
 
 -- | Defaults to '~/.ghcup/cache'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
-ghcupCacheDir :: IO FilePath
+ghcupCacheDir :: IO GHCupPath
 ghcupCacheDir
-  | isWindows = ghcupBaseDir <&> (</> "cache")
+  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
   | otherwise = do
       xdg <- useXDG
       if xdg
@@ -156,17 +273,17 @@ ghcupCacheDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".cache")
-          pure (bdir </> "ghcup")
+          pure (GHCupPath (bdir </> "ghcup"))
-        else ghcupBaseDir <&> (</> "cache")
+        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
 
 
 -- | Defaults to '~/.ghcup/logs'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
-ghcupLogsDir :: IO FilePath
+ghcupLogsDir :: IO GHCupPath
 ghcupLogsDir
-  | isWindows = ghcupBaseDir <&> (</> "logs")
+  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
   | otherwise = do
       xdg <- useXDG
       if xdg
@@ -176,14 +293,34 @@ ghcupLogsDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".cache")
-          pure (bdir </> "ghcup" </> "logs")
+          pure (GHCupPath (bdir </> "ghcup" </> "logs"))
-        else ghcupBaseDir <&> (</> "logs")
+        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
+
+
+-- | Defaults to '~/.ghcup/db.
+--
+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
+-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
+ghcupDbDir :: IO GHCupPath
+ghcupDbDir
+  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
+          pure (GHCupPath (bdir </> "ghcup" </> "db"))
+        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
 
 
 -- | '~/.ghcup/trash'.
 -- Mainly used on windows to improve file removal operations
-ghcupRecycleDir :: IO FilePath
+ghcupRecycleDir :: IO GHCupPath
-ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
+ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
 
 
 
@@ -195,6 +332,7 @@ getAllDirs = do
   logsDir    <- ghcupLogsDir
   confDir    <- ghcupConfigDir
   recycleDir <- ghcupRecycleDir
+  dbDir      <- ghcupDbDir
   pure Dirs { .. }
 
 
@@ -206,7 +344,7 @@ getAllDirs = do
 getConfigFilePath :: (MonadIO m) => m FilePath
 getConfigFilePath = do
   confDir <- liftIO ghcupConfigDir
-  pure $ confDir </> "config.yaml"
+  pure $ fromGHCupPath confDir </> "config.yaml"
 
 ghcupConfigFile :: (MonadIO m)
                 => Excepts '[JSONError] m UserSettings
@@ -224,10 +362,10 @@ ghcupConfigFile = do
 
 
 -- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
 ghcupGHCBaseDir = do
   Dirs {..}  <- getDirs
-  pure (baseDir </> "ghc")
+  pure (baseDir `appendGHCupPath` "ghc")
 
 
 -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -236,11 +374,11 @@ ghcupGHCBaseDir = do
 --   * 8.8.4
 ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
             => GHCTargetVersion
-            -> m FilePath
+            -> m GHCupPath
 ghcupGHCDir ver = do
   ghcbasedir <- ghcupGHCBaseDir
   let verdir = T.unpack $ tVerToText ver
-  pure (ghcbasedir </> verdir)
+  pure (ghcbasedir `appendGHCupPath` verdir)
 
 
 -- | See 'ghcupToolParser'.
@@ -253,19 +391,19 @@ parseGHCupHLSDir (T.pack -> fp) =
   throwEither $ MP.parse version' "" fp
 
 -- | ~/.ghcup/hls by default, for new-style installs.
-ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
 ghcupHLSBaseDir = do
   Dirs {..}  <- getDirs
-  pure (baseDir </> "hls")
+  pure (baseDir `appendGHCupPath` "hls")
 
 -- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
 ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
             => Version
-            -> m FilePath
+            -> m GHCupPath
 ghcupHLSDir ver = do
   basedir <- ghcupHLSBaseDir
   let verdir = T.unpack $ prettyVer ver
-  pure (basedir </> verdir)
+  pure (basedir `appendGHCupPath` verdir)
 
 mkGhcupTmpDir :: ( MonadReader env m
                  , HasDirs env
@@ -275,8 +413,8 @@ mkGhcupTmpDir :: ( MonadReader env m
                  , MonadThrow m
                  , MonadMask m
                  , MonadIO m)
-              => m FilePath
+              => m GHCupPath
-mkGhcupTmpDir = do
+mkGhcupTmpDir = GHCupPath <$> do
   tmpdir <- liftIO getCanonicalTemporaryDirectory
 
   let minSpace = 5000 -- a rough guess, aight?
@@ -312,14 +450,14 @@ withGHCupTmpDir :: ( MonadReader env m
                    , MonadThrow m
                    , MonadMask m
                    , MonadIO m)
-                => m FilePath
+                => m GHCupPath
 withGHCupTmpDir = snd <$> withRunInIO (\run ->
   run
     $ allocate
         (run mkGhcupTmpDir)
         (\fp ->
             handleIO (\e -> run
-                $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
+                $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
             . rmPathForcibly
             $ fp))
 
@@ -339,13 +477,15 @@ useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
 relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
                 -> FilePath  -- ^ the symlink destination
                 -> FilePath
-relativeSymlink p1 p2 =
+relativeSymlink p1 p2
-  let d1      = splitDirectories p1
+  | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
-      d2      = splitDirectories p2
+  | otherwise =
-      common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
+    let d1      = splitDirectories p1
-      cPrefix = drop (length common) d1
+        d2      = splitDirectories p2
-  in  joinPath (replicate (length cPrefix) "..")
+        common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
-        <> joinPath ([pathSeparator] : drop (length common) d2)
+        cPrefix = drop (length common) d1
+    in  joinPath (replicate (length cPrefix) "..")
+          <> joinPath ([pathSeparator] : drop (length common) d2)
 
 
 cleanupTrash :: ( MonadIO m
@@ -358,12 +498,27 @@ cleanupTrash :: ( MonadIO m
              => m ()
 cleanupTrash = do
   Dirs { recycleDir } <- getDirs
-  contents <- liftIO $ listDirectory recycleDir
+  contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
   if null contents
   then pure ()
   else do
-    logWarn ("Removing leftover files in " <> T.pack recycleDir)
+    logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir))
     forM_ contents (\fp -> handleIO (\e ->
         logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
-      ) $ liftIO $ removePathForcibly (recycleDir </> fp))
+      ) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp))
+
+
+
+-- System.Directory re-exports with GHCupPath
+
+removeDirectory :: GHCupPath -> IO ()
+removeDirectory (GHCupPath fp) = SD.removeDirectory fp
+
+removeDirectoryRecursive :: GHCupPath -> IO ()
+removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp
+
+removePathForcibly :: GHCupPath -> IO ()
+removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
+
+
 

lib/GHCup/Utils/Dirs.hs-boot

@@ -0,0 +1,37 @@
+module GHCup.Utils.Dirs
+ ( GHCupPath
+ , appendGHCupPath
+ , fromGHCupPath
+ , createTempGHCupDirectory
+ , removeDirectory
+ , removeDirectoryRecursive
+ , removePathForcibly
+ )
+ where
+
+import Control.DeepSeq (NFData)
+
+
+-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
+newtype GHCupPath = GHCupPath FilePath
+
+instance Show GHCupPath where
+
+instance Eq GHCupPath where
+
+instance Ord GHCupPath where
+
+instance NFData GHCupPath where
+
+appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
+
+fromGHCupPath :: GHCupPath -> FilePath
+
+createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
+
+removeDirectory :: GHCupPath -> IO ()
+
+removeDirectoryRecursive :: GHCupPath -> IO ()
+
+removePathForcibly :: GHCupPath -> IO ()
+

lib/GHCup/Utils/File.hs

@@ -1,17 +1,160 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module GHCup.Utils.File (
+  mergeFileTree,
+  copyFileE,
+  findFilesDeep,
+  getDirectoryContentsRecursive,
+  getDirectoryContentsRecursiveBFS,
+  getDirectoryContentsRecursiveDFS,
+  getDirectoryContentsRecursiveUnsafe,
+  getDirectoryContentsRecursiveBFSUnsafe,
+  getDirectoryContentsRecursiveDFSUnsafe,
+  recordedInstallationFile,
   module GHCup.Utils.File.Common,
-#if IS_WINDOWS
+
-  module GHCup.Utils.File.Windows
+  executeOut,
-#else
+  execLogged,
-  module GHCup.Utils.File.Posix
+  exec,
-#endif
+  toProcessError,
+  chmod_755,
+  isBrokenSymlink,
+  copyFile,
+  deleteFile,
+  install,
+  removeEmptyDirectory,
 ) where
 
+import GHCup.Utils.Dirs
 import GHCup.Utils.File.Common
 #if IS_WINDOWS
 import GHCup.Utils.File.Windows
 #else
 import GHCup.Utils.File.Posix
 #endif
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.Optics
+import           GHCup.Utils.Prelude
+
+import           Text.Regex.Posix
+import           Control.Exception.Safe
+import           Haskus.Utils.Variant.Excepts
+import           Control.Monad.Reader
+import           System.FilePath
+import           Text.PrettyPrint.HughesPJClass (prettyShow)
+
+import qualified Data.Text                     as T
+import qualified Streamly.Prelude              as S
+
+
+mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env)
+              => GHCupPath                       -- ^ source base directory from which to install findFiles
+              -> InstallDirResolved              -- ^ destination base dir
+              -> Tool
+              -> GHCTargetVersion
+              -> (FilePath -> FilePath -> m ())  -- ^ file copy operation
+              -> m ()
+mergeFileTree sourceBase destBase tool v' copyOp = do
+  -- These checks are not atomic, but we perform them to have
+  -- the opportunity to abort before copying has started.
+  --
+  -- The actual copying might still fail.
+  liftIO $ baseCheck (fromGHCupPath sourceBase)
+  liftIO $ destCheck (fromInstallDir destBase)
+
+  recFile <- recordedInstallationFile tool v'
+  case destBase of
+    IsolateDirResolved _ -> pure ()
+    _ -> do
+      whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
+      liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
+
+  flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
+    copy f
+    recordInstalledFile f recFile
+    pure f
+
+ where
+  recordInstalledFile f recFile = do
+    case destBase of
+      IsolateDirResolved _ -> pure ()
+      _ -> liftIO $ appendFile recFile (f <> "\n")
+
+  copy source = do
+    let dest = fromInstallDir destBase </> source
+        src  = fromGHCupPath sourceBase </> source
+
+    when (isAbsolute source)
+      $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
+
+    liftIO . createDirectoryIfMissing True . takeDirectory $ dest
+
+    copyOp src dest
+
+
+  baseCheck src = do
+      when (isRelative src)
+        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
+      whenM (not <$> doesDirectoryExist src)
+        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
+  destCheck dest = do
+      when (isRelative dest)
+        $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
+
+
+
+copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
+copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
+
+
+-- | List all the files in a directory and all subdirectories.
+--
+-- The order places files in sub-directories after all the files in their
+-- parent directories. The list is generated lazily so is not well defined if
+-- the source directory structure changes before the list is used.
+--
+-- depth first
+getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                 => GHCupPath
+                                 -> S.SerialT m FilePath
+getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
+
+-- breadth first
+getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                 => GHCupPath
+                                 -> S.SerialT m FilePath
+getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
+
+
+getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                              => GHCupPath
+                              -> S.SerialT m FilePath
+getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
+
+getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                    => FilePath
+                                    -> S.SerialT m FilePath
+getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
+
+findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
+findFilesDeep path regex =
+  S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
+
+
+recordedInstallationFile :: ( MonadReader env m
+                            , HasDirs env
+                            )
+                         => Tool
+                         -> GHCTargetVersion
+                         -> m FilePath
+recordedInstallationFile t v' = do
+  Dirs {..}  <- getDirs
+  pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
+

lib/GHCup/Utils/File/Common.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
 
@@ -15,14 +16,16 @@ import           Data.Maybe
 import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
+import           System.Directory hiding ( removeDirectory
-import           System.Directory        hiding (findFiles)
+                                         , removeDirectoryRecursive
+                                         , removePathForcibly
+                                         , findFiles
+                                         )
 import           System.FilePath
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 
+
 import qualified Data.Text                     as T
-import qualified Data.ByteString.Lazy          as BL
 import qualified Text.Megaparsec               as MP
 
 
@@ -96,10 +99,6 @@ findFiles path regex = do
   contents <- listDirectory path
   pure $ filter (match regex) contents
 
-findFilesDeep :: FilePath -> Regex -> IO [FilePath]
-findFilesDeep path regex = do
-  contents <- getDirectoryContentsRecursive path
-  pure $ filter (match regex) contents
 
 findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
 findFiles' path parser = do
@@ -109,3 +108,5 @@ findFiles' path parser = do
 
 checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
 checkFileAlreadyExists fp = liftIO $ doesFileExist fp
+
+

lib/GHCup/Utils/File/Posix.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DataKinds  #-}
+{-# LANGUAGE MultiWayIf  #-}
 
 {-|
 Module      : GHCup.Utils.File.Posix
@@ -15,15 +17,17 @@ Some of these functions use sophisticated logging.
 -}
 module GHCup.Utils.File.Posix where
 
+import           GHCup.Utils.Dirs
 import           GHCup.Utils.File.Common
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.Utils.File.Posix.Traversals
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
-import           Control.Exception              ( evaluate )
+import qualified Control.Exception              as E
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.Reader
@@ -34,12 +38,15 @@ import           Data.IORef
 import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
+import           Foreign.C.String
+import           Foreign.C.Types
 import           GHC.IO.Exception
-import           System.IO                      ( stderr )
+import           System.IO                      ( stderr, hClose, hSetBinaryMode )
 import           System.IO.Error
 import           System.FilePath
-import           System.Directory
 import           System.Posix.Directory
+import           System.Posix.Error             ( throwErrnoPathIfMinus1Retry )
+import           System.Posix.Internals         ( withFilePath )
 import           System.Posix.Files
 import           System.Posix.IO
 import           System.Posix.Process           ( ProcessStatus(..) )
@@ -50,12 +57,27 @@ import qualified Control.Exception             as EX
 import qualified Data.Sequence                 as Sq
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
+import qualified System.Posix.Directory        as PD
+import qualified System.Posix.Files            as PF
 import qualified System.Posix.Process          as SPP
+import qualified System.Posix.IO               as SPI
 import qualified System.Console.Terminal.Size  as TP
+import qualified System.Posix as Posix
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified "unix-bytestring" System.Posix.IO.ByteString
                                                as SPIB
+import qualified Streamly.FileSystem.Handle    as FH
+import qualified Streamly.Internal.FileSystem.Handle
+                                               as IFH
+import qualified Streamly.Prelude              as S
+import qualified GHCup.Utils.File.Posix.Foreign as FD
+import qualified Streamly.Internal.Data.Stream.StreamD.Type
+                                               as D
+import           Streamly.Internal.Data.Unfold.Type
+import qualified Streamly.Internal.Data.Unfold as U
+import           Streamly.Internal.Control.Concurrent ( withRunInIO )
+import           Streamly.Internal.Data.IOFinalizer   ( newIOFinalizer, runIOFinalizer )
 
 
 
@@ -87,7 +109,7 @@ execLogged exe args chdir lfile env = do
   Settings {..} <- getSettings
   Dirs {..} <- getDirs
   logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
-  let logfile = logsDir </> lfile <> ".log"
+  let logfile = fromGHCupPath logsDir </> lfile <> ".log"
   liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
                    closeFd
                    (action verbose noColor)
@@ -262,7 +284,7 @@ captureOutStreams action = do
 
         -- execute the action
         a <- action
-        void $ evaluate a
+        void $ E.evaluate a
 
       -- close everything we don't need
       closeFd childStdoutWrite
@@ -399,3 +421,201 @@ isBrokenSymlink fp = do
     Right b -> pure b
     Left e | isDoesNotExistError e -> pure False
            | otherwise -> throwIO e
+
+copyFile :: FilePath   -- ^ source file
+         -> FilePath   -- ^ destination file
+         -> Bool       -- ^ fail if file exists
+         -> IO ()
+copyFile from to fail' = do
+  bracket
+    (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
+    (hClose . snd)
+    $ \(fromFd, fH) -> do
+        sourceFileMode <- fileMode <$> getFdStatus fromFd
+        let dflags = [ FD.oNofollow
+                     , if fail' then FD.oExcl else FD.oTrunc
+                     ]
+        bracket
+          (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
+          (hClose . snd)
+          $ \(_, tH) -> do
+              hSetBinaryMode fH True
+              hSetBinaryMode tH True
+              streamlyCopy (fH, tH)
+ where
+  openFdHandle fp omode flags fM = do
+    fd      <- openFd' fp omode flags fM
+    handle' <- SPI.fdToHandle fd
+    pure (fd, handle')
+  streamlyCopy (fH, tH) =
+    S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
+
+foreign import ccall unsafe "open"
+   c_open :: CString -> CInt -> Posix.CMode -> IO CInt
+
+
+open_  :: CString
+       -> Posix.OpenMode
+       -> [FD.Flags]
+       -> Maybe Posix.FileMode
+       -> IO Posix.Fd
+open_ str how optional_flags maybe_mode = do
+    fd <- c_open str all_flags mode_w
+    return (Posix.Fd fd)
+  where
+    all_flags  = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
+
+
+    (creat, mode_w) = case maybe_mode of
+                        Nothing -> ([],0)
+                        Just x  -> ([FD.oCreat], x)
+
+    open_mode = case how of
+                   Posix.ReadOnly  -> FD.oRdonly
+                   Posix.WriteOnly -> FD.oWronly
+                   Posix.ReadWrite -> FD.oRdwr
+
+
+-- |Open and optionally create this file. See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+--
+-- Note that passing @Just x@ as the 4th argument triggers the
+-- `oCreat` status flag, which must be set when you pass in `oExcl`
+-- to the status flags. Also see the manpage for @open(2)@.
+openFd' :: FilePath
+        -> Posix.OpenMode
+        -> [FD.Flags]               -- ^ status flags of @open(2)@
+        -> Maybe Posix.FileMode  -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
+        -> IO Posix.Fd
+openFd' name how optional_flags maybe_mode =
+   withFilePath name $ \str ->
+     throwErrnoPathIfMinus1Retry "openFd" name $
+       open_ str how optional_flags maybe_mode
+
+
+-- |Deletes the given file. Raises `eISDIR`
+-- if run on a directory. Does not follow symbolic links.
+--
+-- Throws:
+--
+--    - `InappropriateType` for wrong file type (directory)
+--    - `NoSuchThing` if the file does not exist
+--    - `PermissionDenied` if the directory cannot be read
+--
+-- Notes: calls `unlink`
+deleteFile :: FilePath -> IO ()
+deleteFile = removeLink
+
+
+-- |Recreate a symlink.
+--
+-- In `Overwrite` copy mode only files and empty directories are deleted.
+--
+-- Safety/reliability concerns:
+--
+--    * `Overwrite` mode is inherently non-atomic
+--
+-- Throws:
+--
+--    - `InvalidArgument` if source file is wrong type (not a symlink)
+--    - `PermissionDenied` if output directory cannot be written to
+--    - `PermissionDenied` if source directory cannot be opened
+--    - `SameFile` if source and destination are the same file
+--      (`HPathIOException`)
+--
+--
+-- Throws in `Strict` mode only:
+--
+--    - `AlreadyExists` if destination already exists
+--
+-- Throws in `Overwrite` mode only:
+--
+--    - `UnsatisfiedConstraints` if destination file is non-empty directory
+--
+-- Notes:
+--
+--    - calls `symlink`
+recreateSymlink :: FilePath   -- ^ the old symlink file
+                -> FilePath   -- ^ destination file
+                -> Bool       -- ^ fail if destination file exists
+                -> IO ()
+recreateSymlink symsource newsym fail' = do
+  sympoint <- readSymbolicLink symsource
+  case fail' of
+    True  -> pure ()
+    False ->
+      hideError doesNotExistErrorType $ deleteFile newsym
+  createSymbolicLink sympoint newsym
+
+
+-- copys files, recreates symlinks, fails on all other types
+install :: FilePath -> FilePath -> Bool -> IO ()
+install from to fail' = do
+  fs <- PF.getSymbolicLinkStatus from
+  decide fs
+ where
+  decide fs | PF.isRegularFile fs     = copyFile from to fail'
+            | PF.isSymbolicLink fs    = recreateSymlink from to fail'
+            | otherwise               = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
+
+
+removeEmptyDirectory :: FilePath -> IO ()
+removeEmptyDirectory = PD.removeDirectory
+
+
+-- | Create an 'Unfold' of directory contents.
+unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
+unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
+ where
+  {-# INLINE [0] step #-}
+  step dirstream = do
+    (typ, e) <- liftIO $ readDirEnt dirstream
+    return $ if
+      | null e    -> D.Stop
+      | "." == e  -> D.Skip dirstream
+      | ".." == e -> D.Skip dirstream
+      | otherwise -> D.Yield (typ, e) dirstream
+
+
+getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
+                                       => FilePath
+                                       -> S.SerialT m FilePath
+getDirectoryContentsRecursiveDFSUnsafe fp = go ""
+ where
+  go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
+    if | t == FD.dtDir -> go (cd </> f)
+       | otherwise     -> pure (cd </> f)
+
+
+getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath
+getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))
+ where
+  {-# INLINE [0] step #-}
+  step (_, Nothing, []) = return D.Stop
+
+  step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
+    (dt, f) <- liftIO $ readDirEnt dirstream
+    if | FD.dtUnknown == dt -> do
+           runIOFinalizer finalizer
+           return $ D.Skip (topdir, Nothing, dirs)
+       | f == "." || f == ".."
+                        -> return $ D.Skip               (topdir, Just (cdir, dirstream, finalizer), dirs)
+       | FD.dtDir == dt -> return $ D.Skip               (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)
+       | otherwise      -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)
+
+  step (topdir, Nothing, dir:dirs) = do
+    (s, f) <- acquire (topdir </> dir)
+    return $ D.Skip (topdir, Just (dir, s, f), dirs)
+
+  acquire dir =
+    withRunInIO $ \run -> mask_ $ run $ do
+        dirstream <- liftIO $ openDirStream dir
+        ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
+        return (dirstream, ref)
+
+getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
+                                       => FilePath
+                                       -> S.SerialT m FilePath
+getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
+
+

lib/GHCup/Utils/File/Posix/Foreign.hsc

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

lib/GHCup/Utils/File/Posix/Traversals.hs

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

lib/GHCup/Utils/File/Windows.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DataKinds  #-}
 
 {-|
 Module      : GHCup.Utils.File.Windows
@@ -31,18 +32,30 @@ import           Data.List
 import           Foreign.C.Error
 import           GHC.IO.Exception
 import           GHC.IO.Handle
-import           System.Directory
+import qualified GHC.Unicode                  as U
 import           System.Environment
 import           System.FilePath
 import           System.IO
+import qualified System.IO.Error              as IOE
 import           System.Process
- 
+
+import qualified System.Win32.Info             as WS
+import qualified System.Win32.File             as WS
 import qualified Control.Exception             as EX
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 
+import qualified Streamly.Internal.Data.Stream.StreamD.Type
+                                               as D
+import           Streamly.Internal.Data.Unfold.Type hiding ( concatMap )
+import           Data.Bits ((.&.))
+import qualified Streamly.Prelude              as S
+import qualified Streamly.Internal.Data.Unfold as U
+import           Streamly.Internal.Control.Concurrent ( withRunInIO )
+import           Streamly.Internal.Data.IOFinalizer   ( newIOFinalizer, runIOFinalizer )
+
 
 
 toProcessError :: FilePath
@@ -164,8 +177,8 @@ execLogged :: ( MonadReader env m
 execLogged exe args chdir lfile env = do
   Dirs {..} <- getDirs
   logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
-  let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
+  let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
-      stderrLogfile = logsDir </> lfile <> ".stderr.log"
+      stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
   cp <- createProcessWithMingwPath ((proc exe args)
     { cwd = chdir
     , env = env
@@ -199,7 +212,7 @@ execLogged exe args chdir lfile env = do
             -- subprocess stdout also goes to stderr for logging
             void $ BS.hPut stderr some
             go
-        
+
 
 -- | Thin wrapper around `executeFile`.
 exec :: MonadIO m
@@ -256,7 +269,7 @@ ghcupMsys2Dir =
     Just fp -> pure fp
     Nothing -> do
       baseDir <- liftIO ghcupBaseDir
-      pure (baseDir </> "msys64")
+      pure (fromGHCupPath baseDir </> "msys64")
 
 -- | Checks whether the binary is a broken link.
 isBrokenSymlink :: FilePath -> IO Bool
@@ -269,3 +282,229 @@ isBrokenSymlink fp = do
       -- this drops 'symDir' if 'tfp' is absolute
       (takeDirectory fp </> tfp)
   else pure False
+
+
+copyFile :: FilePath   -- ^ source file
+         -> FilePath   -- ^ destination file
+         -> Bool       -- ^ fail if file exists
+         -> IO ()
+copyFile = WS.copyFile
+
+deleteFile :: FilePath -> IO ()
+deleteFile = WS.deleteFile
+
+install :: FilePath -> FilePath -> Bool -> IO ()
+install = copyFile
+
+removeEmptyDirectory :: FilePath -> IO ()
+removeEmptyDirectory = WS.removeDirectory
+
+
+unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath)
+unfoldDirContents = U.bracket alloc dealloc (Unfold step return)
+ where
+  {-# INLINE [0] step #-}
+  step (_, False, _, _) = return D.Stop
+  step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do
+    f <- liftIO $ WS.getFindDataFileName fd
+    more <- liftIO $ WS.findNextFile h fd
+
+    -- can't get file attribute from FindData yet (needs Win32 PR)
+    fattr <- liftIO $ WS.getFileAttributes (topdir </> f)
+
+    if | f == "." || f == ".." -> return $ D.Skip             (topdir, more, h, fd)
+       | otherwise             -> return $ D.Yield (fattr, f) (topdir, more, h, fd)
+
+  alloc topdir = do
+    query <- liftIO $ furnishPath (topdir </> "*")
+    (h, fd) <- liftIO $ WS.findFirstFile query
+    pure (topdir, True, h, fd)
+
+  dealloc (_, _, fd, _) = liftIO $ WS.findClose fd
+
+
+getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t)
+                                       => FilePath
+                                       -> t m FilePath
+getDirectoryContentsRecursiveDFSUnsafe fp = go ""
+ where
+  isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
+
+  go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
+    if | isDir t   -> go (cd </> f)
+       | otherwise -> pure (cd </> f)
+
+
+getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath
+getDirectoryContentsRecursiveUnfold = Unfold step init'
+ where
+  {-# INLINE [0] step #-}
+  step (_, Nothing, []) = return D.Stop
+
+  step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do
+    f <- liftIO $ WS.getFindDataFileName findData
+
+    more <- liftIO $ WS.findNextFile h findData
+    when (not more) $ runIOFinalizer ref
+    let nextState = if more then state else Nothing
+
+    -- can't get file attribute from FindData yet (needs Win32 PR)
+    fattr <- liftIO $ WS.getFileAttributes (topdir </> cdir </> f)
+
+    if | f == "." || f == ".." -> return $ D.Skip               (topdir, nextState, dirs)
+       | isDir fattr           -> return $ D.Skip               (topdir, nextState, (cdir </> f):dirs)
+       | otherwise             -> return $ D.Yield (cdir </> f) (topdir, nextState, dirs)
+
+  step (topdir, Nothing, dir:dirs) = do
+    (h, findData, ref) <- acquire (topdir </> dir)
+    return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs)
+
+  init' topdir = do
+    (h, findData, ref) <- acquire topdir
+    return (topdir, Just ("", (h, findData, ref)), [])
+
+  isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
+
+  acquire dir = do
+    query <- liftIO $ furnishPath (dir </> "*")
+    withRunInIO $ \run -> mask_ $ run $ do
+        (h, findData) <- liftIO $ WS.findFirstFile query
+        ref <- newIOFinalizer (liftIO $ WS.findClose h)
+        return (h, findData, ref)
+
+
+getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
+                                       => FilePath
+                                       -> S.SerialT m FilePath
+getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
+
+
+
+    --------------------------------------
+    --[ Inlined from directory package ]--
+    --------------------------------------
+
+
+furnishPath :: FilePath -> IO FilePath
+furnishPath path =
+  (toExtendedLengthPath <$> rawPrependCurrentDirectory path)
+    `IOE.catchIOError` \ _ ->
+      pure path
+
+
+toExtendedLengthPath :: FilePath -> FilePath
+toExtendedLengthPath path
+  | isRelative path = simplifiedPath
+  | otherwise =
+      case simplifiedPath of
+        '\\' : '?'  : '?' : '\\' : _ -> simplifiedPath
+        '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath
+        '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath
+        '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
+        _ -> "\\\\?\\" <> simplifiedPath
+  where simplifiedPath = simplify path
+
+
+simplify :: FilePath -> FilePath
+simplify = simplifyWindows
+
+simplifyWindows :: FilePath -> FilePath
+simplifyWindows "" = ""
+simplifyWindows path =
+  case drive' of
+    "\\\\?\\" -> drive' <> subpath
+    _ -> simplifiedPath
+  where
+    simplifiedPath = joinDrive drive' subpath'
+    (drive, subpath) = splitDrive path
+    drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
+    subpath' = appendSep . avoidEmpty . prependSep . joinPath .
+               stripPardirs . expandDots . skipSeps .
+               splitDirectories $ subpath
+
+    upperDrive d = case d of
+      c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s
+      _ -> d
+    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
+    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
+                 | otherwise = id
+    prependSep | subpathIsAbsolute = (pathSeparator :)
+               | otherwise = id
+    avoidEmpty | not pathIsAbsolute
+                 && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
+                 = emptyToCurDir
+               | otherwise = id
+    appendSep p | hasTrailingPathSep
+                  && not (pathIsAbsolute && null p)
+                  = addTrailingPathSeparator p
+                | otherwise = p
+    pathIsAbsolute = not (isRelative path)
+    subpathIsAbsolute = any isPathSeparator (take 1 subpath)
+    hasTrailingPathSep = hasTrailingPathSeparator subpath
+
+emptyToCurDir :: FilePath -> FilePath
+emptyToCurDir ""   = "."
+emptyToCurDir path = path
+
+normaliseTrailingSep :: FilePath -> FilePath
+normaliseTrailingSep path = do
+  let path' = reverse path
+  let (sep, path'') = span isPathSeparator path'
+  let addSep = if null sep then id else (pathSeparator :)
+  reverse (addSep path'')
+
+normalisePathSeps :: FilePath -> FilePath
+normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
+
+expandDots :: [FilePath] -> [FilePath]
+expandDots = reverse . go []
+  where
+    go ys' xs' =
+      case xs' of
+        [] -> ys'
+        x : xs ->
+          case x of
+            "." -> go ys' xs
+            ".." ->
+              case ys' of
+                [] -> go (x : ys') xs
+                ".." : _ -> go (x : ys') xs
+                _ : ys -> go ys xs
+            _ -> go (x : ys') xs
+
+rawPrependCurrentDirectory :: FilePath -> IO FilePath
+rawPrependCurrentDirectory path
+  | isRelative path =
+    ((`ioeAddLocation` "prependCurrentDirectory") .
+     (`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do
+      getFullPathName path
+  | otherwise = pure path
+
+ioeAddLocation :: IOError -> String -> IOError
+ioeAddLocation e loc = do
+  IOE.ioeSetLocation e newLoc
+  where
+    newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
+    oldLoc = IOE.ioeGetLocation e
+
+getFullPathName :: FilePath -> IO FilePath
+getFullPathName path =
+  fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)
+
+fromExtendedLengthPath :: FilePath -> FilePath
+fromExtendedLengthPath ePath =
+  case ePath of
+    '\\' : '\\' : '?' : '\\' : path ->
+      case path of
+        'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath
+        drive : ':' : subpath
+          -- if the path is not "regular", then the prefix is necessary
+          -- to ensure the path is interpreted literally
+          | U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path
+        _ -> ePath
+    _ -> ePath
+  where
+    isPathRegular path =
+      not ('/' `elem` path ||
+           "." `elem` splitDirectories path ||
+           ".." `elem` splitDirectories path)

lib/GHCup/Utils/Logger.hs

@@ -17,6 +17,7 @@ module GHCup.Utils.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
+import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
 import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
 import           GHCup.Utils.String.QQ
 
@@ -117,14 +118,14 @@ initGHCupFileLogging :: ( MonadReader env m
                         ) => m FilePath
 initGHCupFileLogging = do
   Dirs { logsDir } <- getDirs
-  let logfile = logsDir </> "ghcup.log"
+  let logfile = fromGHCupPath logsDir </> "ghcup.log"
   logFiles <- liftIO $ findFiles
-    logsDir
+    (fromGHCupPath logsDir)
     (makeRegexOpts compExtended
                    execBlank
                    ([s|^.*\.log$|] :: B.ByteString)
     )
-  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
+  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
 
   liftIO $ writeFile logfile ""
   pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -27,6 +27,7 @@ module GHCup.Utils.Prelude
   )
 where
 
+import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
 import           GHCup.Types
 import           GHCup.Errors
 import           GHCup.Types.Optics
@@ -44,9 +45,8 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
+import           Data.List                      ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
 import           Data.Maybe
-import           Data.Foldable
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.String
 import           Data.Text                      ( Text )
@@ -56,9 +56,11 @@ import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import           System.IO.Error
-import           System.IO.Temp
+import           System.Directory hiding ( removeDirectory
-import           System.IO.Unsafe
+                                         , removeDirectoryRecursive
-import           System.Directory
+                                         , removePathForcibly
+                                         , copyFile
+                                         )
 import           System.FilePath
 
 import           Control.Retry
@@ -78,6 +80,7 @@ import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
 
 
+
 -- $setup
 -- >>> import Data.ByteString.Internal (c2w, w2c)
 -- >>> import Test.QuickCheck
@@ -397,64 +400,6 @@ createDirRecursive' p =
       _ -> throwIO e
 
 
--- | Recursively copy the contents of one directory to another path.
---
--- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
-copyDirectoryRecursive srcDir destDir doCopy = do
-  srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith destDir [ (srcDir, f)
-                          | f <- srcFiles ]
-  where
-    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
-    copyFilesWith targetDir srcFiles = do
-
-      -- Create parent directories for everything
-      let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
-      traverse_ (createDirectoryIfMissing True) dirs
-
-      -- Copy all the files
-      sequence_ [ let src  = srcBase   </> srcFile
-                      dest = targetDir </> srcFile
-                   in doCopy src dest
-                | (srcBase, srcFile) <- srcFiles ]
-
-
--- | List all the files in a directory and all subdirectories.
---
--- The order places files in sub-directories after all the files in their
--- parent directories. The list is generated lazily so is not well defined if
--- the source directory structure changes before the list is used.
---
-getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
-getDirectoryContentsRecursive topdir = recurseDirectories [""]
-  where
-    recurseDirectories :: [FilePath] -> IO [FilePath]
-    recurseDirectories []         = return []
-    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
-      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
-      files' <- recurseDirectories (dirs' ++ dirs)
-      return (files ++ files')
-
-      where
-        collect files dirs' []              = return (reverse files
-                                                     ,reverse dirs')
-        collect files dirs' (entry:entries) | ignore entry
-                                            = collect files dirs' entries
-        collect files dirs' (entry:entries) = do
-          let dirEntry = dir </> entry
-          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
-          if isDirectory
-            then collect files (dirEntry:dirs') entries
-            else collect (dirEntry:files) dirs' entries
-
-        ignore ['.']      = True
-        ignore ['.', '.'] = True
-        ignore _          = False
-
-
 -- https://github.com/haskell/directory/issues/110
 -- https://github.com/haskell/directory/issues/96
 -- https://www.sqlite.org/src/info/89f1848d7f
@@ -463,17 +408,17 @@ recyclePathForcibly :: ( MonadIO m
                        , HasDirs env
                        , MonadMask m
                        )
-                    => FilePath
+                    => GHCupPath
                     -> m ()
 recyclePathForcibly fp
   | isWindows = do
       Dirs { recycleDir } <- getDirs
-      tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
-      let dest = tmp </> takeFileName fp
+      let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
-      liftIO (moveFile fp dest)
+      liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
           `catch`
           (\e -> if | isDoesNotExistError e -> pure ()
-                    | isPermissionError e {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
+                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
                     | otherwise -> throwIO e)
           `finally`
             liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
@@ -483,7 +428,7 @@ recyclePathForcibly fp
 rmPathForcibly :: ( MonadIO m
                   , MonadMask m
                   )
-               => FilePath
+               => GHCupPath
                -> m ()
 rmPathForcibly fp
   | isWindows = recover (liftIO $ removePathForcibly fp)
@@ -491,7 +436,7 @@ rmPathForcibly fp
 
 
 rmDirectory :: (MonadIO m, MonadMask m)
-            => FilePath
+            => GHCupPath
             -> m ()
 rmDirectory fp
   | isWindows = recover (liftIO $ removeDirectory fp)
@@ -511,11 +456,11 @@ recycleFile fp
   | isWindows = do
       Dirs { recycleDir } <- getDirs
       liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
-      tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
-      let dest = tmp </> takeFileName fp
+      let dest = fromGHCupPath tmp </> takeFileName fp
       liftIO (moveFile fp dest)
         `catch`
-          (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
         `finally`
           liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
   | otherwise = liftIO $ removeFile fp
@@ -549,10 +494,6 @@ recover action =
     (\_ -> action)
 
 
-copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
-copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
-
-
 -- | Gathering monoidal values
 --
 -- >>> traverseFold (pure . (:["0"])) ["1","2"]
@@ -762,4 +703,3 @@ breakOn :: Eq a => [a] -> [a] -> ([a], [a])
 breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
 breakOn _ [] = ([], [])
 breakOn needle (x:xs) = first (x:) $ breakOn needle xs
-

lib/GHCup/Utils/Prelude/Posix.hs

@@ -1,6 +1,10 @@
 module GHCup.Utils.Prelude.Posix where
 
-import System.Directory
+import           System.Directory hiding ( removeDirectory
+                                         , removeDirectoryRecursive
+                                         , removePathForcibly
+                                         , findFiles
+                                         )
 import System.Posix.Files
 
 
@@ -17,4 +21,4 @@ moveFilePortable :: FilePath -> FilePath -> IO ()
 moveFilePortable from to = do
   copyFile from to
   removeFile from
-  
+

mkdocs.yml

@@ -13,7 +13,8 @@ theme:
 
 nav:
   - Home: index.md
-  - "Getting Started": install.md
+  - "Getting started": install.md
+  - "First steps": steps.md
   - "User Guide": guide.md
   - "Developer Guide": dev.md
   - About: about.md

scripts/bootstrap/bootstrap-haskell

@@ -16,6 +16,7 @@
 #   * BOOTSTRAP_HASKELL_INSTALL_HLS - whether to install latest hls
 #   * BOOTSTRAP_HASKELL_ADJUST_BASHRC - whether to adjust PATH in bashrc (prepend)
 #   * BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG - whether to adjust mingw paths in cabal.config on windows
+#   * GHCUP_BASE_URL - the base url for ghcup binary download (use this to overwrite https://downloads.haskell.org/~ghcup with a mirror)
 
 # License: LGPL-3.0
 
@@ -25,8 +26,8 @@
 
 plat="$(uname -s)"
 arch=$(uname -m)
-ghver="0.1.17.5"
+ghver="0.1.17.8"
-base_url="https://downloads.haskell.org/~ghcup"
+: "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}"
 
 export GHCUP_SKIP_UPDATE_CHECK=yes
 
@@ -157,7 +158,7 @@ _done() {
 				green "and the \"Mingw package management docs\""
 				green "desktop shortcuts."
 				green
-				green "If you are new to Haskell, check out https://www.haskell.org/ghcup/install/#first-steps"
+				green "If you are new to Haskell, check out https://www.haskell.org/ghcup/steps/"
 				;;
 			*)
 				green
@@ -172,7 +173,7 @@ _done() {
 				green "To install other GHC versions and tools, run:"
 				green "  ghcup tui"
 				green
-				green "If you are new to Haskell, check out https://www.haskell.org/ghcup/install/#first-steps"
+				green "If you are new to Haskell, check out https://www.haskell.org/ghcup/steps/"
 				;;
 
 	esac
@@ -181,6 +182,51 @@ _done() {
 	exit 0
 }
 
+# @FUNCTION: posix_realpath
+# @USAGE: <file>
+# @DESCRIPTION:
+# Portably gets the realpath and prints it to stdout.
+# This was initially inspired by
+#   https://gist.github.com/tvlooy/cbfbdb111a4ebad8b93e
+#   and
+#   https://stackoverflow.com/a/246128
+#
+# If the file does not exist, just prints it appended to the current directory.
+# @STDOUT: realpath of the given file
+posix_realpath() {
+    [ -z "$1" ] && die "Internal error: no argument given to posix_realpath"
+    current_loop=0
+    max_loops=50
+    mysource=$1
+    # readlink and '[ -h $path ]' behave different wrt '/sbin/' and '/sbin', so we strip it
+    mysource=${mysource%/}
+    [ -z "${mysource}" ] && mysource=$1
+
+    while [ -h "${mysource}" ]; do
+        current_loop=$((current_loop+1))
+        mydir="$( cd -P "$( dirname "${mysource}" )" > /dev/null 2>&1 && pwd )"
+        mysource="$(readlink "${mysource}")"
+        [ "${mysource%"${mysource#?}"}"x != '/x' ] && mysource="${mydir%/}/${mysource}"
+
+        if [ ${current_loop} -gt ${max_loops} ] ; then
+            (>&2 echo "${1}: Too many levels of symbolic links")
+			echo "$1"
+            return
+        fi
+    done
+    mydir="$( cd -P "$( dirname "${mysource}" )" > /dev/null 2>&1 && pwd )"
+
+    # TODO: better distinguish between "does not exist" and "permission denied"
+    if [ -z "${mydir}" ] ; then
+        (>&2 echo "${1}: Permission denied")
+		echo "$(pwd)/$1"
+    else
+        echo "${mydir%/}/$(basename "${mysource}")"
+    fi
+
+    unset current_loop max_loops mysource mydir
+}
+
 download_ghcup() {
 
     case "${plat}" in
@@ -190,26 +236,26 @@ download_ghcup() {
 					# we could be in a 32bit docker container, in which
 					# case uname doesn't give us what we want
 					if [ "$(getconf LONG_BIT)" = "32" ] ; then
-						_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
+						_url=${GHCUP_BASE_URL}/${ghver}/i386-linux-ghcup-${ghver}
 					elif [ "$(getconf LONG_BIT)" = "64" ] ; then
-						_url=${base_url}/${ghver}/x86_64-linux-ghcup-${ghver}
+						_url=${GHCUP_BASE_URL}/${ghver}/x86_64-linux-ghcup-${ghver}
 					else
 						die "Unknown long bit size: $(getconf LONG_BIT)"
 					fi
 					;;
 				i*86)
-					_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
+					_url=${GHCUP_BASE_URL}/${ghver}/i386-linux-ghcup-${ghver}
 					;;
 				armv7*|*armv8l*)
-					_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
+					_url=${GHCUP_BASE_URL}/${ghver}/armv7-linux-ghcup-${ghver}
 					;;
 				aarch64|arm64)
 					# we could be in a 32bit docker container, in which
 					# case uname doesn't give us what we want
 					if [ "$(getconf LONG_BIT)" = "32" ] ; then
-						_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
+						_url=${GHCUP_BASE_URL}/${ghver}/armv7-linux-ghcup-${ghver}
 					elif [ "$(getconf LONG_BIT)" = "64" ] ; then
-						_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
+						_url=${GHCUP_BASE_URL}/${ghver}/aarch64-linux-ghcup-${ghver}
 					else
 						die "Unknown long bit size: $(getconf LONG_BIT)"
 					fi
@@ -236,15 +282,15 @@ download_ghcup() {
 				*) die "Unknown architecture: ${arch}"
 					;;
 			esac
-			_url=${base_url}/${ghver}/x86_64-freebsd${freebsd_ver}-ghcup-${ghver}
+			_url=${GHCUP_BASE_URL}/${ghver}/x86_64-freebsd${freebsd_ver}-ghcup-${ghver}
             ;;
         "Darwin"|"darwin")
 			case "${arch}" in
 				x86_64|amd64)
-					_url=${base_url}/${ghver}/x86_64-apple-darwin-ghcup-${ghver}
+					_url=${GHCUP_BASE_URL}/${ghver}/x86_64-apple-darwin-ghcup-${ghver}
 					;;
 				aarch64|arm64|armv8l)
-					_url=${base_url}/${ghver}/aarch64-apple-darwin-ghcup-${ghver}
+					_url=${GHCUP_BASE_URL}/${ghver}/aarch64-apple-darwin-ghcup-${ghver}
 					;;
 				i*86)
 					die "i386 currently not supported!"
@@ -256,7 +302,7 @@ download_ghcup() {
         MSYS*|MINGW*)
 			case "${arch}" in
 				x86_64|amd64)
-					_url=${base_url}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe
+					_url=${GHCUP_BASE_URL}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe
 					;;
 				*) die "Unknown architecture: ${arch}"
 					;;
@@ -427,23 +473,23 @@ adjust_bashrc() {
 					;;
 				fish)
 					mkdir -p "${GHCUP_PROFILE_FILE%/*}"
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
+					sed -i -e '/# ghcup-env$/ s/^#*/#/' "$(posix_realpath "${GHCUP_PROFILE_FILE}")"
 					case $1 in
 						1)
-							echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
+							printf "\n%s" "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 							;;
 						2)
-							echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin \$PATH $GHCUP_BIN # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
+							printf "\n%s" "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin \$PATH $GHCUP_BIN # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 							;;
 					esac
 					;;
 				bash)
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
+					sed -i -e '/# ghcup-env$/ s/^#*/#/' "$(posix_realpath "${GHCUP_PROFILE_FILE}")"
-					echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
+					printf "\n%s" "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 					case "${plat}" in
 						"Darwin"|"darwin")
 							if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
-								echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
+								printf "\n%s" "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
 							fi
 							;;
 						MSYS*|MINGW*)
@@ -457,8 +503,8 @@ adjust_bashrc() {
 					;;
 
 				zsh)
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
+					sed -i -e '/# ghcup-env$/ s/^#*/#/' "$(posix_realpath "${GHCUP_PROFILE_FILE}")"
-					echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
+					printf "\n%s" "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 					;;
 			esac
 			echo

scripts/bootstrap/bootstrap-haskell.ps1

@@ -239,7 +239,27 @@ if ($Silent -and !($InstallDir)) {
   }
 } else {
   while ($true) {
-    Print-Msg -color Magenta -msg ('Where to install to (this should be a short Path, preferably a Drive like ''C:\''){1}Press enter to accept the default [{0}]:' -f $defaultGhcupBasePrefix, "`n")
+	Print-Msg -color Magenta -msg (@'
+Welcome to Haskell!
+
+This script will download and install the following programs:
+  * ghcup - The Haskell toolchain installer
+  * ghc   - The Glasgow Haskell Compiler
+  * msys2 - A linux-style toolchain environment required for many operations
+  * cabal - The Cabal build tool for managing Haskell software
+  * stack - (optional) A cross-platform program for developing Haskell projects
+  * hls   - (optional) A language server for developers to integrate with their editor/IDE
+
+Please note that ANTIVIRUS may interfere with the installation. If you experience problems, consider
+disabling it temporarily.
+
+Where to install to (this should be a short Path, preferably a Drive like 'C:\')?
+If you accept this path, binaries will be installed into '{0}ghcup\bin' and msys2 into '{0}ghcup\msys64'.
+Press enter to accept the default [{0}]:
+
+'@ -f $defaultGhcupBasePrefix)
+
+
     $basePrefixPrompt = Read-Host
     $GhcupBasePrefix = ($defaultGhcupBasePrefix,$basePrefixPrompt)[[bool]$basePrefixPrompt]
     if (!($GhcupBasePrefix.EndsWith('\'))) {

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-18.25
+resolver: lts-18.28
 
 packages:
   - .
@@ -16,6 +16,7 @@ extra-deps:
   - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
   - haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
   - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
+  - haskus-utils-variant-3.2.1@sha256:791f4cf1e786eb578f4d37aef60986641f84c36e130164321f7d01542584066a,2200
   - heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340
   - hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
   - hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
@@ -25,7 +26,7 @@ extra-deps:
   - 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.0
+  - libyaml-streamly-0.2.1
   - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
   - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
   - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
@@ -34,15 +35,11 @@ extra-deps:
   - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
   - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
   - regex-posix-clib-2.7
-  - streamly-0.8.0@sha256:9784c80ee1ada51477520cabc4e92a0c76a6bb265f968a188f2fce818e7398e0,19654
+  - streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500
+  - unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123
   - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
   - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
-  - yaml-streamly-0.12.0
+  - yaml-streamly-0.12.1
-
-  - git: https://github.com/hasufell/packages.git
-    commit: cc0b4688f8bb374fa92f17c856949de795b56291
-    subdirs:
-      - haskus-utils-variant
 
 flags:
   http-io-streams:

test/GHCup/Utils/FileSpec.hs

@@ -0,0 +1,58 @@
+module GHCup.Utils.FileSpec where
+
+import           GHCup.Utils.File
+
+import           Data.List
+import           System.Directory
+import           System.FilePath
+import           System.IO.Unsafe
+import qualified Streamly.Prelude              as S
+
+import           Test.Hspec
+
+
+
+spec :: Spec
+spec = do
+  describe "GHCup.Utils.File" $ do
+    it "getDirectoryContentsRecursiveBFS" $ do
+      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe ".")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "."
+      not (null l1) `shouldBe` True
+      not (null l2) `shouldBe` True
+      l1 `shouldBe` l2
+    it "getDirectoryContentsRecursiveDFS" $ do
+      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe ".")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "."
+      not (null l1) `shouldBe` True
+      not (null l2) `shouldBe` True
+      l1 `shouldBe` l2
+
+
+getDirectoryContentsRecursiveLazy :: FilePath -> IO [FilePath]
+getDirectoryContentsRecursiveLazy topdir = recurseDirectories [""]
+  where
+    recurseDirectories :: [FilePath] -> IO [FilePath]
+    recurseDirectories []         = return []
+    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
+      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
+      files' <- recurseDirectories (dirs' ++ dirs)
+      return (files ++ files')
+
+      where
+        collect files dirs' []              = return (reverse files
+                                                     ,reverse dirs')
+        collect files dirs' (entry:entries) | ignore entry
+                                            = collect files dirs' entries
+        collect files dirs' (entry:entries) = do
+          let dirEntry = dir </> entry
+          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
+          if isDirectory
+            then collect files (dirEntry:dirs') entries
+            else collect (dirEntry:files) dirs' entries
+
+        ignore ['.']      = True
+        ignore ['.', '.'] = True
+        ignore _          = False
+
+

test/Main.hs

@@ -1,10 +1,9 @@
 import Test.Hspec.Runner
-import Test.Hspec.Formatters
 import qualified Spec
 
 
 main :: IO ()
 main =
   hspecWith
-    defaultConfig { configFormatter = Just progress }
+    defaultConfig
     Spec.spec