More stuff

1. short hashes now work
2. print the long hash in addition to the detected cabal version of HLS
3. add `--git-describe-version` switch as an alternative to
   `--overwrite-version`

Fix 1. and 2. for GHC as well.

.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.
-    - '[ -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"
-
+    # extract brew cache
+    - ./.gitlab/script/ci.sh extract_brew_cache
     # 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
-    - brew install llvm
-    - brew install autoconf automake coreutils
+    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
+    # extract cabal cache
+    - ./.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.
-    - '[ -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"
-
+    - ./.gitlab/script/ci.sh extract_brew_cache
+    - ./.gitlab/script/ci.sh extract_cabal_cache
     # 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
-    - brew install llvm
-    - brew install autoconf automake
+    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
   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_BIN="$CI_PROJECT_DIR/ghcup/bin"
-	export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
-	export TMPDIR="$CI_PROJECT_DIR/tmp"
+    export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
+    export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin"
+    export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
+    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_BIN="$CI_PROJECT_DIR/.ghcup/bin"
-	export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
-	export TMPDIR="$CI_PROJECT_DIR/tmp"
+    export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
+    export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin"
+    export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
+    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_bootstrap.sh

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

.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,23 @@ rm -rf "${GHCUP_DIR}"
 eghcup --numeric-version
 
 eghcup install ghc ${GHC_VERSION}
-[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
-[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ]
+eghcup unset ghc ${GHC_VERSION}
+ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})"
+[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
+[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
+[ "`ghcup run --ghc ${GHC_VERSION} -- ghc -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" = "`$(ghcup whereis ghc ${GHC_VERSION}) -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" ]
 eghcup set ghc ${GHC_VERSION}
 eghcup install cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
+[ "`$(eghcup 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
+
+# make sure no cabal is set when running 'ghcup run' to check that PATH propagages properly
+# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
+[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
 eghcup set cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
-[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ]
+
+[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
 
 if [ "${OS}" != "FREEBSD" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
@@ -170,12 +180,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 +199,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
-			"$GHCUP_BIN"/stack --version && exit || echo yes
+			eghcup unset stack
+			"$GHCUP_BIN"/stack --version && exit 1 || echo yes
 		fi
 	fi
 fi
@@ -210,11 +222,13 @@ eghcup rm $(ghc --numeric-version)
 # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
-		eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
+		eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4
 		eghcup rm cabal 3.4.0.0-rc4
 	fi
 fi
 
+eghcup gc -c
+
 sha_sum() {
 	if [ "${OS}" = "FREEBSD" ] ; then
 		sha256 "$@"
@@ -262,13 +276,39 @@ 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
 
 eghcup upgrade
 eghcup upgrade -f
 
+# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
+mkdir no_nuke/
+mkdir no_nuke/bar
+echo 'foo' > no_nuke/file
+echo 'bar' > no_nuke/bar/file
+ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
+ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
 
 # nuke
 eghcup nuke
 [ ! -e "${GHCUP_DIR}" ]
+
+# make sure nuke doesn't resolve symlinks
+[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
+[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]
+
+

.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,5 +1,22 @@
 # Revision history for ghcup
 
+## 0.1.17.10 -- 2022-05-12
+
+* windows hotfix (hackage-only release)
+
+## 0.1.17.9 -- 2022-05-12
+
+* broken sdist (hackage-only release)
+
+## 0.1.17.8 -- 2022-05-11
+
+* Fix a serious (but hard to trigger) bug when combining `--isolate <DIR>` with `--force`, please make sure to upgrade or avoid `--force`
+* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361)
+* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353)
+* Re-enable upgrade functionality for all configurations wrt [MR #250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250) and [VSCode haskell issue #601](https://github.com/haskell/vscode-haskell/issues/601)
+* Fix `ghcup run --ghc 8.10` (for short versions) wrt [#360](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/360)
+    - this also introduces a `--quick` switch for `ghcup run`
+
 ## 0.1.17.7 -- 2022-04-21
 
 * Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345)

app/ghcup/BrickMain.hs

@@ -13,9 +13,10 @@ import           GHCup.Errors
 import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
-import           GHCup.Utils.Logger
-import           GHCup.Utils.Prelude ( decUTF8Safe )
-import           GHCup.Utils.File
+import           GHCup.Prelude ( decUTF8Safe )
+import           GHCup.Prelude.File
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.Process
 
 import           Brick
 import           Brick.Widgets.Border
@@ -44,7 +45,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 +437,9 @@ install' _ (_, ListResult {..}) = do
               , TarDirDoesNotExist
               , FileAlreadyExistsError
               , ProcessError
+              , ToolShadowed
+              , UninstallFailed
+              , MergeFileTreeError
               ]
 
   run (do
@@ -446,19 +449,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 +514,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,7 +96,7 @@ data Command
   | Config ConfigCommand
   | Whereis WhereisOptions WhereisCommand
 #ifndef DISABLE_UPGRADE
-  | Upgrade UpgradeOpts Bool
+  | Upgrade UpgradeOpts Bool Bool
 #endif
   | ToolRequirements ToolReqOpts
   | ChangeLog ChangeLogOptions
@@ -222,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

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,9 +12,11 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
-import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
+import           GHCup.Prelude.Process (exec)
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -34,8 +36,6 @@ import GHCup.Types.Optics
 import GHCup.Utils
 import Data.Versions
 import URI.ByteString (serializeURIRef')
-import GHCup.Utils.Prelude
-import GHCup.Utils.File (exec)
 import Data.Char (toLower)
 
 

app/ghcup/GHCup/OptParse/Common.hs

@@ -16,10 +16,10 @@ 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           GHCup.Prelude
+import           GHCup.Prelude.Process
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.MegaParsec
 
 import           Control.DeepSeq
 import           Control.Concurrent
@@ -52,7 +52,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           Safe
-import           System.Directory
 import           System.Process                  ( readProcess )
 import           System.FilePath
 import           Text.HTML.TagSoup       hiding ( Tag )
@@ -227,7 +226,7 @@ absolutePathParser f = case isValid f && isAbsolute f of
               False -> Left "Please enter a valid absolute filepath."
 
 isolateParser :: FilePath -> Either String FilePath
-isolateParser f = case isValid f of
+isolateParser f = case isValid f && isAbsolute f of
               True -> Right $ normalise f
               False -> Left "Please enter a valid filepath for isolate dir."
 

app/ghcup/GHCup/OptParse/Compile.hs

@@ -13,13 +13,12 @@ module GHCup.OptParse.Compile where
 
 import           GHCup
 import           GHCup.Errors
-import           GHCup.Utils.File
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -83,7 +82,7 @@ data HLSCompileOptions = HLSCompileOptions
   { targetHLS    :: Either Version GitBranch
   , jobs         :: Maybe Int
   , setCompile   :: Bool
-  , ovewrwiteVer :: Maybe Version
+  , ovewrwiteVer :: Either Bool Version
   , isolateDir   :: Maybe FilePath
   , cabalProject :: Maybe (Either FilePath URI)
   , cabalProjectLocal :: Maybe URI
@@ -99,7 +98,7 @@ data HLSCompileOptions = HLSCompileOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 compileP :: Parser CompileCommand
 compileP = subparser
   (  command
@@ -146,14 +145,16 @@ Examples:
 
   compileHLSFooter = [s|Discussion:
   Compiles and installs the specified HLS version.
-  The last argument is a list of GHC versions to compile for.
+  The --ghc arguments are necessary to specify which GHC version to build for/against.
   These need to be available in PATH prior to compilation.
 
 Examples:
-  # compile 1.4.0 for ghc 8.10.5 and 8.10.7
-  ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
-  # compile from master for ghc 8.10.7, linking everything dynamically
-  ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
+  # compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal
+  ghcup compile hls -v 1.7.0.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 -- --allow-newer
+  # compile from master for ghc 9.2.3 and use 'git describe' to name the binary
+  ghcup compile hls -g master --git-describe-version --ghc 9.2.3
+  # compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
+  ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]
 
 
 ghcCompileOpts :: Parser GHCCompileOptions
@@ -233,7 +234,7 @@ ghcCompileOpts =
               "Build cross-compiler for this platform"
             )
           )
-    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
+    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)"))
     <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
     <*> optional
           (option
@@ -281,7 +282,7 @@ hlsCompileOpts =
           (Right <$> (GitBranch <$> option
           str
           (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
-            "The git commit/branch/ref to build from"
+            "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
           ) <*>
           optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
             <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
@@ -296,8 +297,9 @@ hlsCompileOpts =
             )
           )
     <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
-    <*> optional
-          (option
+    <*>
+         (
+          (Right <$> option
             (eitherReader
               (first (const "Not a valid version") . version . T.pack)
             )
@@ -306,6 +308,14 @@ hlsCompileOpts =
             <> (completer $ versionCompleter Nothing HLS)
             )
           )
+          <|>
+          (Left <$> (switch
+                      (long "git-describe-version"
+                         <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
+                      )
+                    )
+          )
+          )
     <*> optional
           (option
             (eitherReader isolateParser)
@@ -388,6 +398,8 @@ type GHCEffects = '[ AlreadyInstalled
                   , ProcessError
                   , CopyError
                   , BuildFailed
+                  , UninstallFailed
+                  , MergeFileTreeError
                   ]
 type HLSEffects = '[ AlreadyInstalled
                   , BuildFailed
@@ -406,6 +418,8 @@ type HLSEffects = '[ AlreadyInstalled
                   , NotInstalled
                   , DirNotEmpty
                   , ArchiveResult
+                  , UninstallFailed
+                  , MergeFileTreeError
                   ]
 
 
@@ -469,7 +483,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     ghcs
                     jobs
                     ovewrwiteVer
-                    isolateDir
+                    (maybe GHCupInternal IsolateDir isolateDir)
                     cabalProject
                     cabalProjectLocal
                     patches
@@ -492,7 +506,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
@@ -524,7 +538,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 $
@@ -541,17 +555,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 $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                runLogger $ logError $
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger $ logError $ T.pack $ prettyShow err
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                        "Check the logs at " <> T.pack 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,7 +7,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ExplicitForAll #-}
 
 module GHCup.OptParse.Config where
 
@@ -15,9 +14,9 @@ module GHCup.OptParse.Config where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
 
 #if !MIN_VERSION_base(4,13,0)

app/ghcup/GHCup/OptParse/DInfo.hs

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

app/ghcup/GHCup/OptParse/GC.hs

@@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -56,26 +56,26 @@ data GCOptions = GCOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 gcP :: Parser GCOptions
 gcP =
   GCOptions
-  <$> 
+  <$>
     switch
       (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
-  <*> 
+  <*>
     switch
       (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
-  <*> 
+  <*>
     switch
       (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
-  <*> 
+  <*>
     switch
       (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
-  <*> 
+  <*>
     switch
       (short 'c' <> long "cache" <> help "GC the GHCup cache")
-  <*> 
+  <*>
     switch
       (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
 
@@ -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

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module GHCup.OptParse.Install where
 
@@ -18,8 +19,10 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Utils.Dirs
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)
@@ -30,7 +33,6 @@ import           Control.Monad.Trans.Resource
 import           Data.Either
 import           Data.Functor
 import           Data.Maybe
-import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
@@ -69,6 +71,7 @@ data InstallOptions = InstallOptions
   , instSet      :: Bool
   , isolateDir   :: Maybe FilePath
   , forceInstall :: Bool
+  , addConfArgs  :: [T.Text]
   }
 
 
@@ -210,13 +213,14 @@ installOpts tool =
            )
           )
     <*> 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)")
+    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
  where
   setDefault = case tool of
     Nothing  -> False
     Just GHC -> False
     Just _   -> True
-          
+
 
 
 
@@ -257,48 +261,9 @@ type InstallEffects = '[ AlreadyInstalled
                        , NoToolVersionSet
                        , FileAlreadyExistsError
                        , ProcessError
-
-                       , (AlreadyInstalled, ())
-                       , (UnknownArchive, ())
-                       , (ArchiveResult, ())
-                       , (FileDoesNotExistError, ())
-                       , (CopyError, ())
-                       , (NotInstalled, ())
-                       , (DirNotEmpty, ())
-                       , (NoDownload, ())
-                       , (NotInstalled, ())
-                       , (BuildFailed, ())
-                       , (TagNotFound, ())
-                       , (DigestError, ())
-                       , (GPGError, ())
-                       , (DownloadFailed, ())
-                       , (TarDirDoesNotExist, ())
-                       , (NextVerNotFound, ())
-                       , (NoToolVersionSet, ())
-                       , (FileAlreadyExistsError, ())
-                       , (ProcessError, ())
-
-                       , (AlreadyInstalled, NotInstalled)
-                       , (UnknownArchive, NotInstalled)
-                       , (ArchiveResult, NotInstalled)
-                       , (FileDoesNotExistError, NotInstalled)
-                       , (CopyError, NotInstalled)
-                       , (NotInstalled, NotInstalled)
-                       , (DirNotEmpty, NotInstalled)
-                       , (NoDownload, NotInstalled)
-                       , (NotInstalled, NotInstalled)
-                       , (BuildFailed, NotInstalled)
-                       , (TagNotFound, NotInstalled)
-                       , (DigestError, NotInstalled)
-                       , (GPGError, NotInstalled)
-                       , (DownloadFailed, NotInstalled)
-                       , (TarDirDoesNotExist, NotInstalled)
-                       , (NextVerNotFound, NotInstalled)
-                       , (NoToolVersionSet, NotInstalled)
-                       , (FileAlreadyExistsError, NotInstalled)
-                       , (ProcessError, NotInstalled)
-
-                       , ((), NotInstalled)
+                       , UninstallFailed
+                       , MergeFileTreeError
+                       , InstallSetError
                        ]
 
 
@@ -313,52 +278,27 @@ runInstTool appstate' mInstPlatform =
     @InstallEffects
 
 
-type InstallGHCEffects = '[ TagNotFound
-                          , NextVerNotFound
-                          , NoToolVersionSet
+type InstallGHCEffects = '[ AlreadyInstalled
+                          , ArchiveResult
                           , BuildFailed
+                          , CopyError
+                          , DigestError
                           , DirNotEmpty
-                          , AlreadyInstalled
-
-                          , (AlreadyInstalled, NotInstalled)
-                          , (UnknownArchive, NotInstalled)
-                          , (ArchiveResult, NotInstalled)
-                          , (FileDoesNotExistError, NotInstalled)
-                          , (CopyError, NotInstalled)
-                          , (NotInstalled, NotInstalled)
-                          , (DirNotEmpty, NotInstalled)
-                          , (NoDownload, NotInstalled)
-                          , (BuildFailed, NotInstalled)
-                          , (TagNotFound, NotInstalled)
-                          , (DigestError, NotInstalled)
-                          , (GPGError, NotInstalled)
-                          , (DownloadFailed, NotInstalled)
-                          , (TarDirDoesNotExist, NotInstalled)
-                          , (NextVerNotFound, NotInstalled)
-                          , (NoToolVersionSet, NotInstalled)
-                          , (FileAlreadyExistsError, NotInstalled)
-                          , (ProcessError, NotInstalled)
-
-                          , (AlreadyInstalled, ())
-                          , (UnknownArchive, ())
-                          , (ArchiveResult, ())
-                          , (FileDoesNotExistError, ())
-                          , (CopyError, ())
-                          , (NotInstalled, ())
-                          , (DirNotEmpty, ())
-                          , (NoDownload, ())
-                          , (BuildFailed, ())
-                          , (TagNotFound, ())
-                          , (DigestError, ())
-                          , (GPGError, ())
-                          , (DownloadFailed, ())
-                          , (TarDirDoesNotExist, ())
-                          , (NextVerNotFound, ())
-                          , (NoToolVersionSet, ())
-                          , (FileAlreadyExistsError, ())
-                          , (ProcessError, ())
-
-                          , ((), NotInstalled)
+                          , DownloadFailed
+                          , FileAlreadyExistsError
+                          , FileDoesNotExistError
+                          , GPGError
+                          , MergeFileTreeError
+                          , NextVerNotFound
+                          , NoDownload
+                          , NoToolVersionSet
+                          , NotInstalled
+                          , ProcessError
+                          , TagNotFound
+                          , TarDirDoesNotExist
+                          , UninstallFailed
+                          , UnknownArchive
+                          , InstallSetError
                           ]
 
 runInstGHC :: AppState
@@ -393,23 +333,25 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstGHC s' instPlatform $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         void $ liftE $ sequenceE (installGHCBin
+         liftE $ runBothE' (installGHCBin
                      (_tvVersion v)
-                     isolateDir
+                     (maybe GHCupInternal IsolateDir isolateDir)
                      forceInstall
+                     addConfArgs
                    )
-                   $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
+                   $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
          pure vi
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           void $ liftE $ sequenceE (installGHCBindist
+           liftE $ runBothE' (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                        (_tvVersion v)
-                       isolateDir
+                       (maybe GHCupInternal IsolateDir isolateDir)
                        forceInstall
+                       addConfArgs
                      )
-                     $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
+                     $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
            pure vi
       )
         >>= \case
@@ -419,43 +361,41 @@ install installCommand settings getAppState' runLogger = case installCommand of
                   runLogger $ logInfo msg
                 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 <> "'"
+              VLeft e@(V (AlreadyInstalled _ _)) -> do
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 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 <> "'"
+              VLeft e@(V (AlreadyInstalled _ _)) -> do
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 pure ExitSuccess
 
               VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logWarn $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                runLogger $ logError $
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
-              VLeft (V (DirNotEmpty fp, ())) -> do
-                runLogger $ logWarn $
-                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+              VLeft (V (DirNotEmpty fp)) -> do
+                runLogger $ logError $
+                  "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
 
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                    "Check the logs at " <> T.pack 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
+              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
 
 
@@ -465,21 +405,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         void $ liftE $ sequenceE (installCabalBin
+         liftE $ runBothE' (installCabalBin
                                     v
-                                    isolateDir
+                                    (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
+                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           void $ liftE $ sequenceE (installCabalBindist
+           liftE $ runBothE' (installCabalBindist
                                       (DownloadInfo uri Nothing "")
                                       v
-                                      isolateDir
+                                      (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
+                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
            pure vi
       )
       >>= \case
@@ -488,26 +428,24 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            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 <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               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 (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 <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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
@@ -516,22 +454,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         void $ liftE $ sequenceE (installHLSBin
+         liftE $ runBothE' (installHLSBin
                                     v
-                                    isolateDir
+                                    (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
+                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
            -- TODO: support legacy
-           void $ liftE $ sequenceE (installHLSBindist
+           liftE $ runBothE' (installHLSBindist
                                       (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
                                       v
-                                      isolateDir
+                                      (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
+                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
            pure vi
       )
       >>= \case
@@ -540,34 +478,24 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            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
-                <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               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 (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
-                <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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
@@ -576,21 +504,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
         Nothing -> runInstTool s' instPlatform $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          void $ liftE $ sequenceE (installStackBin
+          liftE $ runBothE' (installStackBin
                                      v
-                                     isolateDir
+                                     (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
-                                   ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
+                                   ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
           pure vi
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
             (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            void $ liftE $ sequenceE (installStackBindist
+            liftE $ runBothE' (installStackBindist
                                        (DownloadInfo uri Nothing "")
                                        v
-                                       isolateDir
+                                       (maybe GHCupInternal IsolateDir isolateDir)
                                        forceInstall
-                                     ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
+                                     ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
             pure vi
       )
       >>= \case
@@ -599,25 +527,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            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 <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               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 (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 <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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

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

app/ghcup/GHCup/OptParse/Nuke.hs

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

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -14,9 +14,10 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.File
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -33,7 +34,6 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Utils.Prelude
 import GHCup.Download (getDownloadsF)
 
 

app/ghcup/GHCup/OptParse/Rm.hs

@@ -18,9 +18,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -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

@@ -10,14 +10,18 @@ module GHCup.OptParse.Run where
 
 import           GHCup
 import           GHCup.Utils
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.File
 import           GHCup.OptParse.Common
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude
+import           GHCup.Prelude.File
+#ifdef IS_WINDOWS
+import           GHCup.Prelude.Process
+import           GHCup.Prelude.Process.Windows ( execNoMinGW )
+#endif
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 import           Control.Exception.Safe         ( MonadMask, MonadCatch )
 #if !MIN_VERSION_base(4,13,0)
@@ -32,7 +36,6 @@ 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.Exit
@@ -56,11 +59,13 @@ import qualified System.Posix.Process          as SPP
 data RunOptions = RunOptions
   { runAppendPATH :: Bool
   , runInstTool'  :: Bool
+  , runMinGWPath  :: Bool
   , runGHCVer     :: Maybe ToolVersion
   , runCabalVer   :: Maybe ToolVersion
   , runHLSVer     :: Maybe ToolVersion
   , runStackVer   :: Maybe ToolVersion
   , runBinDir     :: Maybe FilePath
+  , runQuick      :: Bool
   , runCOMMAND    :: [String]
   }
 
@@ -70,8 +75,8 @@ data RunOptions = RunOptions
     --[ Parsers ]--
     ---------------
 
-          
-    
+
+
 runOpts :: Parser RunOptions
 runOpts =
   RunOptions
@@ -79,6 +84,8 @@ runOpts =
           (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
     <*> switch
           (short 'i' <> long "install" <> help "Install the tool, if missing")
+    <*> switch
+          (short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
     <*> optional
           (option
             (eitherReader toolVersionEither)
@@ -121,6 +128,8 @@ runOpts =
            <> 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."))
           
 
@@ -173,6 +182,8 @@ type RunEffects = '[ AlreadyInstalled
                    , NoToolVersionSet
                    , FileAlreadyExistsError
                    , ProcessError
+                   , UninstallFailed
+                   , MergeFileTreeError
                    ]
 
 runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@@ -219,29 +230,15 @@ run :: forall m.
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
 run RunOptions{..} runAppState leanAppstate runLogger = do
-   r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool'
+   r <- if not runQuick
         then runRUN runAppState $ do
          toolchain <- liftE resolveToolchainFull
-         tmp <- case runBinDir of
-           Just bindir -> do
-             liftIO $ createDirRecursive' bindir
-             liftIO $ canonicalizePath bindir
-           Nothing -> do
-             d <- liftIO $ predictableTmpDir toolchain
-             liftIO $ createDirRecursive' d
-             liftIO $ canonicalizePath d
+         tmp <- liftIO $ createTmpDir toolchain
          liftE $ installToolChainFull toolchain tmp
          pure tmp
         else runLeanRUN leanAppstate $ do
          toolchain <- resolveToolchain
-         tmp <- case runBinDir of
-           Just bindir -> do
-             liftIO $ createDirRecursive' bindir
-             liftIO $ canonicalizePath bindir
-           Nothing -> do
-             d <- liftIO $ predictableTmpDir toolchain
-             liftIO $ createDirRecursive' d
-             liftIO $ canonicalizePath d
+         tmp <- liftIO $ createTmpDir toolchain
          liftE $ installToolChain toolchain tmp
          pure tmp
    case r of
@@ -256,7 +253,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
                pure ExitSuccess
 #else
-               r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
+               r' <- if runMinGWPath
+                     then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
+                     else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
                case r' of
                  VRight _ -> pure ExitSuccess
                  VLeft e -> do
@@ -269,9 +268,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
 
   where
 
-   isToolTag :: ToolVersion -> Bool
-   isToolTag (ToolTag _) = True
-   isToolTag _           = False
+   createTmpDir :: Toolchain -> IO FilePath
+   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
    resolveToolchainFull :: ( MonadFail m
@@ -343,6 +349,8 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                               , AlreadyInstalled
                               , FileAlreadyExistsError
                               , CopyError
+                              , UninstallFailed
+                              , MergeFileTreeError
                               ] (ResourceT (ReaderT AppState m)) ()
    installToolChainFull Toolchain{..} tmp = do
          forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
@@ -351,25 +359,26 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
              Just (GHC, v) -> do
                unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
                  (_tvVersion v)
-                 Nothing
+                 GHCupInternal
                  False
+                 []
                setTool GHC v tmp
              Just (Cabal, v) -> do
                unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
                  (_tvVersion v)
-                 Nothing
+                 GHCupInternal
                  False
                setTool Cabal v tmp
              Just (Stack, v) -> do
                unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
                  (_tvVersion v)
-                 Nothing
+                 GHCupInternal
                  False
                setTool Stack v tmp
              Just (HLS, v) -> do
                unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
                  (_tvVersion v)
-                 Nothing
+                 GHCupInternal
                  False
                setTool HLS v tmp
              _ -> pure ()

app/ghcup/GHCup/OptParse/Set.hs

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

app/ghcup/GHCup/OptParse/ToolRequirements.hs

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

app/ghcup/GHCup/OptParse/UnSet.hs

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

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -14,7 +14,8 @@ module GHCup.OptParse.Upgrade where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.File
+import           GHCup.Prelude.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -59,15 +60,16 @@ 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
@@ -92,6 +94,7 @@ type UpgradeEffects = '[ DigestError
                        , FileDoesNotExistError
                        , CopyError
                        , DownloadFailed
+                       , ToolShadowed
                        ]
 
 
@@ -120,18 +123,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,8 +17,9 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Types
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Utils
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -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

@@ -22,9 +22,9 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics      hiding ( toolRequirements )
 import           GHCup.Utils
-import           GHCup.Utils.Logger
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.Version
 
 import           Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -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"
@@ -157,7 +155,6 @@ main = do
   versions. It maintains a self-contained ~/.ghcup directory.
 
 ENV variables:
-  * TMPDIR: where ghcup does the work (unpacking, building, ...)
   * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
   * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
 
@@ -222,7 +219,7 @@ 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 ()
@@ -245,14 +242,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)
@@ -296,26 +289,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
-            InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
-            Set setCommand           -> set setCommand runAppState runLeanAppState runLogger
-            UnSet unsetCommand       -> unset unsetCommand runLeanAppState runLogger
-            List lo                  -> list lo no_color runAppState
-            Rm rmCommand             -> rm rmCommand runAppState runLogger
-            DInfo                    -> dinfo runAppState runLogger
-            Compile compileCommand   -> compile compileCommand settings dirs runAppState runLogger
-            Config configCommand     -> config configCommand settings keybindings runLogger
+            Install installCommand     -> install installCommand settings appState runLogger
+            InstallCabalLegacy iopts   -> install (Left (InstallCabal iopts)) settings appState runLogger
+            Set setCommand             -> set setCommand runAppState runLeanAppState runLogger
+            UnSet unsetCommand         -> unset unsetCommand runLeanAppState runLogger
+            List lo                    -> list lo no_color runAppState
+            Rm rmCommand               -> rm rmCommand runAppState runLogger
+            DInfo                      -> dinfo runAppState runLogger
+            Compile compileCommand     -> compile compileCommand settings dirs runAppState runLogger
+            Config configCommand       -> config configCommand settings keybindings runLogger
             Whereis whereisOptions
-                    whereisCommand   -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
-#ifndef DISABLE_UPGRADE
-            Upgrade uOpts force'     -> upgrade uOpts force' dirs runAppState runLogger
-#endif
-            ToolRequirements topts   -> toolRequirements topts runAppState runLogger
-            ChangeLog changelogOpts  -> changelog changelogOpts runAppState runLogger
-            Nuke                     -> nuke appState runLogger
-            Prefetch pfCom           -> prefetch pfCom runAppState runLogger
-            GC gcOpts                -> gc gcOpts runAppState runLogger
-            Run runCommand           -> run runCommand appState leanAppstate runLogger
+                    whereisCommand     -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
+            Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
+            ToolRequirements topts     -> toolRequirements topts runAppState runLogger
+            ChangeLog changelogOpts    -> changelog changelogOpts runAppState runLogger
+            Nuke                       -> nuke appState runLogger
+            Prefetch pfCom             -> prefetch pfCom runAppState runLogger
+            GC gcOpts                  -> gc gcOpts runAppState runLogger
+            Run runCommand             -> run runCommand appState leanAppstate runLogger
 
           case res of
             ExitSuccess        -> pure ()
@@ -349,13 +340,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
     (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
   alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
     (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
     (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
-#endif
+  alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
   alreadyInstalling _ _ = pure False
 
   cmp' :: ( HasLog env

cabal.ghc8107.project

@@ -15,7 +15,7 @@ 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,
 
 package libarchive
   flags: -system-libarchive
@@ -29,6 +29,9 @@ package cabal-plan
 package aeson
   flags: +ordered-keymap
 
+package streamly
+  flags: +use-unliftio
+
 allow-newer: base, ghc-prim, template-haskell, language-c
 
 with-compiler: ghc-8.10.7

cabal.ghc8107.project.freeze

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

cabal.ghc902.project

@@ -15,7 +15,7 @@ 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,
 
 package libarchive
   flags: -system-libarchive
@@ -29,6 +29,9 @@ package cabal-plan
 package aeson
   flags: +ordered-keymap
 
+package streamly
+  flags: +use-unliftio
+
 allow-newer: base, ghc-prim, template-haskell, language-c
 
 with-compiler: ghc-9.0.2

cabal.ghc902.project.freeze

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

cabal.ghc923.project

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

cabal.ghc923.project.freeze

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

cabal.project

@@ -16,8 +16,6 @@ source-repository-package
 constraints: http-io-streams -brotli,
              any.Cabal ==3.6.2.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
@@ -31,4 +29,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

docs/about.md

@@ -74,12 +74,15 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
 
 ## Known users
 
-* Github actions:
-	- [actions/virtual-environments](https://github.com/actions/virtual-environments)
-	- [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
+* CI:
+	- [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
+	- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
+	- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
 * mirrors:
 	- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
 * tools:
+	- [vscode-haskell](https://github.com/haskell/vscode-haskell)
+	- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
 	- [vabal](https://github.com/Franciman/vabal)
 
 ## Known problems

docs/guide.md

@@ -57,6 +57,13 @@ 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
@@ -69,7 +76,6 @@ Partial configuration is fine. Command line options always override the config f
 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
@@ -221,6 +227,8 @@ See `ghcup compile ghc --help` for further information.
 
 ## 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.
 
@@ -279,10 +287,11 @@ GHCup itself is also pre-installed on all platforms, but may use non-standard in
 GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
 this is cryptographically secure.
 
-First, obtain the gpg key:
+First, obtain the gpg keys:
 
 ```sh
-gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
+gpg --batch --keyserver keys.openpgp.org     --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
+gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
 ```
 
 Then verify the gpg key in one of these ways:
@@ -301,7 +310,7 @@ 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
 
 ## ghcup run
@@ -315,3 +324,34 @@ ghcup run --ghc 8.10.7 --cabal latest --hls latest --stack latest --install -- c
 ```
 
 This will execute vscode with GHC set to 8.10.7 and all other tools to their latest version.
+
+# Troubleshooting
+
+## Script immediately exits on windows
+
+There are two possible reasons:
+
+1. your company blocks the script (some have a whitelist)... ask your administrator
+2. your Antivirus or Windows Defender interfere with the installation. Disable them temporarily.
+
+## C compiler cannot create executables
+
+### Darwin
+
+You need to update your XCode command line tools, e.g. [like this](https://stackoverflow.com/questions/34617452/how-to-update-xcode-from-command-line).
+
+## Certificate authority errors (curl)
+
+If your certificates are outdated or improperly configured, curl may be unable
+to download ghcup.
+
+There are two known workarounds:
+
+1. Tell curl to ignore certificate errors (dangerous): `curl -k https://gitlab.haskell.org/haskell/ghcup-hs/-/raw/master/scripts/bootstrap/bootstrap-haskell | GHCUP_CURL_OPTS="-k" sh`
+2. Try to use wget instead: `wget -O /dev/stdout https://gitlab.haskell.org/haskell/ghcup-hs/-/raw/master/scripts/bootstrap/bootstrap-haskell | BOOTSTRAP_HASKELL_DOWNLOADER=wget sh`
+
+On windows, you can disable curl like so:
+
+```pwsh
+Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true
+```

docs/index.md

@@ -57,7 +57,7 @@ hide:
 </section>
 
 <p id="help" class="ghcup-help">
-  Need help? Ask on
+  Need help? Check the <a href="guide/#troubleshooting">Troubleshooting section</a> or ask on
   <span>
     <a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup">
       <img src="irc.svg" alt="" />

docs/install.md

@@ -55,7 +55,8 @@ GHCup supports the following tools, which are also known as the **Haskell Toolch
 <table>
 <thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
 <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.3</td><td><span style="color:blue">latest</span>, base-4.16.2.0</td></tr>
+<tr><td>9.2.2</td><td>base-4.16.1.0</td></tr>
 <tr><td>9.2.1</td><td>base-4.16.0.0</td></tr>
 <tr><td>9.0.2</td><td>base-4.15.1.0</td></tr>
 <tr><td>9.0.1</td><td>base-4.15.0.0</td></tr>
@@ -187,7 +188,7 @@ Lower availability of bindists. Stack and HLS binaries are experimental.
 Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
 and place it into your `PATH` anywhere.
 
-If you want to GPG verify the binaries, import the following key first: `7784930957807690A66EBDBE3786C5262ECB4A3F`.
+If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`.
 
 Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
 
@@ -199,6 +200,14 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
 
 See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
 
+## VSCode integration
+The developers of the Haskell Language Server offer an [extension](https://github.com/haskell/vscode-haskell) tightly integrated with the [Haskell Language Server](https://github.com/haskell/haskell-language-server). To get started:
+
+1. Install GHCup. During installation, opt in to install the Haskell Language Server (HLS).
+2. Install the extension (from VSCode: Ctrl + P and then `ext install haskell.haskell`).
+3. Make sure your project uses the GHC version installed from GHCup (otherwise HLS is likely to fail on launch):
+    - instructions for [stack](https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc)
+
 ## Get help
 
 * [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.17.7
+version:            0.1.18.0
 license:            LGPL-3.0-only
 license-file:       LICENSE
 copyright:          Julian Ospald 2020
@@ -44,38 +44,39 @@ flag internal-downloader
   manual:      True
 
 flag no-exe
-  description: Don't build any executables 
-  default:     False
-  manual:      True
-
-flag disable-upgrade
-  description:
-    Disable upgrade functionality. This is mainly to support brew packagers.
-
+  description: Don't build any executables
   default:     False
   manual:      True
 
 library
   exposed-modules:
     GHCup
+    GHCup.Cabal
     GHCup.Download
     GHCup.Download.Utils
     GHCup.Errors
+    GHCup.GHC
+    GHCup.HLS
+    GHCup.List
     GHCup.Platform
+    GHCup.Prelude
+    GHCup.Prelude.File
+    GHCup.Prelude.File.Search
+    GHCup.Prelude.Internal
+    GHCup.Prelude.Logger
+    GHCup.Prelude.Logger.Internal
+    GHCup.Prelude.MegaParsec
+    GHCup.Prelude.Process
+    GHCup.Prelude.String.QQ
+    GHCup.Prelude.Version.QQ
     GHCup.Requirements
+    GHCup.Stack
     GHCup.Types
     GHCup.Types.JSON
     GHCup.Types.JSON.Utils
     GHCup.Types.Optics
     GHCup.Utils
     GHCup.Utils.Dirs
-    GHCup.Utils.File
-    GHCup.Utils.File.Common
-    GHCup.Utils.Logger
-    GHCup.Utils.MegaParsec
-    GHCup.Utils.Prelude
-    GHCup.Utils.String.QQ
-    GHCup.Utils.Version.QQ
     GHCup.Version
 
   hs-source-dirs:     lib
@@ -107,8 +108,8 @@ library
     , base                  >=4.12       && <5
     , base16-bytestring     >=0.1.1.6    && <1.1
     , binary                ^>=0.8.6.0
-    , bytestring            ^>=0.10
-    , Cabal                 ^>=3.6.2.0
+    , bytestring            >=0.10       && <0.12
+    , Cabal                 ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0
     , case-insensitive      ^>=1.2.1.0
     , casing                ^>=0.1.4.1
     , containers            ^>=0.6
@@ -116,6 +117,7 @@ library
     , deepseq               ^>=1.4.4.0
     , directory             ^>=1.3.6.0
     , disk-free-space       ^>=0.1.0.1
+    , exceptions            ^>=0.10
     , filepath              ^>=1.4.2.1
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
@@ -133,6 +135,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
@@ -160,9 +163,11 @@ library
   if os(windows)
     cpp-options:   -DIS_WINDOWS
     other-modules:
-      GHCup.Utils.File.Windows
-      GHCup.Utils.Prelude.Windows
-      GHCup.Utils.Windows
+      GHCup.Prelude.File.Windows
+      GHCup.Prelude.Windows
+    -- GHCup.OptParse.Run uses this
+    exposed-modules:
+      GHCup.Prelude.Process.Windows
 
     build-depends:
       , bzlib
@@ -171,10 +176,13 @@ library
 
   else
     other-modules:
-      GHCup.Utils.File.Posix
-      GHCup.Utils.Posix
-      GHCup.Utils.Prelude.Posix
+      GHCup.Prelude.File.Posix
+      GHCup.Prelude.File.Posix.Foreign
+      GHCup.Prelude.File.Posix.Traversals
+      GHCup.Prelude.Posix
+      GHCup.Prelude.Process.Posix
 
+    c-sources:     cbits/dirutils.c
     build-depends:
       , bz2              >=0.5.0.5 && <1.1
       , terminal-size    ^>=0.3.2.1
@@ -204,6 +212,7 @@ executable ghcup
     GHCup.OptParse.Set
     GHCup.OptParse.ToolRequirements
     GHCup.OptParse.UnSet
+    GHCup.OptParse.Upgrade
     GHCup.OptParse.Whereis
 
   hs-source-dirs:     app/ghcup
@@ -227,13 +236,14 @@ executable ghcup
     , aeson-pretty          ^>=0.8.8
     , async                 ^>=2.2.3
     , base                  >=4.12     && <5
-    , bytestring            ^>=0.10
+    , bytestring            >=0.10       && <0.12
     , cabal-plan            ^>=0.7.2
     , containers            ^>=0.6
     , deepseq               ^>=1.4
     , directory             ^>=1.3.6.0
     , filepath              ^>=1.4.2.1
     , ghcup
+    , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , megaparsec            >=8.0.0    && <9.3
@@ -277,12 +287,6 @@ executable ghcup
   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
@@ -291,6 +295,7 @@ test-suite ghcup-test
   other-modules:
     GHCup.ArbitraryTypes
     GHCup.Types.JSONSpec
+    GHCup.Utils.FileSpec
     Spec
 
   default-language:   Haskell2010
@@ -308,14 +313,17 @@ test-suite ghcup-test
 
   build-depends:
     , base                      >=4.12    && <5
-    , bytestring                ^>=0.10
+    , bytestring            >=0.10       && <0.12
     , containers                ^>=0.6
-    , generic-arbitrary         >=0.1.0   && <0.3
+    , directory                 ^>=1.3.6.0
+    , filepath                  ^>=1.4.2.1
+    , generic-arbitrary         >=0.1.0  && < 0.2.1 || >=0.2.2 && <0.3
     , ghcup
     , 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/Cabal.hs

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

lib/GHCup/Download.hs

@@ -34,9 +34,10 @@ 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
+import           GHCup.Prelude
+import           GHCup.Prelude.File
+import           GHCup.Prelude.Logger.Internal
+import           GHCup.Prelude.Process
 import           GHCup.Version
 
 import           Control.Applicative
@@ -69,7 +70,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe
-import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
@@ -145,7 +145,7 @@ getDownloadsF = do
 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
@@ -242,7 +242,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
@@ -581,7 +581,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
@@ -599,7 +599,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/Download/IOStreams.hs

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

lib/GHCup/Download/Utils.hs

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

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

lib/GHCup/HLS.hs

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

lib/GHCup/List.hs

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

lib/GHCup/Platform.hs

@@ -23,10 +23,11 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.File
-import           GHCup.Utils.Logger
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.String.QQ
+import           GHCup.Utils.Dirs
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.Process
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -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/Prelude.hs

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

lib/GHCup/Prelude/File.hs

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

lib/GHCup/Prelude/File/Posix.hs

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

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

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

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

@@ -0,0 +1,92 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+
+module GHCup.Prelude.File.Posix.Traversals (
+-- lower-level stuff
+  readDirEnt
+, unpackDirStream
+) where
+
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>))
+#endif
+import GHCup.Prelude.File.Posix.Foreign
+
+import Unsafe.Coerce (unsafeCoerce)
+import Foreign.C.Error
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix
+import Foreign (alloca)
+import System.Posix.Internals (peekFilePath)
+
+
+
+
+
+----------------------------------------------------------
+-- dodgy stuff
+
+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/Prelude/File/Search.hs

@@ -1,13 +1,13 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
 
-module GHCup.Utils.File.Common (
-  module GHCup.Utils.File.Common
+module GHCup.Prelude.File.Search (
+  module GHCup.Prelude.File.Search
   , ProcessError(..)
   , CapturedProcess(..)
   ) where
 
-import           GHCup.Utils.Prelude
 import           GHCup.Types(ProcessError(..), CapturedProcess(..))
 
 import           Control.Monad.Reader
@@ -15,15 +15,19 @@ import           Data.Maybe
 import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
-import           System.Directory        hiding (findFiles)
+import           System.Directory hiding ( removeDirectory
+                                         , 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
+import Control.Exception.Safe (handleIO)
+import System.Directory.Internal.Prelude (ioeGetErrorType)
 
 
 
@@ -35,7 +39,7 @@ searchPath paths needle = go paths
  where
   go [] = pure Nothing
   go (x : xs) =
-    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
+    handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e)
       $ do
           contents <- listDirectory x
           findM (isMatch x) contents >>= \case
@@ -49,6 +53,12 @@ searchPath paths needle = go paths
   isExecutable :: FilePath -> IO Bool
   isExecutable file = executable <$> getPermissions file
 
+  -- TODO: inlined from GHCup.Prelude
+  findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
+  ifM ~b ~t ~f = do
+    b' <- b
+    if b' then t else f
+
 
 -- | Check wether a binary is shadowed by another one that comes before
 -- it in PATH. Returns the path to said binary, if any.
@@ -96,10 +106,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
@@ -107,5 +113,3 @@ findFiles' path parser = do
   pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents
 
 
-checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
-checkFileAlreadyExists fp = liftIO $ doesFileExist fp

lib/GHCup/Prelude/File/Windows.hs

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

lib/GHCup/Prelude/Internal.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeOperators       #-}
 
 {-|
-Module      : GHCup.Utils.Prelude
+Module      : GHCup.Prelude.Internal
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -15,27 +15,11 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 
-GHCup specific prelude. Lots of Excepts functionality.
+Stuff that doesn't need GHCup modules, so we can avoid
+recursive imports.
 -}
-module GHCup.Utils.Prelude
-  (module GHCup.Utils.Prelude,
-#if defined(IS_WINDOWS)
-   module GHCup.Utils.Prelude.Windows
-#else
-   module GHCup.Utils.Prelude.Posix
-#endif
-  )
-where
+module GHCup.Prelude.Internal where
 
-import           GHCup.Types
-import           GHCup.Errors
-import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)
-#if defined(IS_WINDOWS)
-import           GHCup.Utils.Prelude.Windows
-#else
-import           GHCup.Utils.Prelude.Posix
-#endif
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -44,22 +28,15 @@ 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 )
 import           Data.Maybe
-import           Data.Foldable
-import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Data.Word8                  hiding ( isDigit )
 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.IO.Unsafe
-import           System.Directory
-import           System.FilePath
 
 import           Control.Retry
 import           GHC.IO.Exception
@@ -68,7 +45,6 @@ import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
 import qualified Data.List.Split               as Split
-import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -78,6 +54,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
@@ -181,13 +158,6 @@ lEM' :: forall e' e es a m
      -> Excepts es m a
 lEM' f em = lift em >>= lE . first f
 
--- for some obscure reason... this won't type-check if we move it to a different module
-catchWarn :: forall es m env . ( Pretty (V es)
-                             , MonadReader env m
-                             , HasLog env
-                             , MonadIO m
-                             , Monad m) => Excepts es m () -> Excepts '[] m ()
-catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
 
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
@@ -308,56 +278,6 @@ intToText :: Integral a => a -> T.Text
 intToText = TL.toStrict . B.toLazyText . B.decimal
 
 
-pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
-pvpToVersion pvp_ rest =
-  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
-
--- | Convert a version to a PVP and unparsable rest.
---
--- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
-versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
-versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
-versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v
- where
-  alternative :: MonadThrow m => Version -> m PVP
-  alternative v' = case NE.takeWhile isDigit (_vChunks v') of
-    [] -> throwM $ ParseError "Couldn't convert Version to PVP"
-    xs -> pure $ pvpFromList (unsafeDigit <$> xs)
-
-  rest :: Version -> Text
-  rest (Version _ cs pr me) =
-    let chunks = NE.dropWhile isDigit cs
-        ver = intersperse (T.pack ".") . chunksAsT $ chunks
-        me' = maybe [] (\m -> [T.pack "+",m]) me
-        pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
-        prefix = case (ver, pr', me') of
-                   (_:_, _, _) -> T.pack "."
-                   _           -> T.pack ""
-    in prefix <> mconcat (ver <> pr' <> me')
-   where
-    chunksAsT :: Functor t => t VChunk -> t Text
-    chunksAsT = fmap (foldMap f)
-      where
-        f :: VUnit -> Text
-        f (Digits i) = T.pack $ show i
-        f (Str s)    = s
-
-    foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
-    foldable d g f | null f    = d
-                   | otherwise = g f
-
-
-
-  isDigit :: VChunk -> Bool
-  isDigit (Digits _ :| []) = True
-  isDigit _                = False
-
-  unsafeDigit :: VChunk -> Int
-  unsafeDigit (Digits x :| []) = fromIntegral x
-  unsafeDigit _ = error "unsafeDigit: wrong input"
-
-pvpFromList :: [Int] -> PVP
-pvpFromList = PVP . NE.fromList . fmap fromIntegral
 
 -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
 -- the Unicode replacement character U+FFFD.
@@ -376,167 +296,6 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
   go (x : xs) | x == _period = [_backslash, _period] ++ go xs
               | otherwise    = x : go xs
 
--- | More permissive version of 'createDirRecursive'. This doesn't
--- error when the destination is a symlink to a directory.
-createDirRecursive' :: FilePath -> IO ()
-createDirRecursive' p =
-  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
-    . createDirectoryIfMissing True
-    $ p
-
- where
-  isSymlinkDir e = do
-    ft <- pathIsSymbolicLink p
-    case ft of
-      True -> do
-        rp <- canonicalizePath p
-        rft <- doesDirectoryExist rp
-        case rft of
-          True -> pure ()
-          _ -> throwIO e
-      _ -> throwIO e
-
-
--- | 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
-recyclePathForcibly :: ( MonadIO m
-                       , MonadReader env m
-                       , HasDirs env
-                       , MonadMask m
-                       )
-                    => FilePath
-                    -> m ()
-recyclePathForcibly fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
-      let dest = tmp </> takeFileName fp
-      liftIO (moveFile fp dest)
-          `catch`
-          (\e -> if | isDoesNotExistError e -> pure ()
-                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
-                    | otherwise -> throwIO e)
-          `finally`
-            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removePathForcibly fp
-
-
-rmPathForcibly :: ( MonadIO m
-                  , MonadMask m
-                  )
-               => FilePath
-               -> m ()
-rmPathForcibly fp
-  | isWindows = recover (liftIO $ removePathForcibly fp)
-  | otherwise = liftIO $ removePathForcibly fp
-
-
-rmDirectory :: (MonadIO m, MonadMask m)
-            => FilePath
-            -> m ()
-rmDirectory fp
-  | isWindows = recover (liftIO $ removeDirectory fp)
-  | otherwise = liftIO $ removeDirectory fp
-
-
--- https://www.sqlite.org/src/info/89f1848d7f
--- https://github.com/haskell/directory/issues/96
-recycleFile :: ( MonadIO m
-               , MonadMask m
-               , MonadReader env m
-               , HasDirs env
-               )
-            => FilePath
-            -> m ()
-recycleFile fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
-      tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
-      let dest = tmp </> takeFileName fp
-      liftIO (moveFile fp dest)
-        `catch`
-          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
-        `finally`
-          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmFile :: ( MonadIO m
-          , MonadMask m
-          )
-      => FilePath
-      -> m ()
-rmFile fp
-  | isWindows = recover (liftIO $ removeFile fp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-                => FilePath
-                -> m ()
-rmDirectoryLink fp
-  | isWindows = recover (liftIO $ removeDirectoryLink fp)
-  | otherwise = liftIO $ removeDirectoryLink fp
 
 
 recover :: (MonadIO m, MonadMask m) => m a -> m a
@@ -549,10 +308,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 +517,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/Prelude/Logger.hs

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

lib/GHCup/Prelude/Logger/Internal.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 
 {-|
-Module      : GHCup.Utils.Logger
+Module      : GHCup.Utils.Logger.Internal
 Description : logger definition
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -11,16 +11,13 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 
-Here we define our main logger.
+Breaking import cycles.
 -}
-module GHCup.Utils.Logger where
+module GHCup.Prelude.Logger.Internal where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
-import           GHCup.Utils.String.QQ
 
-import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
@@ -28,12 +25,7 @@ import           Data.Text               ( Text )
 import           Optics
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
-import           System.FilePath
-import           System.IO.Error
-import           Text.Regex.Posix
 
-import qualified Data.ByteString               as B
-import GHCup.Utils.Prelude
 import qualified Data.Text                     as T
 
 logInfo :: ( MonadReader env m
@@ -91,7 +83,7 @@ logInternal logLevel msg = do
   let strs = T.split (== '\n') msg
   let out = case strs of
               [] -> T.empty
-              (x:xs) -> 
+              (x:xs) ->
                   foldr (\a b -> a <> "\n" <> b) mempty
                 . ((l <> " " <> x) :)
                 . fmap (\line' -> style' "[ ...   ] " <> line' )
@@ -109,22 +101,3 @@ logInternal logLevel msg = do
   let outr = lr <> " " <> msg <> "\n"
   liftIO $ fileOutter outr
 
-
-initGHCupFileLogging :: ( MonadReader env m
-                        , HasDirs env
-                        , MonadIO m
-                        , MonadMask m
-                        ) => m FilePath
-initGHCupFileLogging = do
-  Dirs { logsDir } <- getDirs
-  let logfile = logsDir </> "ghcup.log"
-  logFiles <- liftIO $ findFiles
-    logsDir
-    (makeRegexOpts compExtended
-                   execBlank
-                   ([s|^.*\.log$|] :: B.ByteString)
-    )
-  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
-
-  liftIO $ writeFile logfile ""
-  pure logfile

lib/GHCup/Prelude/MegaParsec.hs

@@ -10,7 +10,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Utils.MegaParsec where
+module GHCup.Prelude.MegaParsec where
 
 import           GHCup.Types
 

lib/GHCup/Prelude/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.Utils.Posix where
+module GHCup.Prelude.Posix where
 
 
 -- | Enables ANSI support on windows, does nothing on unix.
@@ -12,3 +12,8 @@ module GHCup.Utils.Posix where
 enableAnsiSupport :: IO (Either String Bool)
 enableAnsiSupport = pure (Right True)
 
+isWindows, isNotWindows :: Bool
+isWindows = False
+isNotWindows = not isWindows
+
+

lib/GHCup/Prelude/Process.hs

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

lib/GHCup/Prelude/Process/Posix.hs

@@ -1,29 +1,31 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DataKinds  #-}
+{-# LANGUAGE MultiWayIf  #-}
+{-# LANGUAGE CApiFFI #-}
 
 {-|
 Module      : GHCup.Utils.File.Posix
-Description : File and unix APIs
+Description : Process handling for unix
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : POSIX
-
-This module handles file and executable handling.
-Some of these functions use sophisticated logging.
 -}
-module GHCup.Utils.File.Posix where
+module GHCup.Prelude.Process.Posix where
 
-import           GHCup.Utils.File.Common
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.Logger
+import           GHCup.Utils.Dirs
+import           GHCup.Prelude.File
+import           GHCup.Prelude.File.Posix
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
 
 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
@@ -36,11 +38,9 @@ import           Data.List
 import           Data.Word8
 import           GHC.IO.Exception
 import           System.IO                      ( stderr )
-import           System.IO.Error
+import           System.IO.Error      hiding    ( catchIOError )
 import           System.FilePath
-import           System.Directory
 import           System.Posix.Directory
-import           System.Posix.Files
 import           System.Posix.IO
 import           System.Posix.Process           ( ProcessStatus(..) )
 import           System.Posix.Types
@@ -87,7 +87,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 +262,7 @@ captureOutStreams action = do
 
         -- execute the action
         a <- action
-        void $ evaluate a
+        void $ E.evaluate a
 
       -- close everything we don't need
       closeFd childStdoutWrite
@@ -360,42 +360,3 @@ toProcessError exe args mps = case mps of
 
 
 
-chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
-chmod_755 fp = do
-  let exe_mode =
-          nullFileMode
-            `unionFileModes` ownerExecuteMode
-            `unionFileModes` ownerReadMode
-            `unionFileModes` ownerWriteMode
-            `unionFileModes` groupExecuteMode
-            `unionFileModes` groupReadMode
-            `unionFileModes` otherExecuteMode
-            `unionFileModes` otherReadMode
-  logDebug ("chmod 755 " <> T.pack fp)
-  liftIO $ setFileMode fp exe_mode
-
-
--- |Default permissions for a new file.
-newFilePerms :: FileMode
-newFilePerms =
-  ownerWriteMode
-    `unionFileModes` ownerReadMode
-    `unionFileModes` groupWriteMode
-    `unionFileModes` groupReadMode
-    `unionFileModes` otherWriteMode
-    `unionFileModes` otherReadMode
-
-
--- | Checks whether the binary is a broken link.
-isBrokenSymlink :: FilePath -> IO Bool
-isBrokenSymlink fp = do
-  try (pathIsSymbolicLink fp) >>= \case
-    Right True -> do
-      let symDir = takeDirectory fp
-      tfp <- getSymbolicLinkTarget fp
-      not <$> doesPathExist
-        -- this drops 'symDir' if 'tfp' is absolute
-        (symDir </> tfp)
-    Right b -> pure b
-    Left e | isDoesNotExistError e -> pure False
-           | otherwise -> throwIO e

lib/GHCup/Prelude/Process/Windows.hs

@@ -1,24 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DataKinds  #-}
 
 {-|
-Module      : GHCup.Utils.File.Windows
-Description : File and windows APIs
+Module      : GHCup.Utils.Process.Windows
+Description : Process handling for windows
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : Windows
-
-This module handles file and executable handling.
-Some of these functions use sophisticated logging.
 -}
-module GHCup.Utils.File.Windows where
+module GHCup.Prelude.Process.Windows where
 
-import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
 import           GHCup.Utils.Dirs
-import           GHCup.Utils.File.Common
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.File.Search
+import           GHCup.Prelude.Logger.Internal
 import           GHCup.Types
 import           GHCup.Types.Optics
 
@@ -31,12 +28,11 @@ import           Data.List
 import           Foreign.C.Error
 import           GHC.IO.Exception
 import           GHC.IO.Handle
-import           System.Directory
 import           System.Environment
 import           System.FilePath
 import           System.IO
 import           System.Process
- 
+
 import qualified Control.Exception             as EX
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
@@ -45,6 +41,7 @@ import qualified Data.Text                     as T
 
 
 
+
 toProcessError :: FilePath
                -> [FilePath]
                -> ExitCode
@@ -164,8 +161,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"
-      stderrLogfile = logsDir </> lfile <> ".stderr.log"
+  let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
+      stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
   cp <- createProcessWithMingwPath ((proc exe args)
     { cwd = chdir
     , env = env
@@ -199,7 +196,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
@@ -209,10 +206,36 @@ exec :: MonadIO m
      -> Maybe [(String, String)] -- ^ optional environment
      -> m (Either ProcessError ())
 exec exe args chdir env = do
+  -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
+  forM_ (Map.fromList <$> env) $ \cEnv -> do
+    let paths = ["PATH", "Path"]
+        curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
+        newPath = intercalate [searchPathSeparator] curPaths
+    liftIO $ setEnv "PATH" ""
+    liftIO $ setEnv "Path" newPath
   cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
   exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
   pure $ toProcessError exe args exit_code
 
+-- | Like 'exec', except doesn't add msys2 stuff to PATH.
+execNoMinGW :: MonadIO m
+     => FilePath       -- ^ thing to execute
+     -> [FilePath]     -- ^ args for the thing
+     -> Maybe FilePath   -- ^ optionally chdir into this
+     -> Maybe [(String, String)] -- ^ optional environment
+     -> m (Either ProcessError ())
+execNoMinGW exe args chdir env = do
+  -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
+  forM_ (Map.fromList <$> env) $ \cEnv -> do
+    let paths = ["PATH", "Path"]
+        curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
+        newPath = intercalate [searchPathSeparator] curPaths
+    liftIO $ setEnv "PATH" ""
+    liftIO $ setEnv "Path" newPath
+  let cp = (proc exe args) { cwd = chdir, env = env }
+  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
+  pure $ toProcessError exe args exit_code
+
 
 -- | Thin wrapper around `executeFile`.
 execShell :: MonadIO m
@@ -228,20 +251,15 @@ execShell exe args chdir env = do
   pure $ toProcessError cmd [] exit_code
 
 
-chmod_755 :: MonadIO m => FilePath -> m ()
-chmod_755 fp =
-  let perm = setOwnerWritable True emptyPermissions
-  in liftIO $ setPermissions fp perm
-
-
 createProcessWithMingwPath :: MonadIO m
                           => CreateProcess
                           -> m CreateProcess
 createProcessWithMingwPath cp = do
   msys2Dir <- liftIO ghcupMsys2Dir
   cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
-  let mingWPaths = [msys2Dir </> "usr" </> "bin"
-                   ,msys2Dir </> "mingw64" </> "bin"]
+  let mingWPaths = [msys2Dir </> "mingw64" </> "bin"
+                   ,msys2Dir </> "usr" </> "bin"
+                   ]
       paths = ["PATH", "Path"]
       curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
       newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
@@ -256,16 +274,5 @@ 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
-isBrokenSymlink fp = do
-  b <- pathIsLink fp
-  if b
-  then do
-    tfp <- getLinkTarget fp
-    not <$> doesPathExist
-      -- this drops 'symDir' if 'tfp' is absolute
-      (takeDirectory fp </> tfp)
-  else pure False

lib/GHCup/Prelude/String/QQ.hs

@@ -30,7 +30,7 @@ Any instance of the IsString type is permitted.
 (For GHC versions 6, write "[$s||]" instead of "[s||]".)
 
 -}
-module GHCup.Utils.String.QQ
+module GHCup.Prelude.String.QQ
   ( s
   )
 where

lib/GHCup/Prelude/Version/QQ.hs

@@ -16,7 +16,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Utils.Version.QQ where
+module GHCup.Prelude.Version.QQ where
 
 import           Data.Data
 import           Data.Text                      ( Text )

lib/GHCup/Prelude/Windows.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module GHCup.Utils.Windows where
+module GHCup.Prelude.Windows where
 
 
 import           Control.Exception.Safe
@@ -46,3 +46,8 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do
     >> pure (Right False)
   else pure (Right True)
 
+
+isWindows, isNotWindows :: Bool
+isWindows = True
+isNotWindows = not isWindows
+

lib/GHCup/Stack.hs

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

lib/GHCup/Types.hs

@@ -26,6 +26,8 @@ module GHCup.Types
   )
   where
 
+import {-# SOURCE #-} GHCup.Utils.Dirs          ( fromGHCupPath, GHCupPath )
+
 import           Control.DeepSeq                ( NFData, rnf )
 import           Data.Map.Strict                ( Map )
 import           Data.List.NonEmpty             ( NonEmpty (..) )
@@ -438,12 +440,14 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
 instance NFData Settings
 
 data Dirs = Dirs
-  { baseDir  :: FilePath
-  , binDir   :: FilePath
-  , cacheDir :: FilePath
-  , logsDir  :: FilePath
-  , confDir  :: FilePath
-  , recycleDir :: FilePath -- mainly used on windows
+  { baseDir    :: GHCupPath
+  , binDir     :: FilePath
+  , cacheDir   :: GHCupPath
+  , logsDir    :: GHCupPath
+  , confDir    :: GHCupPath
+  , dbDir      :: GHCupPath
+  , recycleDir :: GHCupPath -- mainly used on windows
+  , tmpDir     :: GHCupPath
   }
   deriving (Show, GHC.Generic)
 
@@ -628,3 +632,32 @@ 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
+
+
+isSafeDir :: InstallDirResolved -> Bool
+isSafeDir (IsolateDirResolved _) = False
+isSafeDir (GHCupDir _)           = True
+isSafeDir (GHCupBinDir _)        = False
+
+
+
+
+
+
+
+

lib/GHCup/Types/JSON.hs

@@ -23,7 +23,7 @@ module GHCup.Types.JSON where
 
 import           GHCup.Types
 import           GHCup.Types.JSON.Utils
-import           GHCup.Utils.MegaParsec
+import           GHCup.Prelude.MegaParsec
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)
@@ -79,37 +79,6 @@ 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 ->
@@ -349,7 +318,40 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
 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
-
 deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
 deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
+
+instance FromJSON URLSource where
+  parseJSON v =
+        parseGHCupURL v
+    <|> parseOwnSourceLegacy v
+    <|> parseOwnSourceNew1 v
+    <|> parseOwnSourceNew2 v
+    <|> parseOwnSpec v
+    <|> legacyParseAddSource v
+    <|> newParseAddSource v
+   where
+    parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
+      r :: URI <- o .: "OwnSource"
+      pure (OwnSource [Right r])
+    parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
+      r :: [URI] <- o .: "OwnSource"
+      pure (OwnSource (fmap Right r))
+    parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "OwnSource"
+      pure (OwnSource r)
+    parseOwnSpec = withObject "URLSource" $ \o -> do
+      r :: GHCupInfo <- o .: "OwnSpec"
+      pure (OwnSpec r)
+    parseGHCupURL = withObject "URLSource" $ \o -> do
+      _ :: [Value] <- o .: "GHCupURL"
+      pure GHCupURL
+    legacyParseAddSource = withObject "URLSource" $ \o -> do
+      r :: Either GHCupInfo URI <- o .: "AddSource"
+      pure (AddSource [r])
+    newParseAddSource = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "AddSource"
+      pure (AddSource r)
+
+deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
+

lib/GHCup/Utils.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -22,18 +23,18 @@ module GHCup.Utils
   ( module GHCup.Utils.Dirs
   , module GHCup.Utils
 #if defined(IS_WINDOWS)
-  , module GHCup.Utils.Windows
+  , module GHCup.Prelude.Windows
 #else
-  , module GHCup.Utils.Posix
+  , module GHCup.Prelude.Posix
 #endif
   )
 where
 
 
 #if defined(IS_WINDOWS)
-import GHCup.Utils.Windows
+import GHCup.Prelude.Windows
 #else
-import GHCup.Utils.Posix
+import GHCup.Prelude.Posix
 #endif
 import           GHCup.Download
 import           GHCup.Errors
@@ -41,11 +42,13 @@ 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.MegaParsec
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.String.QQ
+import           GHCup.Version
+import           GHCup.Prelude
+import           GHCup.Prelude.File
+import           GHCup.Prelude.Logger.Internal
+import           GHCup.Prelude.MegaParsec
+import           GHCup.Prelude.Process
+import           GHCup.Prelude.String.QQ
 
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
@@ -58,6 +61,7 @@ import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+import           Data.Char                      ( isHexDigit )
 import           Data.Bifunctor                 ( first )
 import           Data.ByteString                ( ByteString )
 import           Data.Either
@@ -71,10 +75,10 @@ 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
+import           Text.PrettyPrint.HughesPJClass (prettyShow)
 import           URI.ByteString
 
 import qualified Codec.Compression.BZip        as BZip
@@ -86,6 +90,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
@@ -96,14 +103,14 @@ import qualified Data.List.NonEmpty            as NE
 -- >>> import System.Directory
 -- >>> import URI.ByteString
 -- >>> import qualified Data.Text as T
--- >>> import GHCup.Utils.Prelude
+-- >>> import GHCup.Prelude
 -- >>> import GHCup.Download
 -- >>> import GHCup.Version
 -- >>> import GHCup.Errors
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
 -- >>> import Optics
--- >>> import GHCup.Utils.Version.QQ
+-- >>> import GHCup.Prelude.Version.QQ
 -- >>> import qualified Data.Text.Encoding as E
 -- >>> import Control.Monad.Reader
 -- >>> import Haskus.Utils.Variant.Excepts
@@ -277,14 +284,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.
@@ -327,7 +334,7 @@ ghcSet mtarget = do
 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
@@ -430,7 +437,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
@@ -515,7 +522,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.
@@ -616,7 +623,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 +634,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 +648,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 +852,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 +912,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")
 
 
@@ -1016,6 +1023,28 @@ applyPatch patch ddir = do
     !? PatchFailed
 
 
+applyAnyPatch :: ( MonadReader env m
+                 , HasDirs env
+                 , HasLog env
+                 , HasSettings env
+                 , MonadUnliftIO m
+                 , MonadCatch m
+                 , MonadResource m
+                 , MonadThrow m
+                 , MonadMask m
+                 , MonadIO m)
+              => Maybe (Either FilePath [URI])
+              -> FilePath
+              -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
+applyAnyPatch Nothing _                   = pure ()
+applyAnyPatch (Just (Left pdir)) workdir  = liftE $ applyPatches pdir workdir
+applyAnyPatch (Just (Right uris)) workdir = do
+  tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
+  forM_ uris $ \uri -> do
+    patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
+    liftE $ applyPatch patch workdir
+
+
 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
                    => Platform
@@ -1029,6 +1058,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 +1070,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 +1080,12 @@ runBuildAction :: ( MonadReader env m
                   , MonadFail m
                   , MonadCatch m
                   )
-               => FilePath        -- ^ build directory (cleaned up depending on Settings)
-               -> Maybe FilePath  -- ^ dir to *always* clean up on exception
+               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
                -> 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 +1107,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 +1116,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)
 
@@ -1113,97 +1160,6 @@ getVersionInfo v' tool =
     )
 
 
--- | The file extension for executables.
-exeExt :: String
-exeExt
-  | isWindows = ".exe"
-  | otherwise = ""
-
--- | The file extension for executables.
-exeExt' :: ByteString
-exeExt'
-  | isWindows = ".exe"
-  | otherwise = ""
-
-
-
-
--- | On unix, we can use symlinks, so we just get the
--- symbolic link target.
---
--- On windows, we have to emulate symlinks via shims,
--- see 'createLink'.
-getLinkTarget :: FilePath -> IO FilePath
-getLinkTarget fp
-  | isWindows = do
-      content <- readFile (dropExtension fp <.> "shim")
-      [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
-      pure $ stripNewline $ dropPrefix "path = " p
-  | otherwise = getSymbolicLinkTarget fp
-
-
--- | Checks whether the path is a link.
-pathIsLink :: FilePath -> IO Bool
-pathIsLink fp
-  | isWindows = doesPathExist (dropExtension fp <.> "shim")
-  | otherwise = pathIsSymbolicLink fp
-
-
-rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
-rmLink fp
-  | isWindows = do
-      hideError doesNotExistErrorType . recycleFile $ fp
-      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
-  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp
-
-
--- | Creates a symbolic link on unix and a fake symlink on windows for
--- executables, which:
---     1. is a shim exe
---     2. has a corresponding .shim file in the same directory that
---        contains the target
---
--- This overwrites previously existing files.
---
--- On windows, this requires that 'ensureGlobalTools' was run beforehand.
-createLink :: ( MonadMask m
-              , MonadThrow m
-              , HasLog env
-              , MonadIO m
-              , MonadReader env m
-              , HasDirs env
-              , MonadUnliftIO m
-              , MonadFail m
-              )
-           => FilePath      -- ^ path to the target executable
-           -> FilePath      -- ^ path to be created
-           -> m ()
-createLink link exe
-  | isWindows = do
-      dirs <- getDirs
-      let shimGen = cacheDir dirs </> "gs.exe"
-
-      let shim = dropExtension exe <.> "shim"
-          -- For hardlinks, link needs to be absolute.
-          -- If link is relative, it's relative to the target exe.
-          -- Note that (</>) drops lhs when rhs is absolute.
-          fullLink = takeDirectory exe </> link
-          shimContents = "path = " <> fullLink
-
-      logDebug $ "rm -f " <> T.pack exe
-      rmLink exe
-
-      logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
-      liftIO $ copyFile shimGen exe
-      liftIO $ writeFile shim shimContents
-  | otherwise = do
-      logDebug $ "rm -f " <> T.pack exe
-      hideError doesNotExistErrorType $ recycleFile exe
-
-      logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
-      liftIO $ createFileLink link exe
-
-
 ensureGlobalTools :: ( MonadMask m
                      , MonadThrow m
                      , HasLog env
@@ -1225,8 +1181,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 $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
+          lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (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 +1190,17 @@ ensureGlobalTools
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
-  createDirRecursive' baseDir
-  createDirRecursive' (baseDir </> "ghc")
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do
+  createDirRecursive' (fromGHCupPath baseDir)
+  createDirRecursive' (fromGHCupPath baseDir </> "ghc")
+  createDirRecursive' (fromGHCupPath baseDir </> "hls")
   createDirRecursive' binDir
-  createDirRecursive' cacheDir
-  createDirRecursive' logsDir
-  createDirRecursive' confDir
-  createDirRecursive' trashDir
+  createDirRecursive' (fromGHCupPath cacheDir)
+  createDirRecursive' (fromGHCupPath logsDir)
+  createDirRecursive' (fromGHCupPath confDir)
+  createDirRecursive' (fromGHCupPath trashDir)
+  createDirRecursive' (fromGHCupPath dbDir)
+  createDirRecursive' (fromGHCupPath tmpDir)
   pure ()
 
 
@@ -1264,10 +1223,88 @@ 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
-    unless (null contents) (throwE $ DirNotEmpty isoDir)
+    empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe 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)
+
+
+-- | Warn if the installed and set HLS is not compatible with the installed and
+-- set GHC version.
+warnAboutHlsCompatibility :: ( MonadReader env m
+                             , HasDirs env
+                             , HasLog env
+                             , MonadThrow m
+                             , MonadCatch m
+                             , MonadIO m
+                             )
+                          => m ()
+warnAboutHlsCompatibility = do
+  supportedGHC <- hlsGHCVersions
+  currentGHC   <- fmap _tvVersion <$> ghcSet Nothing
+  currentHLS   <- hlsSet
+
+  case (currentGHC, currentHLS) of
+    (Just gv, Just hv) | gv `notElem` supportedGHC -> do
+      logWarn $
+        "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
+        "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
+        "Haskell IDE support may not work until this is fixed." <> "\n" <>
+        "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
+        T.pack (prettyShow supportedGHC)
+
+    _ -> return ()
+
+
+
+    -----------
+    --[ Git ]--
+    -----------
+
+
+
+isCommitHash :: String -> Bool
+isCommitHash str' = let hex = all isHexDigit str'
+                        len = length str'
+                    in hex && len == 40
+
+
+gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
+gitOut args dir = do
+  CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)
+  case _exitCode of
+    ExitSuccess   -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
+    ExitFailure c -> do
+      let pe = NonZeroExit c "git" args
+      lift $ logDebug $ T.pack (prettyShow pe)
+      throwE pe
+
+processBranches :: T.Text -> [String]
+processBranches str' = let lines'   = lines (T.unpack str')
+                           words'   = fmap words lines'
+                           refs     = catMaybes $ fmap (`atMay` 1) words'
+                           branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
+                       in branches
+

lib/GHCup/Utils.hs-boot

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

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
 
@@ -38,35 +107,86 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
-import           GHCup.Utils.MegaParsec
-import           GHCup.Utils.Logger
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude.MegaParsec
+import           GHCup.Prelude.File.Search
+import           GHCup.Prelude.String.QQ
+import           GHCup.Prelude.Logger.Internal (logWarn, logDebug)
+#if defined(IS_WINDOWS)
+import           GHCup.Prelude.Windows ( isWindows )
+#else
+import           GHCup.Prelude.Posix   ( isWindows )
+#endif
 
+import           Control.DeepSeq (NFData, rnf)
 import           Control.Exception.Safe
 import           Control.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           System.DiskSpace                                                
+import           Safe
+import           System.Directory hiding ( removeDirectory
+                                         , removeDirectoryRecursive
+                                         , removePathForcibly
+                                         , findFiles
+                                         )
+import qualified System.Directory              as SD
+
 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
 import qualified Data.Yaml.Aeson               as Y
 import qualified Text.Megaparsec               as MP
-import Control.Concurrent (threadDelay)
+import System.IO.Error (ioeGetErrorType)
 
 
 
+    ---------------------------
+    --[ GHCupPath utilities ]--
+    ---------------------------
+
+-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
+--
+-- The constructor is not exported.
+newtype GHCupPath = GHCupPath FilePath
+  deriving (Show, Eq, Ord)
+
+instance NFData GHCupPath where
+  rnf (GHCupPath fp) = rnf fp
+
+appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
+appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)
+
+fromGHCupPath :: GHCupPath -> FilePath
+fromGHCupPath (GHCupPath gp) = gp
+
+createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
+createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d
+
+
+getGHCupTmpDirs :: IO [GHCupPath]
+getGHCupTmpDirs = do
+  tmpdir <- fromGHCupPath <$> ghcupTMPDir
+  ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
+    tmpdir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^ghcup-.*$|] :: ByteString)
+    )
+  pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)
+
+
     ------------------------------
     --[ GHCup base directories ]--
     ------------------------------
@@ -76,11 +196,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 +210,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 +234,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 +247,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 +257,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 +276,17 @@ ghcupCacheDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".cache")
-          pure (bdir </> "ghcup")
-        else ghcupBaseDir <&> (</> "cache")
+          pure (GHCupPath (bdir </> "ghcup"))
+        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,16 +296,55 @@ ghcupLogsDir
             Nothing -> do
               home <- liftIO getHomeDirectory
               pure (home </> ".cache")
-          pure (bdir </> "ghcup" </> "logs")
-        else ghcupBaseDir <&> (</> "logs")
+          pure (GHCupPath (bdir </> "ghcup" </> "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 = ghcupBaseDir <&> (</> "trash")
+ghcupRecycleDir :: IO GHCupPath
+ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
 
 
+-- | Defaults to '~/.ghcup/tmp.
+--
+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
+-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
+ghcupTMPDir :: IO GHCupPath
+ghcupTMPDir
+  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
+          pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
+        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
+
 
 getAllDirs :: IO Dirs
 getAllDirs = do
@@ -195,6 +354,8 @@ getAllDirs = do
   logsDir    <- ghcupLogsDir
   confDir    <- ghcupConfigDir
   recycleDir <- ghcupRecycleDir
+  tmpDir     <- ghcupTMPDir
+  dbDir      <- ghcupDbDir
   pure Dirs { .. }
 
 
@@ -206,16 +367,21 @@ 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
 ghcupConfigFile = do
   filepath <- getConfigFilePath
-  contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
+  contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
   case contents of
       Nothing -> pure defaultUserSettings
-      Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
+      Just contents' -> liftE
+        . veitherToExcepts @_ @'[JSONError]
+        . either (VLeft . V) VRight
+        . first (JSONDecodeError . displayException)
+        . Y.decodeEither'
+        $ contents'
 
 
     -------------------------
@@ -224,10 +390,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 +402,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'.
@@ -252,20 +418,27 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
 parseGHCupHLSDir (T.pack -> fp) =
   throwEither $ MP.parse version' "" fp
 
+-- TODO: inlined from GHCup.Prelude
+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+throwEither a = case a of
+  Left  e -> throwM e
+  Right r -> pure r
+
 -- | ~/.ghcup/hls by default, for new-style installs.
-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,31 +448,10 @@ mkGhcupTmpDir :: ( MonadReader env m
                  , MonadThrow m
                  , MonadMask m
                  , MonadIO m)
-              => m FilePath
-mkGhcupTmpDir = do
-  tmpdir <- liftIO getCanonicalTemporaryDirectory
-
-  let minSpace = 5000 -- a rough guess, aight?
-  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
-  when (maybe False (toBytes minSpace >) space) $ do
-    logWarn ("Possibly insufficient disk space on "
-      <> T.pack tmpdir
-      <> ". At least "
-      <> T.pack (show minSpace)
-      <> " MB are recommended, but only "
-      <> toMB (fromJust space)
-      <> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
-    logWarn
-      "...waiting for 10 seconds before continuing anyway, you can still abort..."
-    liftIO $ threadDelay 10000000 -- give the user a sec to intervene
-
-  liftIO $ createTempDirectory tmpdir "ghcup"
- where
-  toBytes mb = mb * 1024 * 1024
-  toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
-  truncate' :: Double -> Int -> Double
-  truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
-      where t = 10^n
+              => m GHCupPath
+mkGhcupTmpDir = GHCupPath <$> do
+  Dirs { tmpDir } <- getDirs
+  liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
 
 
 withGHCupTmpDir :: ( MonadReader env m
@@ -312,15 +464,15 @@ 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)))
-            . rmPathForcibly
+                $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
+            . removePathForcibly
             $ fp))
 
 
@@ -360,12 +512,28 @@ 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 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module GHCup.Utils.File (
-  module GHCup.Utils.File.Common,
-#if IS_WINDOWS
-  module GHCup.Utils.File.Windows
-#else
-  module GHCup.Utils.File.Posix
-#endif
-) where
-
-import GHCup.Utils.File.Common
-#if IS_WINDOWS
-import GHCup.Utils.File.Windows
-#else
-import GHCup.Utils.File.Posix
-#endif

lib/GHCup/Utils/File/Common.hs-boot

@@ -1,5 +0,0 @@
-module GHCup.Utils.File.Common where
-
-import           Text.Regex.Posix
-
-findFiles :: FilePath -> Regex -> IO [FilePath]

lib/GHCup/Utils/Logger.hs-boot

@@ -1,19 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DataKinds        #-}
-
-module GHCup.Utils.Logger where
-
-import           GHCup.Types
-
-import           Control.Monad.IO.Class
-import           Control.Monad.Reader
-import           Data.Text               ( Text )
-import           Optics
-
-logWarn :: ( MonadReader env m
-           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-           , MonadIO m
-           )
-        => Text
-        -> m ()
-

lib/GHCup/Utils/Prelude/Posix.hs

@@ -1,20 +0,0 @@
-module GHCup.Utils.Prelude.Posix where
-
-import System.Directory
-import System.Posix.Files
-
-
-isWindows, isNotWindows :: Bool
-isWindows = False
-isNotWindows = not isWindows
-
-
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile = rename
-
-
-moveFilePortable :: FilePath -> FilePath -> IO ()
-moveFilePortable from to = do
-  copyFile from to
-  removeFile from
-  

lib/GHCup/Utils/Prelude/Windows.hs

@@ -1,17 +0,0 @@
-module GHCup.Utils.Prelude.Windows where
-
-import qualified System.Win32.File             as Win32
-
-
-isWindows, isNotWindows :: Bool
-isWindows = True
-isNotWindows = not isWindows
-
-
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile from to = Win32.moveFileEx from (Just to) 0
-
-
-moveFilePortable :: FilePath -> FilePath -> IO ()
-moveFilePortable = Win32.moveFile
-

lib/GHCup/Version.hs

@@ -16,12 +16,18 @@ import           GHCup.Types
 import           Paths_ghcup (version)
 
 import           Data.Version (Version(versionBranch))
-import           Data.Versions hiding (version)
 import           URI.ByteString
 import           URI.ByteString.QQ
 
 import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
+import qualified Data.Versions as V
+import Control.Exception.Safe (MonadThrow)
+import Data.Text (Text)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.List (intersperse)
+import Control.Monad.Catch (throwM)
+import GHCup.Errors (ParseError(..))
 
 -- | This reflects the API version of the YAML.
 --
@@ -31,22 +37,72 @@ ghcupURL :: URI
 ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|]
 
 -- | The current ghcup version.
-ghcUpVer :: PVP
-ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version
+ghcUpVer :: V.PVP
+ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version
 
 -- | ghcup version as numeric string.
 numericVer :: String
-numericVer = T.unpack . prettyPVP $ ghcUpVer
+numericVer = T.unpack . V.prettyPVP $ ghcUpVer
 
-versionCmp :: Versioning -> VersionCmp -> Bool
+versionCmp :: V.Versioning -> VersionCmp -> Bool
 versionCmp ver1 (VR_gt ver2)   = ver1 > ver2
 versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
 versionCmp ver1 (VR_lt ver2)   = ver1 < ver2
 versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
 versionCmp ver1 (VR_eq ver2)   = ver1 == ver2
 
-versionRange :: Versioning -> VersionRange -> Bool
+versionRange :: V.Versioning -> VersionRange -> Bool
 versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
 versionRange ver' (OrRange cmps range) = 
   versionRange ver' (SimpleRange cmps) || versionRange ver' range
 
+pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version
+pvpToVersion pvp_ rest =
+  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_
+
+-- | Convert a version to a PVP and unparsable rest.
+--
+-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
+versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text)
+versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
+versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v
+ where
+  alternative :: MonadThrow m => V.Version -> m V.PVP
+  alternative v' = case NE.takeWhile isDigit (V._vChunks v') of
+    [] -> throwM $ ParseError "Couldn't convert Version to PVP"
+    xs -> pure $ pvpFromList (unsafeDigit <$> xs)
+
+  rest :: V.Version -> Text
+  rest (V.Version _ cs pr me) =
+    let chunks = NE.dropWhile isDigit cs
+        ver = intersperse (T.pack ".") . chunksAsT $ chunks
+        me' = maybe [] (\m -> [T.pack "+",m]) me
+        pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
+        prefix = case (ver, pr', me') of
+                   (_:_, _, _) -> T.pack "."
+                   _           -> T.pack ""
+    in prefix <> mconcat (ver <> pr' <> me')
+   where
+    chunksAsT :: Functor t => t V.VChunk -> t Text
+    chunksAsT = fmap (foldMap f)
+      where
+        f :: V.VUnit -> Text
+        f (V.Digits i) = T.pack $ show i
+        f (V.Str s)    = s
+
+    foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
+    foldable d g f | null f    = d
+                   | otherwise = g f
+
+
+
+  isDigit :: V.VChunk -> Bool
+  isDigit (V.Digits _ :| []) = True
+  isDigit _                = False
+
+  unsafeDigit :: V.VChunk -> Int
+  unsafeDigit (V.Digits x :| []) = fromIntegral x
+  unsafeDigit _ = error "unsafeDigit: wrong input"
+
+pvpFromList :: [Int] -> V.PVP
+pvpFromList = V.PVP . NE.fromList . fmap fromIntegral

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
+#   * BOOTSTRAP_HASKELL_DOWNLOADER - which downloader to use (default: curl)
 #   * 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
@@ -26,10 +27,11 @@
 
 plat="$(uname -s)"
 arch=$(uname -m)
-ghver="0.1.17.7"
+ghver="0.1.17.8"
 : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}"
 
 export GHCUP_SKIP_UPDATE_CHECK=yes
+: "${BOOTSTRAP_HASKELL_DOWNLOADER:=curl}"
 
 case "${plat}" in
         MSYS*|MINGW*)
@@ -133,6 +135,15 @@ _eghcup() {
     fi
 }
 
+ecabal() {
+	edo _ecabal "$@"
+}
+
+_ecabal() {
+    # shellcheck disable=SC2086
+    "${GHCUP_BIN}/cabal" "$@"
+}
+
 _done() {
 	echo
 	echo "==============================================================================="
@@ -313,11 +324,35 @@ download_ghcup() {
     esac
     case "${plat}" in
         MSYS*|MINGW*)
-			edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup.exe
+            case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
+                "curl")
+	                # shellcheck disable=SC2086
+                    edo curl -Lf ${GHCUP_CURL_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup.exe
+                    ;;
+                "wget")
+	                # shellcheck disable=SC2086
+                    edo wget -O /dev/stdout ${GHCUP_WGET_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup.exe
+                    ;;
+                *)
+                    die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
+                    ;;
+            esac
 			edo chmod +x "${GHCUP_BIN}"/ghcup.exe
 			;;
 		*)
-			edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
+            case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
+                "curl")
+	                # shellcheck disable=SC2086
+                    edo curl -Lf ${GHCUP_CURL_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup
+                    ;;
+                "wget")
+	                # shellcheck disable=SC2086
+                    edo wget -O /dev/stdout ${GHCUP_WGET_OPTS} "${_url}" > "${GHCUP_BIN}"/ghcup
+                    ;;
+                *)
+                    die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
+                    ;;
+            esac
 			edo chmod +x "${GHCUP_BIN}"/ghcup
 			;;
 	esac
@@ -344,6 +379,17 @@ download_ghcup() {
 
 	# shellcheck disable=SC1090
     edo . "${GHCUP_DIR}"/env
+    case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
+        "curl")
+            eghcup config set downloader Curl
+            ;;
+        "wget")
+            eghcup config set downloader Wget
+            ;;
+        *)
+            die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"
+            ;;
+    esac
     eghcup upgrade
 }
 
@@ -537,7 +583,7 @@ adjust_cabal_config() {
     else
         cabal_bin="$HOME/AppData/Roaming/cabal/bin"
     fi
-    edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
+    ecabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
 }
 
 ask_cabal_config_init() {
@@ -688,7 +734,7 @@ find_shell
 echo
 echo "Welcome to Haskell!"
 echo
-echo "This script will download and install the following binaries:"
+echo "This script can download and install the following binaries:"
 echo "  * ghcup - The Haskell toolchain installer"
 echo "  * ghc   - The Glasgow Haskell Compiler"
 echo "  * cabal - The Cabal build tool for managing Haskell software"
@@ -763,7 +809,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
 
 	do_cabal_config_init $ask_cabal_config_init_answer
 
-	edo cabal new-update --ignore-project
+	edo cabal update --ignore-project
 else # don't install ghc and cabal
 	case "${plat}" in
 			MSYS*|MINGW*)

scripts/bootstrap/bootstrap-haskell.ps1

@@ -36,7 +36,9 @@ param (
     # Instead of installing a new MSys2, use an existing installation
     [string]$ExistingMsys2Dir,
     # Specify the cabal root directory (default: '$InstallDir\cabal')
-    [string]$CabalDir
+    [string]$CabalDir,
+    # Whether to disable use of curl.exe
+    [switch]$DisableCurl
 )
 
 $Silent = !$Interactive
@@ -242,7 +244,7 @@ if ($Silent -and !($InstallDir)) {
 	Print-Msg -color Magenta -msg (@'
 Welcome to Haskell!
 
-This script will download and install the following programs:
+This script can 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
@@ -250,7 +252,7 @@ This script will download and install the following programs:
   * stack - (optional) A cross-platform program for developing Haskell projects
   * hls   - (optional) A language server for developers to integrate with their editor/IDE
 
-Please not that ANTIVIRUS may interfere with the installation. If you experience problems, consider
+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:\')?
@@ -425,7 +427,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
     $archive = 'msys2-x86_64-latest.sfx.exe'
     $archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive")
     
-    if (Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) {
+    if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) {
       Exec "curl.exe" '-o' "$archivePath" ('https://repo.msys2.org/distrib/{0}' -f "$archive")
     } else {
       Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder ([IO.Path]::GetTempPath()) -includeStats
@@ -591,10 +593,17 @@ if ($Minimal) {
   $MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;'
 }
 
-if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
-  Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]]  && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
+if ($DisableCurl) {
+  $BootstrapDownloader = 'export BOOTSTRAP_HASKELL_DOWNLOADER=wget ;'
+  $DownloadScript = 'wget -O /dev/stdout'
 } else {
-  Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]]  && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
+  $DownloadScript = 'curl --proto ''=https'' --tlsv1.2 -sSf'
+}
+
+if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
+  Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]]  && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript)
+} else {
+  Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]]  && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript)
 }
 
 

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-18.27
+resolver: lts-18.28
 
 packages:
   - .
@@ -26,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
@@ -35,10 +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
 
 flags:
   http-io-streams:
@@ -56,6 +57,9 @@ flags:
   cabal-plan:
     exe: false
 
+  streamly:
+    use-unliftio: true
+
 ghc-options:
   "$locals": -O2
   streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

test/GHCup/Utils/FileSpec.hs

@@ -0,0 +1,58 @@
+module GHCup.Utils.FileSpec where
+
+import           GHCup.Prelude.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 "lib")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"
+      not (null l1) `shouldBe` True
+      not (null l2) `shouldBe` True
+      l1 `shouldBe` l2
+    it "getDirectoryContentsRecursiveDFS" $ do
+      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"
+      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