WIP

.gitlab-ci.yml

@@ -13,10 +13,7 @@ variables:
 
   # Sequential version number of all cached things.
   # Bump to invalidate GitLab CI cache.
-  CACHE_REV: 1
+  CACHE_REV: 0
-
-  GIT_SUBMODULE_STRATEGY: recursive
-
 
 ############################################################
 # CI Step
@@ -118,17 +115,13 @@ variables:
   script:
     - bash ./.gitlab/script/ghcup_version.sh
   variables:
-    JSON_VERSION: "0.0.7"
+    JSON_VERSION: "0.0.6"
   artifacts:
     expire_in: 2 week
     paths:
       - test/golden
       - dist-newstyle/cache/
     when: on_failure
-  cache:
-    key: ghcup-test-$CACHE_REV
-    paths:
-      - cabal-cache
 
 # .test_ghcup_scoop:
   # script:
@@ -140,10 +133,6 @@ 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:
@@ -151,10 +140,6 @@ 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:
@@ -162,10 +147,6 @@ 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:
@@ -173,42 +154,45 @@ 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_cache
+      - .brew
-    key: ghcup-test-$CACHE_REV
+      - .brew_cache
-    paths:
-      - cabal-cache
   before_script:
-    # extract brew cache
+    # Install brew locally in the project dir. Packages will also be installed here.
-    - ./.gitlab/script/ci.sh extract_brew_cache
+    - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew'
+    - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
+
     # otherwise we seem to get intel binaries
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
+
+    # make sure to not pollute the machine with temp files etc
+    - mkdir -p $CI_PROJECT_DIR/.bc
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
+    - mkdir -p $CI_PROJECT_DIR/.bl
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
+    - mkdir -p $CI_PROJECT_DIR/.bt
+    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
+
     # update and install packages
-    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
+    - brew update
-    # extract cabal cache
+    - brew install llvm
-    - ./.gitlab/script/ci.sh extract_cabal_cache
+    - brew install autoconf automake coreutils
   script: |
     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
@@ -218,51 +202,37 @@ 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:
@@ -275,19 +245,16 @@ variables:
   only:
     - tags
   variables:
-    JSON_VERSION: "0.0.7"
+    JSON_VERSION: "0.0.6"
 
 ######## stack test ########
 
 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: []
@@ -317,7 +284,6 @@ 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"
@@ -564,17 +530,28 @@ release:darwin:aarch64:
   cache:
     key: darwin-brew-$CACHE_REV
     paths:
-      - brew_cache
+      - .brew
-    key: ghcup-test-$CACHE_REV
+      - .brew_cache
-    paths:
-      - cabal-cache
   before_script:
-    - ./.gitlab/script/ci.sh extract_brew_cache
+    # Install brew locally in the project dir. Packages will also be installed here.
-    - ./.gitlab/script/ci.sh extract_cabal_cache
+    - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew'
+    - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
+
     # otherwise we seem to get intel binaries
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
+
+    # make sure to not pollute the machine with temp files etc
+    - mkdir -p $CI_PROJECT_DIR/.bc
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
+    - mkdir -p $CI_PROJECT_DIR/.bl
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
+    - mkdir -p $CI_PROJECT_DIR/.bt
+    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
+
     # update and install packages
-    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
+    - brew update
+    - brew install llvm
+    - brew install autoconf automake
   script: |
     export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
     export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang
@@ -584,9 +561,6 @@ 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"
@@ -621,9 +595,6 @@ release:freebsd13:
     - .release_ghcup
     - .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
   variables:
     ARTIFACT: "x86_64-portbld-freebsd-ghcup"

.gitlab/after_script.sh

@@ -12,8 +12,4 @@ if [ "${OS}" = "WINDOWS" ] ; then
 	rm -Rf /c/ghcup
 fi
 
-if [ "${OS}" = "DARWIN" ] ; then
-	rm -Rf /private/tmp/.brew_tmp
-fi
-
 exit 0

.gitlab/before_script/freebsd/install_deps.sh

@@ -8,15 +8,7 @@ set -eux
 
 mkdir -p "${TMPDIR}"
 
-if freebsd-version | grep -E '^12.*' ; then
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
-	freebsd_ver=12
-elif freebsd-version | grep -E '^13.*' ; then
-	freebsd_ver=13
-else
-	(>&2 echo "Unsupported FreeBSD version! Please report a bug at https://gitlab.haskell.org/haskell/ghcup-hs/-/issues")
-	exit 1
-fi
-curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-freebsd${freebsd_ver}-ghcup > ./ghcup-bin
 chmod +x ghcup-bin
 
 ./ghcup-bin -v upgrade -i -f

.gitlab/ghcup-run.files

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

.gitlab/ghcup-run.files.windows

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

.gitlab/ghcup_env

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

.gitlab/script/brew.sh

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

.gitlab/script/ci.sh

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

.gitlab/script/ghcup_bootstrap.sh

@@ -6,10 +6,20 @@ 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_cross.sh

@@ -5,6 +5,8 @@ set -eux
 . "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
 
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
+mkdir -p data/
+git clone https://github.com/haskell/ghcup-metadata.git data/metadata
 
 CI_PROJECT_DIR=$(pwd)
 

.gitlab/script/ghcup_git.sh

@@ -5,6 +5,8 @@ set -eux
 . "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
 
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
+mkdir -p data/
+git clone https://github.com/haskell/ghcup-metadata.git data/metadata
 
 CI_PROJECT_DIR=$(pwd)
 

.gitlab/script/ghcup_hls.sh

@@ -5,6 +5,8 @@ set -eux
 . "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
 
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
+mkdir -p data/
+git clone https://github.com/haskell/ghcup-metadata.git data/metadata
 
 CI_PROJECT_DIR=$(pwd)
 
@@ -41,7 +43,7 @@ cabal --version
 
 eghcup debug-info
 
-eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} --ghc ${GHC_VERSION}
+eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} ${GHC_VERSION}
 
 [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version` = "${HLS_TARGET_VERSION}" ] || [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version | sed 's/.0$//'` = "${HLS_TARGET_VERSION}" ]
 

.gitlab/script/ghcup_version.sh

@@ -1,14 +1,15 @@
-#!/usr/bin/env bash
+#!/bin/sh
 
 set -eux
 
 . "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
 
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
+mkdir -p data/
+git clone https://github.com/haskell/ghcup-metadata.git data/metadata
 
 CI_PROJECT_DIR=$(pwd)
 
-
 ecabal() {
 	cabal "$@"
 }
@@ -35,8 +36,6 @@ git describe --always
 
 ### build
 
-rm -rf "${GHCUP_DIR}"/share
-
 ecabal update
 
 if [ "${OS}" = "DARWIN" ] ; then
@@ -97,32 +96,14 @@ rm -rf "${GHCUP_DIR}"
 eghcup --numeric-version
 
 eghcup install ghc ${GHC_VERSION}
-ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})"
+[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
-[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
-[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
 eghcup set ghc ${GHC_VERSION}
 eghcup install cabal ${CABAL_VERSION}
-[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
+[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
 eghcup unset cabal
-"$GHCUP_BIN"/cabal --version && exit 1 || echo yes
+"$GHCUP_BIN"/cabal --version && exit || echo yes
 eghcup set cabal ${CABAL_VERSION}
-[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
+[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
-[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
-
-if [ "${OS}" != "FREEBSD" ] ; then
-	if [ "${ARCH}" = "64" ] ; then
-		eghcup run --ghc 8.10.7 --cabal 3.4.1.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin"
-		if [ "${OS}" == "WINDOWS" ] ; then
-			expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.windows" | sort)
-		else
-			expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort)
-		fi
-		actual=$(cd ".bin" && find . | sort)
-		[ "${actual}" = "${expected}" ]
-		unset actual expected
-		rm -rf .bin
-	fi
-fi
 
 cabal --version
 
@@ -152,7 +133,7 @@ else
 		eghcup --offline install ghc 8.10.3
 		if [ "${ARCH}" = "64" ] ; then
 			expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort)
-			actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
+			actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
 			[ "${actual}" = "${expected}" ]
 			unset actual expected
 		fi
@@ -160,7 +141,7 @@ else
 		eghcup prefetch ghc 8.10.3
 		eghcup --offline install ghc 8.10.3
 		expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort)
-		actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort)
+		actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
 		[ "${actual}" = "${expected}" ]
 		unset actual expected
 	else
@@ -174,14 +155,12 @@ else
 	eghcup set ${GHC_VERSION}
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 	eghcup unset ghc
-    "$GHCUP_BIN"/ghc --numeric-version && exit 1 || echo yes
+    "$GHCUP_BIN"/ghc --numeric-version && exit || echo yes
 	eghcup set ${GHC_VERSION}
 	eghcup --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
@@ -193,18 +172,16 @@ else
 			eghcup install hls
 			haskell-language-server-wrapper --version
 			eghcup unset hls
-			"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit 1 || echo yes
+			"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes
 
 			eghcup install stack
 			stack --version
-			eghcup unset stack
+			eghcup unset hls
-			"$GHCUP_BIN"/stack --version && exit 1 || echo yes
+			"$GHCUP_BIN"/stack --version && exit || echo yes
 		fi
 	fi
 fi
 
-
-
 # check that lazy loading works for 'whereis'
 cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak"
 echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
@@ -216,13 +193,11 @@ eghcup rm $(ghc --numeric-version)
 # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
-		eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4
+		eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
 		eghcup rm cabal 3.4.0.0-rc4
 	fi
 fi
 
-eghcup gc -c
-
 sha_sum() {
 	if [ "${OS}" = "FREEBSD" ] ; then
 		sha256 "$@"
@@ -270,39 +245,13 @@ 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 ]
-
-

.gitmodules

@@ -1,4 +0,0 @@
-[submodule "data/metadata"]
-	path = data/metadata
-	url = https://github.com/haskell/ghcup-metadata.git
-	branch = master

.hlint.yaml

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

CHANGELOG.md

@@ -1,60 +1,5 @@
 # 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)
-
-## 0.1.17.6 -- 2022-03-18
-
-* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
-* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
-* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)
-* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)
-* Fix bug with isolated installation of not previously installed versions
-* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)
-* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`
-* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)
-* Fix max path issues on windows with `ghcup run`
-
-## 0.1.17.5 -- 2022-02-26
-
-* Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137)
-* Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)
-* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/311)
-* Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson
-* Fix redundant upgrade warnings in `ghcup upgrade`
-* Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)
-* Don't print logs to stdout, but stderr
-* Allow unpacking legacy lzma archives wrt [#307](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/307)
-* Allow to disable self-upgrade functionality wrt [#305](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/305)
-* Fix `ghcup install ghc --set` when ghc is already installed wrt [#291](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/291)
-
-## 0.1.17.4 -- 2021-11-13
-
-* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)
-* make upgrading ghcup in TUI more pleasant wrt [#276](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/276)
-* fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`)
-* fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245)
-* redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files
-* avoid redundant update warnings wrt [#283](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283)
-
 ## 0.1.17.3 -- 2021-10-27
 
 * clean up during unpack failures as well

app/ghcup/BrickMain.hs

@@ -13,10 +13,9 @@ import           GHCup.Errors
 import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
+import           GHCup.Logger
 import           GHCup.Prelude ( decUTF8Safe )
-import           GHCup.Prelude.File
+import           GHCup.System.Process
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
 
 import           Brick
 import           Brick.Widgets.Border
@@ -45,6 +44,7 @@ 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,9 +437,6 @@ install' _ (_, ListResult {..}) = do
               , TarDirDoesNotExist
               , FileAlreadyExistsError
               , ProcessError
-              , ToolShadowed
-              , UninstallFailed
-              , MergeFileTreeError
               ]
 
   run (do
@@ -449,19 +446,19 @@ install' _ (_, ListResult {..}) = do
       case lTool of
         GHC   -> do
           let vi = getVersionInfo lVer GHC dls
-          liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
+          liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)
         Cabal -> do
           let vi = getVersionInfo lVer Cabal dls
-          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
+          liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
         GHCup -> do
           let vi = snd <$> getLatest dls GHCup
-          liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
+          liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
         HLS   -> do
           let vi = getVersionInfo lVer HLS dls
-          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
+          liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)
         Stack -> do
           let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
+          liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)
     )
     >>= \case
           VRight (vi, Dirs{..}, Just ce) -> do
@@ -496,9 +493,9 @@ set' _ (_, ListResult {..}) = do
 
   run (do
       case lTool of
-        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
+        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
         Cabal -> liftE $ setCabal lVer $> ()
-        HLS   -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
+        HLS   -> liftE $ setHLS lVer $> ()
         Stack -> liftE $ setStack lVer $> ()
         GHCup -> pure ()
     )
@@ -514,7 +511,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, UninstallFailed]
+  let run = runE @'[NotInstalled]
 
   run (do
       let vi = getVersionInfo lVer lTool dls

app/ghcup/GHCup/OptParse.hs

@@ -15,16 +15,13 @@ module GHCup.OptParse (
   , module GHCup.OptParse.Config
   , module GHCup.OptParse.Whereis
   , module GHCup.OptParse.List
-#ifndef DISABLE_UPGRADE
   , module GHCup.OptParse.Upgrade
-#endif
   , module GHCup.OptParse.ChangeLog
   , module GHCup.OptParse.Prefetch
   , module GHCup.OptParse.GC
   , module GHCup.OptParse.DInfo
   , module GHCup.OptParse.Nuke
   , module GHCup.OptParse.ToolRequirements
-  , module GHCup.OptParse.Run
   , module GHCup.OptParse
 ) where
 
@@ -34,14 +31,11 @@ import           GHCup.OptParse.Install
 import           GHCup.OptParse.Set
 import           GHCup.OptParse.UnSet
 import           GHCup.OptParse.Rm
-import           GHCup.OptParse.Run
 import           GHCup.OptParse.Compile
 import           GHCup.OptParse.Config
 import           GHCup.OptParse.Whereis
 import           GHCup.OptParse.List
-#ifndef DISABLE_UPGRADE
 import           GHCup.OptParse.Upgrade
-#endif
 import           GHCup.OptParse.ChangeLog
 import           GHCup.OptParse.Prefetch
 import           GHCup.OptParse.GC
@@ -95,10 +89,8 @@ data Command
   | Compile CompileCommand
   | Config ConfigCommand
   | Whereis WhereisOptions WhereisCommand
-#ifndef DISABLE_UPGRADE
+  | Upgrade UpgradeOpts Bool
-  | Upgrade UpgradeOpts Bool Bool
+  | ToolRequirements
-#endif
-  | ToolRequirements ToolReqOpts
   | ChangeLog ChangeLogOptions
   | Nuke
 #if defined(BRICK)
@@ -106,15 +98,14 @@ data Command
 #endif
   | Prefetch PrefetchCommand
   | GC GCOptions
-  | Run RunOptions
 
 
 
 opts :: Parser Options
 opts =
   Options
-    <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
+    <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
-    <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
+    <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
     <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
     <*> optional
           (option
@@ -124,10 +115,9 @@ opts =
             <> metavar "URL"
             <> help "Alternative ghcup download info url"
             <> internal
-            <> completer fileUri
             )
           )
-    <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
+    <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
     <*> optional (option
           (eitherReader keepOnParser)
           (  long "keep"
@@ -135,7 +125,6 @@ opts =
           <> help
                "Keep build directories? (default: errors)"
           <> hidden
-          <> completer (listCompleter ["always", "errors", "never"])
           ))
     <*> optional (option
           (eitherReader downloaderParser)
@@ -144,23 +133,20 @@ opts =
           <> metavar "<internal|curl|wget>"
           <> help
           "Downloader to use (default: internal)"
-          <> completer (listCompleter ["internal", "curl", "wget"])
 #else
           <> metavar "<curl|wget>"
           <> help
           "Downloader to use (default: curl)"
-          <> completer (listCompleter ["curl", "wget"])
 #endif
           <> hidden
           ))
-    <*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.")
+    <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
     <*> optional (option
           (eitherReader gpgParser)
           (  long "gpg"
           <> metavar "<strict|lax|none>"
           <> help
           "GPG verification (default: none)"
-          <> completer (listCompleter ["strict", "lax", "none"])
           ))
     <*> com
  where
@@ -227,8 +213,6 @@ com =
            (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
              )
@@ -271,16 +255,6 @@ com =
              (progDesc "Garbage collection"
              <> footerDoc ( Just $ text gcFooter ))
            )
-      <> command
-              "run"
-               (Run
-               <$>
-                 info
-                   (runOpts <**> helper)
-                   (progDesc "Run a command with the given tool in PATH"
-                   <> footerDoc ( Just $ text runFooter )
-                   )
-               )
       <> commandGroup "Main commands:"
       )
     <|> subparser
@@ -289,8 +263,8 @@ com =
               ((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
           <> command
                "tool-requirements"
-               (   ToolRequirements
+               (   (\_ -> ToolRequirements)
-               <$> info (toolReqP <**> helper)
+               <$> info helper
                         (progDesc "Show the requirements for ghc/cabal")
                )
           <> command

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,11 +12,9 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
+import           GHCup.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Prelude
+import           GHCup.QQ.String
-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 )
@@ -36,6 +34,8 @@ import GHCup.Types.Optics
 import GHCup.Utils
 import Data.Versions
 import URI.ByteString (serializeURIRef')
+import GHCup.Prelude
+import GHCup.System.Process (exec)
 import Data.Char (toLower)
 
 
@@ -76,7 +76,6 @@ changelogP =
             )
             (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
               "Open changelog for given tool (default: ghc)"
-              <> completer toolCompleter
             )
           )
     <*> optional (toolVersionArgument Nothing Nothing)

app/ghcup/GHCup/OptParse/Common.hs

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

app/ghcup/GHCup/OptParse/Compile.hs

@@ -16,9 +16,10 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Prelude.Logger
+import           GHCup.Logger
-import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
+import           GHCup.QQ.String
+import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -39,7 +40,6 @@ import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
-import           URI.ByteString          hiding ( uriParser )
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
 import System.FilePath (isPathSeparator)
@@ -68,7 +68,7 @@ data GHCCompileOptions = GHCCompileOptions
   , bootstrapGhc :: Either Version FilePath
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe FilePath
-  , patches      :: Maybe (Either FilePath [URI])
+  , patchDir     :: Maybe FilePath
   , crossTarget  :: Maybe Text
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
@@ -84,11 +84,10 @@ data HLSCompileOptions = HLSCompileOptions
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
   , isolateDir   :: Maybe FilePath
-  , cabalProject :: Maybe (Either FilePath URI)
+  , cabalProject :: Maybe FilePath
-  , cabalProjectLocal :: Maybe URI
+  , cabalProjectLocal :: Maybe FilePath
-  , patches      :: Maybe (Either FilePath [URI])
+  , patchDir     :: Maybe FilePath
   , targetGHCs   :: [ToolVersion]
-  , cabalArgs    :: [Text]
   }
 
 
@@ -98,7 +97,7 @@ data HLSCompileOptions = HLSCompileOptions
     --[ Parsers ]--
     ---------------
 
-
+          
 compileP :: Parser CompileCommand
 compileP = subparser
   (  command
@@ -149,10 +148,7 @@ Examples:
   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 8.10.5 8.10.7 9.0.1|]
-  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'|]
 
 
 ghcCompileOpts :: Parser GHCCompileOptions
@@ -164,7 +160,6 @@ ghcCompileOpts =
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
             "The tool version to compile"
-            <> (completer $ versionCompleter Nothing GHC)
           )
           ) <|>
           (Right <$> (GitBranch <$> option
@@ -172,10 +167,7 @@ ghcCompileOpts =
           (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
             "The git commit/branch/ref to build from"
           ) <*>
-          optional (option str (
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
-            short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
-            <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
-            ))
           )))
     <*> option
           (eitherReader
@@ -188,14 +180,12 @@ ghcCompileOpts =
           <> metavar "BOOTSTRAP_GHC"
           <> help
                "The GHC version (or full path) to bootstrap with (must be installed)"
-          <> (completer $ versionCompleter Nothing GHC)
           )
     <*> optional
           (option
             (eitherReader (readEither @Int))
             (short 'j' <> long "jobs" <> metavar "JOBS" <> help
               "How many jobs to use for make"
-              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
             )
           )
     <*> optional
@@ -203,28 +193,15 @@ ghcCompileOpts =
             str
             (short 'c' <> long "config" <> metavar "CONFIG" <> help
               "Absolute path to build config file"
-             <> completer (bashCompleter "file")
             )
           )
-    <*> (optional
+    <*> optional
-          (
+          (option
-            (fmap Right $ many $ option
+            str
-              (eitherReader uriParser)
+            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
-              (long "patch" <> metavar "PATCH_URI" <> help
+              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
-                "URI to a patch (https/http/file)"
-               <> completer fileUri
-              )
-            )
-            <|>
-            (fmap Left $ option
-              str
-              (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
-                "Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"
-               <> completer (bashCompleter "directory")
-              )
             )
           )
-        )
     <*> optional
           (option
             str
@@ -232,8 +209,13 @@ ghcCompileOpts =
               "Build cross-compiler for this platform"
             )
           )
-    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)"))
+    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
-    <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
     <*> optional
           (option
             (eitherReader
@@ -241,7 +223,6 @@ ghcCompileOpts =
             )
             (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
-            <> (completer $ versionCompleter Nothing GHC)
             )
           )
     <*> optional
@@ -261,7 +242,6 @@ ghcCompileOpts =
             <> long "isolate"
             <> metavar "DIR"
             <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
-            <> completer (bashCompleter "directory")
             )
            )
 
@@ -274,7 +254,6 @@ hlsCompileOpts =
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
             "The tool version to compile"
-            <> (completer $ versionCompleter Nothing HLS)
           )
           ) <|>
           (Right <$> (GitBranch <$> option
@@ -282,19 +261,21 @@ hlsCompileOpts =
           (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
             "The git commit/branch/ref to build from"
           ) <*>
-          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
-            <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
-          ))
           )))
     <*> optional
           (option
             (eitherReader (readEither @Int))
             (short 'j' <> long "jobs" <> metavar "JOBS" <> help
               "How many jobs to use for make"
-              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
             )
           )
-    <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
     <*> optional
           (option
             (eitherReader
@@ -302,7 +283,6 @@ hlsCompileOpts =
             )
             (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
-            <> (completer $ versionCompleter Nothing HLS)
             )
           )
     <*> optional
@@ -312,51 +292,30 @@ hlsCompileOpts =
             <> long "isolate"
             <> metavar "DIR"
             <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
-            <> completer (bashCompleter "directory")
             )
            )
     <*> optional
           (option
-            ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
+            str
             (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
-              "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
+              "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
-              <> completer fileUri
             )
           )
     <*> optional
           (option
-            (eitherReader uriParser)
+            (eitherReader absolutePathParser)
             (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
-              "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
+              "Absolute path to a cabal.project.local to be used for the build. Will be copied over."
-              <> completer fileUri
             )
           )
-    <*> (optional
+    <*> optional
-          (
+          (option
-            (fmap Right $ many $ option
+            (eitherReader absolutePathParser)
-              (eitherReader uriParser)
+            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
-              (long "patch" <> metavar "PATCH_URI" <> help
+              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
-                "URI to a patch (https/http/file)"
-              <> completer fileUri
-              )
-            )
-            <|>
-            (fmap Left $ option
-              str
-              (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
-                "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
-              <> completer (bashCompleter "directory")
-              )
             )
           )
-        )
+    <*> some (toolVersionArgument Nothing (Just GHC))
-    <*> some (
-          option (eitherReader toolVersionEither)
-            (  long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
-            <> completer (tagCompleter GHC [])
-            <> completer (versionCompleter Nothing GHC))
-        )
-    <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
 
 
 
@@ -387,8 +346,6 @@ type GHCEffects = '[ AlreadyInstalled
                   , ProcessError
                   , CopyError
                   , BuildFailed
-                  , UninstallFailed
-                  , MergeFileTreeError
                   ]
 type HLSEffects = '[ AlreadyInstalled
                   , BuildFailed
@@ -407,8 +364,6 @@ type HLSEffects = '[ AlreadyInstalled
                   , NotInstalled
                   , DirNotEmpty
                   , ArchiveResult
-                  , UninstallFailed
-                  , MergeFileTreeError
                   ]
 
 
@@ -448,11 +403,11 @@ compile :: ( Monad m
            )
       => CompileCommand
       -> Settings
-      -> Dirs
       -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))
       -> (ReaderT LeanAppState m () -> m ())
       -> m ExitCode
-compile compileCommand settings Dirs{..} runAppState runLogger = do
+compile compileCommand settings runAppState runLogger = do
+  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
   case compileCommand of
     (CompileHLS HLSCompileOptions { .. }) -> do
       runCompileHLS runAppState (do
@@ -472,15 +427,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     ghcs
                     jobs
                     ovewrwiteVer
-                    (maybe GHCupInternal IsolateDir isolateDir)
+                    isolateDir
                     cabalProject
                     cabalProjectLocal
-                    patches
+                    patchDir
-                    cabalArgs
         GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
         let vi = getVersionInfo targetVer HLS dls
         when setCompile $ void $ liftE $
-          setHLS targetVer SetHLSOnly Nothing
+          setHLS targetVer
         pure (vi, targetVer)
         )
         >>= \case
@@ -495,7 +449,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 (fromGHCupPath logsDir) <> " and the build directory "
+                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9
@@ -523,15 +477,15 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                     bootstrapGhc
                     jobs
                     buildConfig
-                    patches
+                    patchDir
                     addConfArgs
                     buildFlavour
                     hadrian
-                    (maybe GHCupInternal IsolateDir isolateDir)
+                    isolateDir
         GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
         let vi = getVersionInfo (_tvVersion targetVer) GHC dls
         when setCompile $ void $ liftE $
-          setGHC targetVer SetGHCOnly Nothing
+          setGHC targetVer SetGHCOnly
         pure (vi, targetVer)
         )
         >>= \case
@@ -544,17 +498,17 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                 pure ExitSuccess
               VLeft (V (AlreadyInstalled _ v)) -> do
                 runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
+                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
                 pure ExitSuccess
               VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logError $
+                runLogger $ logWarn $
-                  "Install directory " <> T.pack fp <> " is not empty."
+                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger $ logError $ T.pack $ prettyShow err
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                        "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
+                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9

app/ghcup/GHCup/OptParse/Config.hs

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

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -17,10 +17,10 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Version
 import           GHCup.Types
-import           GHCup.Utils.Dirs
 import           GHCup.Prelude
-import           GHCup.Prelude.Logger
+import           GHCup.Directories
-import           GHCup.Prelude.Process
+import           GHCup.Logger
+import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

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.Prelude.Logger
+import           GHCup.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.QQ.String
 
 #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, UninstallFailed ]
+type GCEffects = '[ NotInstalled ]
 
 
 runGC :: MonadUnliftIO m
@@ -129,10 +129,10 @@ gc :: ( Monad m
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
 gc GCOptions{..} runAppState runLogger = runGC runAppState (do
-  when gcOldGHC (liftE rmOldGHC)
+  when gcOldGHC rmOldGHC
   lift $ when gcProfilingLibs rmProfilingLibs
   lift $ when gcShareDir rmShareDir
-  liftE $ when gcHLSNoGHC rmHLSNoGHC
+  lift $ when gcHLSNoGHC rmHLSNoGHC
   lift $ when gcCache rmCache
   lift $ when gcTmp rmTmp
    ) >>= \case

app/ghcup/GHCup/OptParse/Install.hs

@@ -6,8 +6,6 @@
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE ViewPatterns      #-}
-{-# LANGUAGE TypeOperators     #-}
 
 module GHCup.OptParse.Install where
 
@@ -19,10 +17,9 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Dirs
+import           GHCup.Logger
-import           GHCup.Prelude
+import           GHCup.QQ.String
-import           GHCup.Prelude.Logger
+import           GHCup.System.Process
-import           GHCup.Prelude.String.QQ
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)
@@ -33,13 +30,14 @@ 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 )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-import           URI.ByteString          hiding ( uriParser )
+import           URI.ByteString
 
 import qualified Data.Text                     as T
 
@@ -71,7 +69,6 @@ data InstallOptions = InstallOptions
   , instSet      :: Bool
   , isolateDir   :: Maybe FilePath
   , forceInstall :: Bool
-  , addConfArgs  :: [T.Text]
   }
 
 
@@ -190,18 +187,21 @@ installOpts tool =
     <*> (   (   (,)
             <$> optional
                   (option
-                    (eitherReader uriParser)
+                    (eitherReader bindistParser)
                     (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
                       "Install the specified version from this bindist"
-                      <> completer (toolDlCompleter (fromMaybe GHC tool))
                     )
                   )
             <*> (Just <$> toolVersionArgument Nothing tool)
             )
         <|> pure (Nothing, Nothing)
         )
-    <*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault
+    <*> flag
-      (help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install"))
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
     <*> optional
           (option
            (eitherReader isolateParser)
@@ -209,18 +209,11 @@ installOpts tool =
            <> long "isolate"
            <> metavar "DIR"
            <> help "install in an isolated dir instead of the default one"
-           <> completer (bashCompleter "directory")
            )
           )
     <*> switch
-          (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
+          (short 'f' <> long "force" <> help "Force install")
-    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
+          
- where
-  setDefault = case tool of
-    Nothing  -> False
-    Just GHC -> False
-    Just _   -> True
-
 
 
 
@@ -261,9 +254,6 @@ type InstallEffects = '[ AlreadyInstalled
                        , NoToolVersionSet
                        , FileAlreadyExistsError
                        , ProcessError
-                       , UninstallFailed
-                       , MergeFileTreeError
-                       , InstallSetError
                        ]
 
 
@@ -278,39 +268,6 @@ runInstTool appstate' mInstPlatform =
     @InstallEffects
 
 
-type InstallGHCEffects = '[ AlreadyInstalled
-                          , ArchiveResult
-                          , BuildFailed
-                          , CopyError
-                          , DigestError
-                          , DirNotEmpty
-                          , DownloadFailed
-                          , FileAlreadyExistsError
-                          , FileDoesNotExistError
-                          , GPGError
-                          , MergeFileTreeError
-                          , NextVerNotFound
-                          , NoDownload
-                          , NoToolVersionSet
-                          , NotInstalled
-                          , ProcessError
-                          , TagNotFound
-                          , TarDirDoesNotExist
-                          , UninstallFailed
-                          , UnknownArchive
-                          , InstallSetError
-                          ]
-
-runInstGHC :: AppState
-           -> Maybe PlatformRequest
-           -> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
-           -> IO (VEither InstallGHCEffects a)
-runInstGHC appstate' mInstPlatform =
-  flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
-  . runResourceT
-  . runE
-    @InstallGHCEffects
-
 
     -------------------
     --[ Entrypoints ]--
@@ -331,27 +288,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
   installGHC InstallOptions{..} = do
     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
     (case instBindist of
-       Nothing -> runInstGHC s' instPlatform $ do
+       Nothing -> runInstTool s' instPlatform $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         liftE $ runBothE' (installGHCBin
+         liftE $ installGHCBin
-                     (_tvVersion v)
+                   (_tvVersion v)
-                     (maybe GHCupInternal IsolateDir isolateDir)
+                   isolateDir
-                     forceInstall
+                   forceInstall
-                     addConfArgs
+         when instSet $ void $ liftE $ setGHC v SetGHCOnly
-                   )
-                   $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
          pure vi
        Just uri -> do
-         runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
+         runInstTool s'{ settings = settings {noVerify = True}} instPlatform $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           liftE $ runBothE' (installGHCBindist
+           liftE $ installGHCBindist
-                       (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
+                     (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
-                       (_tvVersion v)
+                     (_tvVersion v)
-                       (maybe GHCupInternal IsolateDir isolateDir)
+                     isolateDir
-                       forceInstall
+                     forceInstall
-                       addConfArgs
+           when instSet $ void $ liftE $ setGHC v SetGHCOnly
-                     )
-                     $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
            pure vi
       )
         >>= \case
@@ -360,42 +313,25 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 forM_ (_viPostInstall =<< vi) $ \msg ->
                   runLogger $ logInfo msg
                 pure ExitSuccess
-
+              VLeft (V (AlreadyInstalled _ v)) -> do
-              VLeft e@(V (AlreadyInstalled _ _)) -> do
+                runLogger $ logWarn $
-                runLogger $ logWarn $ T.pack $ prettyShow e
+                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
                 pure ExitSuccess
-              VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyShow e
-                pure ExitSuccess
-
               VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logError $
+                runLogger $ logWarn $
-                  "Install directory " <> T.pack fp <> " is not empty."
+                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
-                pure $ ExitFailure 3
-              VLeft (V (DirNotEmpty fp)) -> do
-                runLogger $ logError $
-                  "Install directory " <> T.pack fp <> " is not empty."
-                pure $ ExitFailure 3
-
-              VLeft err@(V (BuildFailed tmpdir _)) -> do
-                case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
-                    "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
-                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                    "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
-
               VLeft e -> do
                 runLogger $ do
                   logError $ T.pack $ prettyShow e
-                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
+                  logError $ "Also check the logs in " <> T.pack logsDir
                 pure $ ExitFailure 3
 
 
@@ -404,22 +340,20 @@ install installCommand settings getAppState' runLogger = case installCommand of
     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
     (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
-         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
+         (v, vi) <- liftE $ fromVersion instVer Cabal
-         liftE $ runBothE' (installCabalBin
+         liftE $ installCabalBin
-                                    v
+                   (_tvVersion v)
-                                    (maybe GHCupInternal IsolateDir isolateDir)
+                   isolateDir
-                                    forceInstall
+                   forceInstall
-                                  ) $ 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
+           (v, vi) <- liftE $ fromVersion instVer Cabal
-           liftE $ runBothE' (installCabalBindist
+           liftE $ installCabalBindist 
-                                      (DownloadInfo uri Nothing "")
+                     (DownloadInfo uri Nothing "")
-                                      v
+                     (_tvVersion v)
-                                      (maybe GHCupInternal IsolateDir isolateDir)
+                     isolateDir
-                                      forceInstall
+                     forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
            pure vi
       )
       >>= \case
@@ -428,15 +362,9 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> 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."
+                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
-              pure $ ExitFailure 3
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -445,7 +373,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
+                logError $ "Also check the logs in " <> T.pack logsDir
               pure $ ExitFailure 4
 
   installHLS :: InstallOptions -> IO ExitCode
@@ -453,23 +381,20 @@ install installCommand settings getAppState' runLogger = case installCommand of
      s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
      (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
-         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
+         (v, vi) <- liftE $ fromVersion instVer HLS
-         liftE $ runBothE' (installHLSBin
+         liftE $ installHLSBin
-                                    v
+                   (_tvVersion v)
-                                    (maybe GHCupInternal IsolateDir isolateDir)
+                   isolateDir
-                                    forceInstall
+                   forceInstall
-                                  ) $ 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
+           (v, vi) <- liftE $ fromVersion instVer HLS
-           -- TODO: support legacy
+           liftE $ installHLSBindist
-           liftE $ runBothE' (installHLSBindist
+                     (DownloadInfo uri Nothing "")
-                                      (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
+                     (_tvVersion v)
-                                      v
+                     isolateDir
-                                      (maybe GHCupInternal IsolateDir isolateDir)
+                     forceInstall
-                                      forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
            pure vi
       )
       >>= \case
@@ -478,15 +403,13 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> 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."
+                  "HLS ver "
-              pure $ ExitFailure 3
+                <> prettyVer v
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
-              runLogger $ logWarn $ T.pack $ prettyShow e
+                <> prettyVer v
+                <> "'"
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -495,7 +418,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
+                logError $ "Also check the logs in " <> T.pack logsDir
               pure $ ExitFailure 4
 
   installStack :: InstallOptions -> IO ExitCode
@@ -503,22 +426,20 @@ install installCommand settings getAppState' runLogger = case installCommand of
      s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
      (case instBindist of
         Nothing -> runInstTool s' instPlatform $ do
-          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
+          (v, vi) <- liftE $ fromVersion instVer Stack
-          liftE $ runBothE' (installStackBin
+          liftE $ installStackBin
-                                     v
+                    (_tvVersion v)
-                                     (maybe GHCupInternal IsolateDir isolateDir)
+                    isolateDir
-                                     forceInstall
+                    forceInstall
-                                   ) $ 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
+            (v, vi) <- liftE $ fromVersion instVer Stack
-            liftE $ runBothE' (installStackBindist
+            liftE $ installStackBindist
-                                       (DownloadInfo uri Nothing "")
+                      (DownloadInfo uri Nothing "")
-                                       v
+                      (_tvVersion v)
-                                       (maybe GHCupInternal IsolateDir isolateDir)
+                      isolateDir
-                                       forceInstall
+                      forceInstall
-                                     ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
             pure vi
       )
       >>= \case
@@ -527,15 +448,9 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> 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."
+                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
-              pure $ ExitFailure 3
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -544,6 +459,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
             VLeft e -> do
               runLogger $ do
                 logError $ T.pack $ prettyShow e
-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
+                logError $ "Also check the logs in " <> T.pack logsDir
               pure $ ExitFailure 4
 

app/ghcup/GHCup/OptParse/List.hs

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

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.Prelude.Logger
+import           GHCup.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
     ---------------------------
 
 
-type NukeEffects = '[ NotInstalled, UninstallFailed ]
+type NukeEffects = '[ NotInstalled ]
 
 
 runNuke :: AppState

app/ghcup/GHCup/OptParse/Prefetch.hs

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

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.Prelude.Logger
+import           GHCup.Logger
-import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
     ---------------------------
 
 
-type RmEffects = '[ NotInstalled, UninstallFailed ]
+type RmEffects = '[ NotInstalled ]
 
 
 runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))

app/ghcup/GHCup/OptParse/Run.hs

@@ -1,466 +0,0 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE TypeFamilies      #-}
-module GHCup.OptParse.Run where
-
-
-import           GHCup
-import           GHCup.Utils
-import           GHCup.OptParse.Common
-import           GHCup.Errors
-import           GHCup.Types
-import           GHCup.Types.Optics
-import           GHCup.Prelude
-import           GHCup.Prelude.File
-#ifdef IS_WINDOWS
-import           GHCup.Prelude.Process
-#endif
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
-
-import           Control.Exception.Safe         ( MonadMask, MonadCatch )
-#if !MIN_VERSION_base(4,13,0)
-import           Control.Monad.Fail             ( MonadFail )
-#endif
-import           Codec.Archive
-import           Control.Monad.Reader
-import           Control.Monad.Trans.Resource
-import           Data.Functor
-import           Data.Maybe (isNothing)
-import           Data.List                      ( intercalate )
-import           Haskus.Utils.Variant.Excepts
-import           Options.Applicative     hiding ( style )
-import           Prelude                 hiding ( appendFile )
-import           System.FilePath
-import           System.Environment
-import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-
-import qualified Data.Map.Strict               as Map
-import qualified Data.Text                     as T
-#ifndef IS_WINDOWS
-import qualified System.Posix.Process          as SPP
-#endif
-
-
-
-
-
-    ---------------
-    --[ Options ]--
-    ---------------
-
-
-data RunOptions = RunOptions
-  { runAppendPATH :: Bool
-  , runInstTool'  :: Bool
-  , runGHCVer     :: Maybe ToolVersion
-  , runCabalVer   :: Maybe ToolVersion
-  , runHLSVer     :: Maybe ToolVersion
-  , runStackVer   :: Maybe ToolVersion
-  , runBinDir     :: Maybe FilePath
-  , runQuick      :: Bool
-  , runCOMMAND    :: [String]
-  }
-
-
-
-    ---------------
-    --[ Parsers ]--
-    ---------------
-
-
-
-runOpts :: Parser RunOptions
-runOpts =
-  RunOptions
-    <$> switch
-          (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")
-    <*> optional
-          (option
-            (eitherReader toolVersionEither)
-            (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
-            <> completer (tagCompleter GHC [])
-            <> (completer $ versionCompleter Nothing GHC)
-            )
-          )
-    <*> optional
-          (option
-            (eitherReader toolVersionEither)
-            (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
-            <> completer (tagCompleter Cabal [])
-            <> (completer $ versionCompleter Nothing Cabal)
-            )
-          )
-    <*> optional
-          (option
-            (eitherReader toolVersionEither)
-            (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
-            <> completer (tagCompleter HLS [])
-            <> (completer $ versionCompleter Nothing HLS)
-            )
-          )
-    <*> optional
-          (option
-            (eitherReader toolVersionEither)
-            (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
-            <> completer (tagCompleter Stack [])
-            <> (completer $ versionCompleter Nothing Stack)
-            )
-          )
-    <*> optional
-          (option
-           (eitherReader isolateParser)
-           (  short 'b'
-           <> long "bindir"
-           <> metavar "DIR"
-           <> help "directory where to create the tool symlinks (default: newly created system temp dir)"
-           <> completer (bashCompleter "directory")
-           )
-          )
-    <*> switch
-          (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
-    <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
-          
-
-
-
-    --------------
-    --[ Footer ]--
-    --------------
-
-
-runFooter :: String
-runFooter = [s|Discussion:
-  Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing
-  the relevant binaries, then executes a command.
-
-Examples:
-  # run VSCode with all latest toolchain exposed, installing missing versions if necessary
-  ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs
-
-  # create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH
-  ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin
-
-  # run a specific ghc version
-  ghcup run --ghc 8.10.7 -- ghc --version|]
-
-
-
-
-    ---------------------------
-    --[ Effect interpreters ]--
-    ---------------------------
-
-
-type RunEffects = '[ AlreadyInstalled
-                   , UnknownArchive
-                   , ArchiveResult
-                   , FileDoesNotExistError
-                   , CopyError
-                   , NotInstalled
-                   , DirNotEmpty
-                   , NoDownload
-                   , NotInstalled
-                   , BuildFailed
-                   , TagNotFound
-                   , DigestError
-                   , GPGError
-                   , DownloadFailed
-                   , TarDirDoesNotExist
-                   , NextVerNotFound
-                   , NoToolVersionSet
-                   , FileAlreadyExistsError
-                   , ProcessError
-                   , UninstallFailed
-                   , MergeFileTreeError
-                   ]
-
-runLeanRUN :: (MonadUnliftIO m, MonadIO m)
-           => LeanAppState
-           -> Excepts RunEffects (ReaderT LeanAppState m) a
-           -> m (VEither RunEffects a)
-runLeanRUN leanAppstate =
-    -- Don't use runLeanAppState here, which is disabled on windows.
-    -- This is the only command on all platforms that doesn't need full appstate.
-    flip runReaderT leanAppstate
-    . runE
-      @RunEffects
-
-runRUN :: MonadUnliftIO m
-      => IO AppState
-      -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-      -> m (VEither RunEffects a)
-runRUN appState action' = do
-  s' <- liftIO appState
-  flip runReaderT s'
-    . runResourceT
-    . runE
-      @RunEffects
-    $ action'
-
-
-
-    ------------------
-    --[ Entrypoint ]--
-    ------------------
-
-
-
-run :: forall m. 
-       ( MonadFail m
-       , MonadMask m
-       , MonadCatch m
-       , MonadIO m
-       , MonadUnliftIO m
-       )
-   => RunOptions
-   -> IO AppState
-   -> LeanAppState
-   -> (ReaderT LeanAppState m () -> m ())
-   -> m ExitCode
-run RunOptions{..} runAppState leanAppstate runLogger = do
-   r <- if not runQuick
-        then runRUN runAppState $ do
-         toolchain <- liftE resolveToolchainFull
-         tmp <- liftIO $ createTmpDir toolchain
-         liftE $ installToolChainFull toolchain tmp
-         pure tmp
-        else runLeanRUN leanAppstate $ do
-         toolchain <- resolveToolchain
-         tmp <- liftIO $ createTmpDir toolchain
-         liftE $ installToolChain toolchain tmp
-         pure tmp
-   case r of
-         VRight tmp -> do
-           case runCOMMAND of
-             [] -> do
-               liftIO $ putStr tmp
-               pure ExitSuccess
-             (cmd:args) -> do
-               newEnv <- liftIO $ addToPath tmp
-#ifndef IS_WINDOWS
-               void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
-               pure ExitSuccess
-#else
-               r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
-               case r' of
-                 VRight _ -> pure ExitSuccess
-                 VLeft e -> do
-                   runLogger $ logError $ T.pack $ prettyShow e
-                   pure $ ExitFailure 28
-#endif
-         VLeft e -> do
-           runLogger $ logError $ T.pack $ prettyShow e
-           pure $ ExitFailure 27
-
-  where
-
-   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
-                           , MonadThrow m
-                           , MonadIO m
-                           , MonadCatch m
-                           )
-                        => Excepts
-                             '[ TagNotFound
-                              , NextVerNotFound
-                              , NoToolVersionSet
-                              ] (ResourceT (ReaderT AppState m)) Toolchain
-   resolveToolchainFull = do
-         ghcVer <- forM runGHCVer $ \ver -> do
-           (v, _) <- liftE $ fromVersion (Just ver) GHC
-           pure v
-         cabalVer <- forM runCabalVer $ \ver -> do
-           (v, _) <- liftE $ fromVersion (Just ver) Cabal
-           pure v
-         hlsVer <- forM runHLSVer $ \ver -> do
-           (v, _) <- liftE $ fromVersion (Just ver) HLS
-           pure v
-         stackVer <- forM runStackVer $ \ver -> do
-           (v, _) <- liftE $ fromVersion (Just ver) Stack
-           pure v
-         pure Toolchain{..}
-
-   resolveToolchain = do
-         ghcVer <- case runGHCVer of
-            Just (ToolVersion v) -> pure $ Just v
-            Nothing -> pure Nothing
-            _ -> fail "Internal error"
-         cabalVer <- case runCabalVer of
-            Just (ToolVersion v) -> pure $ Just v
-            Nothing -> pure Nothing
-            _ -> fail "Internal error"
-         hlsVer <- case runHLSVer of
-            Just (ToolVersion v) -> pure $ Just v
-            Nothing -> pure Nothing
-            _ -> fail "Internal error"
-         stackVer <- case runStackVer of
-            Just (ToolVersion v) -> pure $ Just v
-            Nothing -> pure Nothing
-            _ -> fail "Internal error"
-         pure Toolchain{..}
-
-   installToolChainFull :: ( MonadFail m
-                           , MonadThrow m
-                           , MonadIO m
-                           , MonadCatch m
-                           )
-                        => Toolchain
-                        -> FilePath
-                        -> Excepts
-                             '[ TagNotFound
-                              , NextVerNotFound
-                              , NoToolVersionSet
-                              , UnknownArchive
-                              , TarDirDoesNotExist
-                              , ProcessError
-                              , NotInstalled
-                              , NoDownload
-                              , GPGError
-                              , DownloadFailed
-                              , DirNotEmpty
-                              , DigestError
-                              , BuildFailed
-                              , ArchiveResult
-                              , AlreadyInstalled
-                              , FileAlreadyExistsError
-                              , CopyError
-                              , UninstallFailed
-                              , MergeFileTreeError
-                              ] (ResourceT (ReaderT AppState m)) ()
-   installToolChainFull Toolchain{..} tmp = do
-         forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
-           isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
-           case mt of
-             Just (GHC, v) -> do
-               unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
-                 (_tvVersion v)
-                 GHCupInternal
-                 False
-                 []
-               setTool GHC v tmp
-             Just (Cabal, v) -> do
-               unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
-                 (_tvVersion v)
-                 GHCupInternal
-                 False
-               setTool Cabal v tmp
-             Just (Stack, v) -> do
-               unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
-                 (_tvVersion v)
-                 GHCupInternal
-                 False
-               setTool Stack v tmp
-             Just (HLS, v) -> do
-               unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
-                 (_tvVersion v)
-                 GHCupInternal
-                 False
-               setTool HLS v tmp
-             _ -> pure ()
-
-   installToolChain :: ( MonadFail m
-                       , MonadThrow m
-                       , MonadIO m
-                       , MonadCatch m
-                       )
-                    => Toolchain
-                    -> FilePath
-                    -> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
-   installToolChain Toolchain{..} tmp = do
-         forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
-           case mt of
-             Just (GHC, v)   -> setTool GHC v tmp
-             Just (Cabal, v) -> setTool Cabal v tmp
-             Just (Stack, v) -> setTool Stack v tmp
-             Just (HLS, v)   -> setTool HLS v tmp
-             _ -> pure ()
-
-   setTool tool v tmp =
-      case tool of
-        GHC -> do
-          void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
-          void $ liftE $ setGHC v SetGHCOnly (Just tmp)
-        Cabal -> do
-          bin  <- liftE $ whereIsTool Cabal v
-          cbin <- liftIO $ canonicalizePath bin
-          lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
-        Stack -> do
-          bin  <- liftE $ whereIsTool Stack v
-          cbin <- liftIO $ canonicalizePath bin
-          lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
-        HLS -> do
-          Dirs {..}  <- getDirs
-          let v' = _tvVersion v
-          legacy <- isLegacyHLS v'
-          if legacy
-          then do
-            -- TODO: factor this out
-            hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))
-            cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
-            lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
-            hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
-            forM_ hlsBins $ \bin ->
-              lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
-            liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
-          else do
-            liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)
-            liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
-        GHCup -> pure ()
-       
-   addToPath path = do
-    cEnv <- Map.fromList <$> getEnvironment
-    let paths          = ["PATH", "Path"]
-        curPaths       = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
-        newPath        = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths))
-        envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
-        pathVar        = if isWindows then "Path" else "PATH"
-        envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
-    liftIO $ setEnv pathVar newPath
-    return envWithNewPath
-
-   predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =
-     liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))
-   predictableTmpDir Toolchain{..} = do
-      tmp <- getTemporaryDirectory
-      pure $ tmp
-        </> ("ghcup-" <> intercalate "_"
-              (  maybe [] ( (:[]) . ("ghc-"   <>) . T.unpack . tVerToText) ghcVer
-              <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer
-              <> maybe [] ( (:[]) . ("hls-"   <>) . T.unpack . tVerToText) hlsVer
-              <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer
-              )
-            )
-
-
-
-    -------------------------
-    --[ Other local types ]--
-    -------------------------
-
-
-
-data Toolchain = Toolchain
-  { ghcVer     :: Maybe GHCTargetVersion
-  , cabalVer   :: Maybe GHCTargetVersion
-  , hlsVer     :: Maybe GHCTargetVersion
-  , stackVer   :: Maybe GHCTargetVersion
-  }

app/ghcup/GHCup/OptParse/Set.hs

@@ -17,8 +17,8 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.Logger
+import           GHCup.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -271,10 +271,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
           -> m ExitCode
   setGHC' SetOptions{ sToolVer } =
     case sToolVer of
-      (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
+      (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)
       _ -> runSetGHC runAppState (do
           v <- liftE $ fst <$> fromVersion' sToolVer GHC
-          liftE $ setGHC v SetGHCOnly Nothing
+          liftE $ setGHC v SetGHCOnly
         )
       >>= \case
             VRight GHCTargetVersion{..} -> do
@@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
           -> m ExitCode
   setHLS' SetOptions{ sToolVer } =
     case sToolVer of
-      (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)
+      (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)
       _ -> runSetHLS runAppState (do
           v <- liftE $ fst <$> fromVersion' sToolVer HLS
-          liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
+          liftE $ setHLS (_tvVersion v)
           pure v
         )
       >>= \case

app/ghcup/GHCup/OptParse/ToolRequirements.hs

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

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.Prelude.Logger
+import           GHCup.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -14,8 +14,7 @@ module GHCup.OptParse.Upgrade where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.File
+import           GHCup.Logger
-import           GHCup.Prelude.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -60,21 +59,19 @@ data UpgradeOpts = UpgradeInplace
     --[ Parsers ]--
     ---------------
 
-
+          
 upgradeOptsP :: Parser UpgradeOpts
 upgradeOptsP =
   flag'
       UpgradeInplace
       (short 'i' <> long "inplace" <> help
-        "Upgrade ghcup in-place"
+        "Upgrade ghcup in-place (wherever it's at)"
       )
-    <|>
+    <|> (   UpgradeAt
-      (   UpgradeAt
         <$> option
               str
               (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
                 "Absolute filepath to write ghcup into"
-                <> completer (bashCompleter "file")
               )
         )
     <|> pure UpgradeGHCupDir
@@ -94,7 +91,6 @@ type UpgradeEffects = '[ DigestError
                        , FileDoesNotExistError
                        , CopyError
                        , DownloadFailed
-                       , ToolShadowed
                        ]
 
 
@@ -117,25 +113,24 @@ runUpgrade runAppState =
 
 
 upgrade :: ( Monad m
-           , MonadMask m
+         , MonadMask m
-           , MonadUnliftIO m
+         , MonadUnliftIO m
-           , MonadFail m
+         , MonadFail 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' fatal Dirs{..} runAppState runLogger = do
+upgrade uOpts force' runAppState runLogger = do
+  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
   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' fatal
+    v' <- liftE $ upgradeGHCup target force'
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
     pure (v', dls)
     ) >>= \case

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -17,9 +17,8 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Types
-import           GHCup.Utils
+import           GHCup.Logger
-import           GHCup.Prelude.Logger
+import           GHCup.QQ.String
-import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -300,7 +299,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 pure $ ExitFailure 30
 
     (WhereisBaseDir, _) -> do
-      liftIO $ putStr $ fromGHCupPath baseDir
+      liftIO $ putStr baseDir
       pure ExitSuccess
 
     (WhereisBinDir, _) -> do
@@ -308,13 +307,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
       pure ExitSuccess
 
     (WhereisCacheDir, _) -> do
-      liftIO $ putStr $ fromGHCupPath cacheDir
+      liftIO $ putStr cacheDir
       pure ExitSuccess
 
     (WhereisLogsDir, _) -> do
-      liftIO $ putStr $ fromGHCupPath logsDir
+      liftIO $ putStr logsDir
       pure ExitSuccess
 
     (WhereisConfDir, _) -> do
-      liftIO $ putStr $ fromGHCupPath confDir
+      liftIO $ putStr confDir
       pure ExitSuccess

app/ghcup/Main.hs

@@ -20,11 +20,10 @@ import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Platform
 import           GHCup.Types
-import           GHCup.Types.Optics      hiding ( toolRequirements )
 import           GHCup.Utils
+import           GHCup.Logger
 import           GHCup.Prelude
-import           GHCup.Prelude.Logger
+import           GHCup.QQ.String
-import           GHCup.Prelude.String.QQ
 import           GHCup.Version
 
 import           Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -40,7 +39,6 @@ import           Data.Aeson.Encode.Pretty       ( encodePretty )
 import           Data.Either
 import           Data.Functor
 import           Data.Maybe
-import           Data.Versions
 import           GHC.IO.Encoding
 import           Haskus.Utils.Variant.Excepts
 import           Language.Haskell.TH
@@ -82,7 +80,7 @@ toSettings options = do
          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
+         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
      in (Settings {..}, keyBindings)
@@ -140,10 +138,7 @@ main = do
         <> hidden
         )
   let listCommands = infoOption
-        ("install set rm install-cabal list"
+        "install set rm install-cabal list upgrade compile debug-info tool-requirements changelog"
-          <> " upgrade"
-          <> " compile debug-info tool-requirements changelog"
-        )
         (  long "list-commands"
         <> help "List available commands for shell completion"
         <> internal
@@ -155,6 +150,7 @@ 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
 
@@ -195,7 +191,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           -------------------------
 
 
-          let appState = do
+              appState = do
                 pfreq <- (
                   runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
                   ) >>= \case
@@ -219,42 +215,20 @@ 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 (fromGHCupPath recycleDir) <> " manually"))
+                      (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
 
                 case optCommand of
                   Nuke -> pure ()
                   Whereis _ _ -> pure ()
                   DInfo -> pure ()
-                  ToolRequirements _ -> pure ()
+                  ToolRequirements -> pure ()
                   ChangeLog _ -> pure ()
                   UnSet _ -> pure ()
 #if defined(BRICK)
                   Interactive -> pure ()
 #endif
-                  -- check for new tools
+                  _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                  _
+                         Nothing -> runReaderT checkForUpdates s'
-                    | Just False <- optVerbose -> pure ()
-                    | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                         Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
-                           newTools <- lift checkForUpdates 
-                           forM_ newTools $ \newTool@(t, l) -> do
-                             -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
-                             alreadyInstalling' <- alreadyInstalling optCommand newTool
-                             when (not alreadyInstalling') $
-                               case t of
-                                 GHCup -> runLogger $
-                                            logWarn ("New GHCup version available: "
-                                              <> prettyVer l
-                                              <> ". To upgrade, run 'ghcup upgrade'")
-                                 _ -> runLogger $
-                                        logWarn ("New "
-                                          <> T.pack (prettyShow t)
-                                          <> " version available. "
-                                          <> "To upgrade, run 'ghcup install "
-                                          <> T.pack (prettyShow t)
-                                          <> " "
-                                          <> prettyVer l
-                                          <> "'")
                          Just _ -> pure ()
 
                 -- TODO: always run for windows
@@ -289,24 +263,23 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
               s' <- appState
               liftIO $ brickMain s' >> pure ExitSuccess
 #endif
-            Install installCommand     -> install installCommand settings appState runLogger
+            Install installCommand   -> install installCommand settings appState runLogger
-            InstallCabalLegacy iopts   -> install (Left (InstallCabal iopts)) settings appState runLogger
+            InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
-            Set setCommand             -> set setCommand runAppState runLeanAppState runLogger
+            Set setCommand           -> set setCommand runAppState runLeanAppState runLogger
-            UnSet unsetCommand         -> unset unsetCommand runLeanAppState runLogger
+            UnSet unsetCommand       -> unset unsetCommand runLeanAppState runLogger
-            List lo                    -> list lo no_color runAppState
+            List lo                  -> list lo no_color runAppState
-            Rm rmCommand               -> rm rmCommand runAppState runLogger
+            Rm rmCommand             -> rm rmCommand runAppState runLogger
-            DInfo                      -> dinfo runAppState runLogger
+            DInfo                    -> dinfo runAppState runLogger
-            Compile compileCommand     -> compile compileCommand settings dirs runAppState runLogger
+            Compile compileCommand   -> compile compileCommand settings runAppState runLogger
-            Config configCommand       -> config configCommand settings keybindings runLogger
+            Config configCommand     -> config configCommand settings keybindings runLogger
             Whereis whereisOptions
-                    whereisCommand     -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
+                    whereisCommand   -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
-            Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
+            Upgrade uOpts force'     -> upgrade uOpts force' runAppState runLogger
-            ToolRequirements topts     -> toolRequirements topts runAppState runLogger
+            ToolRequirements         -> toolRequirements runAppState runLogger
-            ChangeLog changelogOpts    -> changelog changelogOpts runAppState runLogger
+            ChangeLog changelogOpts  -> changelog changelogOpts runAppState runLogger
-            Nuke                       -> nuke appState runLogger
+            Nuke                     -> nuke appState runLogger
-            Prefetch pfCom             -> prefetch pfCom runAppState runLogger
+            Prefetch pfCom           -> prefetch pfCom runAppState runLogger
-            GC gcOpts                  -> gc gcOpts runAppState runLogger
+            GC gcOpts                -> gc gcOpts runAppState runLogger
-            Run runCommand             -> run runCommand appState leanAppstate runLogger
 
           case res of
             ExitSuccess        -> pure ()
@@ -314,56 +287,4 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
   pure ()
 
- where
-  alreadyInstalling :: ( HasLog env
-                       , MonadFail m
-                       , MonadReader env m
-                       , HasGHCupInfo env
-                       , HasDirs env
-                       , MonadThrow m
-                       , MonadIO m
-                       , MonadCatch m
-                       )
-                    => Command
-                    -> (Tool, Version)
-                    -> Excepts
-                         '[ TagNotFound
-                          , NextVerNotFound
-                          , NoToolVersionSet
-                          ] m Bool
-  alreadyInstalling (Install (Right InstallOptions{..}))                 (GHC, ver)   = cmp' GHC instVer ver
-  alreadyInstalling (Install (Left (InstallGHC InstallOptions{..})))     (GHC, ver)   = cmp' GHC instVer ver
-  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver) = cmp' Cabal instVer ver
-  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)   = cmp' HLS instVer ver
-  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver) = cmp' Stack instVer ver
-  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
-    (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 }))
-    (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
-  alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
-  alreadyInstalling _ _ = pure False
 
-  cmp' :: ( HasLog env
-          , MonadFail m
-          , MonadReader env m
-          , HasGHCupInfo env
-          , HasDirs env
-          , MonadThrow m
-          , MonadIO m
-          , MonadCatch m
-          )
-       => Tool
-       -> Maybe ToolVersion
-       -> Version
-       -> Excepts
-            '[ TagNotFound
-             , NextVerNotFound
-             , NoToolVersionSet
-             ] m Bool
-  cmp' tool instVer ver = do
-    (v, _) <- liftE $ fromVersion instVer tool
-    pure (v == mkTVer ver)

cabal.ghc8107.project

@@ -8,14 +8,9 @@ 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,
+             any.aeson >= 2.0.1.0
 
 package libarchive
   flags: -system-libarchive
@@ -29,9 +24,6 @@ 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

@@ -4,18 +4,18 @@ constraints: any.Cabal ==3.6.2.0,
              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,
+             any.aeson ==2.0.1.0,
-             aeson -cffi +ordered-keymap,
+             aeson -bytestring-builder -cffi +ordered-keymap,
              any.aeson-pretty ==0.8.9,
              aeson-pretty +lib-only,
-             any.alex ==3.2.7.1,
+             any.alex ==3.2.6,
-             any.ansi-terminal ==0.11.3,
+             alex +small_base,
+             any.ansi-terminal ==0.11,
              ansi-terminal -example,
              any.ansi-wl-pprint ==0.6.9,
              ansi-wl-pprint -example,
@@ -25,15 +25,15 @@ constraints: any.Cabal ==3.6.2.0,
              async -bench,
              any.atomic-primops ==0.8.4,
              atomic-primops -debug,
-             any.attoparsec ==0.14.4,
+             any.attoparsec ==0.13.2.5,
              attoparsec -developer,
              any.base ==4.14.3.0,
-             any.base-compat ==0.12.1,
+             any.base-compat ==0.12.0,
-             any.base-compat-batteries ==0.12.1,
+             any.base-compat-batteries ==0.12.0,
-             any.base-orphans ==0.8.6,
+             any.base-orphans ==0.8.5,
-             any.base16-bytestring ==1.0.2.0,
+             any.base16-bytestring ==1.0.1.0,
-             any.base64-bytestring ==1.2.1.0,
+             any.base64-bytestring ==1.1.0.0,
-             any.bifunctors ==5.5.12,
+             any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.8.0,
              any.blaze-builder ==0.4.2.2,
@@ -52,7 +52,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.chs-cabal ==0.1.1.1,
              any.chs-deps ==0.1.0.0,
              chs-deps -cross,
-             any.clock ==0.8.3,
+             any.clock ==0.8.2,
              clock -llvm,
              any.colour ==2.3.6,
              any.comonad ==5.0.8,
@@ -66,10 +66,10 @@ constraints: any.Cabal ==3.6.2.0,
              contravariant +semigroups +statevar +tagged,
              any.cpphs ==1.20.9.1,
              cpphs -old-locale,
-             any.cryptohash-sha1 ==0.11.101.0,
+             any.cryptohash-sha1 ==0.11.100.1,
              any.cryptohash-sha256 ==0.11.102.1,
              cryptohash-sha256 -exe +use-cbits,
-             any.data-clist ==0.2,
+             any.data-clist ==0.1.2.3,
              any.data-fix ==0.3.2,
              any.deepseq ==1.4.4.0,
              any.directory ==1.3.6.0,
@@ -80,65 +80,61 @@ constraints: any.Cabal ==3.6.2.0,
              dlist -werror,
              any.exceptions ==0.10.4,
              any.filepath ==1.4.2.1,
-             any.free ==5.1.8,
+             any.free ==5.1.7,
              any.fusion-plugin-types ==0.1.0,
-             any.generic-arbitrary ==0.2.2,
+             any.generic-arbitrary ==0.1.0,
-             any.ghc ==8.10.7,
-             any.ghc-boot ==8.10.7,
              any.ghc-boot-th ==8.10.7,
              any.ghc-byteorder ==4.11.0.0.10,
-             any.ghc-heap ==8.10.7,
              any.ghc-prim ==0.6.1,
-             any.ghci ==8.10.7,
              any.happy ==1.20.0,
-             any.hashable ==1.4.0.2,
+             any.hashable ==1.3.4.1,
-             hashable +containers +integer-gmp -random-initial-seed,
+             hashable +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.haskus-utils-variant ==3.1,
              any.heaps ==0.4,
-             any.hpc ==0.6.1.0,
+             any.hsc2hs ==0.68.7,
-             any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.9.7,
+             any.hspec ==2.7.10,
-             any.hspec-core ==2.9.7,
+             any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.9.7,
+             any.hspec-discover ==2.7.10,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
-             any.http-io-streams ==0.1.6.1,
+             any.http-io-streams ==0.1.6.0,
              http-io-streams -brotli +fast-xor,
              any.indexed-profunctors ==0.1.1,
-             any.indexed-traversable ==0.1.2,
+             any.indexed-traversable ==0.1.1,
-             any.indexed-traversable-instances ==0.1.1,
+             any.indexed-traversable-instances ==0.1,
              any.integer-gmp ==1.0.3.0,
              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,
+             any.language-c ==0.9.0.1,
              language-c -allwarnings +iecfpextension +usebytestrings,
-             any.libarchive ==3.0.3.2,
+             any.libarchive ==3.0.3.1,
-             libarchive -cross -low-memory +no-exe -system-libarchive,
+             libarchive -cross -low-memory -system-libarchive,
-             any.libyaml-streamly ==0.2.1,
+             any.libyaml-streamly ==0.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.1,
+             any.megaparsec ==9.0.1,
              megaparsec -dev,
              any.microlens ==0.4.12.0,
-             any.microlens-mtl ==0.2.0.2,
+             any.microlens-mtl ==0.2.0.1,
              any.microlens-th ==0.4.3.10,
+             any.monad-control ==1.0.3.1,
              any.mtl ==2.2.2,
-             any.network ==3.1.2.7,
+             any.network ==3.1.2.5,
              network -devel,
              any.network-uri ==2.6.4.1,
              any.openssl-streams ==1.2.3.0,
-             any.optics ==0.4.2,
+             any.optics ==0.4,
-             any.optics-core ==0.4.1,
+             any.optics-core ==0.4,
              optics-core -explicit-generic-labels,
-             any.optics-extra ==0.4.2.1,
+             any.optics-extra ==0.4,
-             any.optics-th ==0.4.1,
+             any.optics-th ==0.4,
-             any.optparse-applicative ==0.17.0.0,
+             any.optparse-applicative ==0.16.1.0,
              optparse-applicative +process,
              any.os-release ==1.0.2.1,
              os-release -devel,
@@ -149,56 +145,53 @@ 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.4.0,
+             any.primitive ==0.7.2.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.1,
+             any.random ==1.2.1,
-             any.recursion-schemes ==5.2.2.2,
+             any.recursion-schemes ==5.2.2.1,
              recursion-schemes +template-haskell,
-             any.regex-base ==0.94.0.2,
+             any.regex-base ==0.94.0.1,
              any.regex-posix ==0.96.0.1,
              regex-posix -_regex-posix-clib,
-             any.resourcet ==1.2.5,
+             any.resourcet ==1.2.4.3,
              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.3,
+             any.safe-exceptions ==0.1.7.2,
              any.scientific ==0.3.7.0,
              scientific -bytestring-builder -integer-simple,
-             any.semialign ==1.2.0.1,
+             any.semialign ==1.2,
              semialign +semigroupoids,
-             any.semigroupoids ==5.3.7,
+             any.semigroupoids ==5.3.6,
              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,
+             any.splitmix ==0.1.0.3,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.1,
-             any.streamly ==0.8.2,
+             any.streamly ==0.8.0,
-             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 -no-fusion +opt -streamk -use-c-malloc,
              any.strict ==0.4.0.1,
              strict +assoc,
              any.strict-base ==0.4.0.0,
              any.tagged ==0.8.6.1,
              tagged +deepseq +transformers,
-             any.tagsoup ==0.14.8,
              any.template-haskell ==2.16.0.0,
              any.temporary ==1.3,
              any.terminal-progress-bar ==0.4.1,
              any.terminal-size ==0.3.2.1,
              any.terminfo ==0.4.1.4,
              any.text ==1.2.4.1,
-             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.th-lift-instances ==0.1.18,
              any.these ==1.1.1.1,
              these +assoc,
              any.time ==1.9.3,
@@ -207,16 +200,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.6,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.7.1,
+             any.transformers-compat ==0.7,
              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-bytestring ==0.3.7.5,
-             any.unix-compat ==0.6,
+             any.unix-compat ==0.5.3,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.19.1,
+             any.unordered-containers ==0.2.14.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -224,15 +215,15 @@ constraints: any.Cabal ==3.6.2.0,
              any.uuid-types ==1.0.5,
              any.vector ==0.12.3.1,
              vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.3,
+             any.versions ==5.0.0,
              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.xor ==0.0.1.0,
-             any.yaml-streamly ==0.12.1,
+             any.yaml-streamly ==0.12.0,
              yaml-streamly +no-examples +no-exe,
-             any.zlib ==0.6.3.0,
+             any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2022-06-04T19:47:01Z
+index-state: hackage.haskell.org 2021-10-24T10:21:56Z

cabal.ghc901.project

@@ -8,14 +8,9 @@ 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,
+             any.aeson >= 2.0.1.0
 
 package libarchive
   flags: -system-libarchive
@@ -29,9 +24,6 @@ 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
+with-compiler: ghc-9.0.1

cabal.ghc901.project.freeze

@@ -4,18 +4,18 @@ constraints: any.Cabal ==3.6.2.0,
              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,
+             any.aeson ==2.0.1.0,
-             aeson -cffi +ordered-keymap,
+             aeson -bytestring-builder -cffi +ordered-keymap,
              any.aeson-pretty ==0.8.9,
              aeson-pretty +lib-only,
-             any.alex ==3.2.7.1,
+             any.alex ==3.2.6,
-             any.ansi-terminal ==0.11.3,
+             alex +small_base,
+             any.ansi-terminal ==0.11,
              ansi-terminal -example,
              any.ansi-wl-pprint ==0.6.9,
              ansi-wl-pprint -example,
@@ -25,15 +25,15 @@ constraints: any.Cabal ==3.6.2.0,
              async -bench,
              any.atomic-primops ==0.8.4,
              atomic-primops -debug,
-             any.attoparsec ==0.14.4,
+             any.attoparsec ==0.13.2.5,
              attoparsec -developer,
-             any.base ==4.15.1.0,
+             any.base ==4.15.0.0,
-             any.base-compat ==0.12.1,
+             any.base-compat ==0.12.0,
-             any.base-compat-batteries ==0.12.1,
+             any.base-compat-batteries ==0.12.0,
-             any.base-orphans ==0.8.6,
+             any.base-orphans ==0.8.5,
-             any.base16-bytestring ==1.0.2.0,
+             any.base16-bytestring ==1.0.1.0,
-             any.base64-bytestring ==1.2.1.0,
+             any.base64-bytestring ==1.1.0.0,
-             any.bifunctors ==5.5.12,
+             any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.8.0,
              any.blaze-builder ==0.4.2.2,
@@ -52,7 +52,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.chs-cabal ==0.1.1.1,
              any.chs-deps ==0.1.0.0,
              chs-deps -cross,
-             any.clock ==0.8.3,
+             any.clock ==0.8.2,
              clock -llvm,
              any.colour ==2.3.6,
              any.comonad ==5.0.8,
@@ -66,13 +66,13 @@ constraints: any.Cabal ==3.6.2.0,
              contravariant +semigroups +statevar +tagged,
              any.cpphs ==1.20.9.1,
              cpphs -old-locale,
-             any.cryptohash-sha1 ==0.11.101.0,
+             any.cryptohash-sha1 ==0.11.100.1,
              any.cryptohash-sha256 ==0.11.102.1,
              cryptohash-sha256 -exe +use-cbits,
-             any.data-clist ==0.2,
+             any.data-clist ==0.1.2.3,
              any.data-fix ==0.3.2,
              any.deepseq ==1.4.5.0,
-             any.directory ==1.3.6.2,
+             any.directory ==1.3.6.1,
              any.disk-free-space ==0.1.0.1,
              any.distributive ==0.6.2.1,
              distributive +semigroups +tagged,
@@ -80,65 +80,61 @@ constraints: any.Cabal ==3.6.2.0,
              dlist -werror,
              any.exceptions ==0.10.4,
              any.filepath ==1.4.2.1,
-             any.free ==5.1.8,
+             any.free ==5.1.7,
              any.fusion-plugin-types ==0.1.0,
-             any.generic-arbitrary ==0.2.2,
+             any.generic-arbitrary ==0.1.0,
-             any.ghc ==9.0.2,
+             any.ghc-bignum ==1.0,
-             any.ghc-bignum ==1.1,
+             any.ghc-boot-th ==9.0.1,
-             any.ghc-boot ==9.0.2,
-             any.ghc-boot-th ==9.0.2,
              any.ghc-byteorder ==4.11.0.0.10,
-             any.ghc-heap ==9.0.2,
              any.ghc-prim ==0.7.0,
-             any.ghci ==9.0.2,
              any.happy ==1.20.0,
-             any.hashable ==1.4.0.2,
+             any.hashable ==1.3.4.1,
-             hashable +containers +integer-gmp -random-initial-seed,
+             hashable +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.haskus-utils-variant ==3.1,
              any.heaps ==0.4,
-             any.hpc ==0.6.1.0,
+             any.hsc2hs ==0.68.7,
-             any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.9.7,
+             any.hspec ==2.7.10,
-             any.hspec-core ==2.9.7,
+             any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.9.7,
+             any.hspec-discover ==2.7.10,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
-             any.http-io-streams ==0.1.6.1,
+             any.http-io-streams ==0.1.6.0,
              http-io-streams -brotli +fast-xor,
              any.indexed-profunctors ==0.1.1,
-             any.indexed-traversable ==0.1.2,
+             any.indexed-traversable ==0.1.1,
-             any.indexed-traversable-instances ==0.1.1,
+             any.indexed-traversable-instances ==0.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,
+             any.language-c ==0.9.0.1,
              language-c -allwarnings +iecfpextension +usebytestrings,
-             any.libarchive ==3.0.3.2,
+             any.libarchive ==3.0.3.1,
-             libarchive -cross -low-memory +no-exe -system-libarchive,
+             libarchive -cross -low-memory -system-libarchive,
-             any.libyaml-streamly ==0.2.1,
+             any.libyaml-streamly ==0.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.1,
+             any.megaparsec ==9.0.1,
              megaparsec -dev,
              any.microlens ==0.4.12.0,
-             any.microlens-mtl ==0.2.0.2,
+             any.microlens-mtl ==0.2.0.1,
              any.microlens-th ==0.4.3.10,
+             any.monad-control ==1.0.3.1,
              any.mtl ==2.2.2,
-             any.network ==3.1.2.7,
+             any.network ==3.1.2.5,
              network -devel,
              any.network-uri ==2.6.4.1,
              any.openssl-streams ==1.2.3.0,
-             any.optics ==0.4.2,
+             any.optics ==0.4,
-             any.optics-core ==0.4.1,
+             any.optics-core ==0.4,
              optics-core -explicit-generic-labels,
-             any.optics-extra ==0.4.2.1,
+             any.optics-extra ==0.4,
-             any.optics-th ==0.4.1,
+             any.optics-th ==0.4,
-             any.optparse-applicative ==0.17.0.0,
+             any.optparse-applicative ==0.16.1.0,
              optparse-applicative +process,
              any.os-release ==1.0.2.1,
              os-release -devel,
@@ -149,56 +145,53 @@ 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.4.0,
+             any.primitive ==0.7.2.0,
-             any.process ==1.6.13.2,
+             any.process ==1.6.11.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.random ==1.2.1,
-             any.recursion-schemes ==5.2.2.2,
+             any.recursion-schemes ==5.2.2.1,
              recursion-schemes +template-haskell,
-             any.regex-base ==0.94.0.2,
+             any.regex-base ==0.94.0.1,
              any.regex-posix ==0.96.0.1,
              regex-posix -_regex-posix-clib,
-             any.resourcet ==1.2.5,
+             any.resourcet ==1.2.4.3,
              any.retry ==0.8.1.2,
              retry -lib-werror,
-             any.rts ==1.0.2,
+             any.rts ==1.0,
              any.safe ==0.3.19,
-             any.safe-exceptions ==0.1.7.3,
+             any.safe-exceptions ==0.1.7.2,
              any.scientific ==0.3.7.0,
              scientific -bytestring-builder -integer-simple,
-             any.semialign ==1.2.0.1,
+             any.semialign ==1.2,
              semialign +semigroupoids,
-             any.semigroupoids ==5.3.7,
+             any.semigroupoids ==5.3.6,
              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,
+             any.splitmix ==0.1.0.3,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.0,
-             any.streamly ==0.8.2,
+             any.streamly ==0.8.0,
-             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 -no-fusion +opt -streamk -use-c-malloc,
              any.strict ==0.4.0.1,
              strict +assoc,
              any.strict-base ==0.4.0.0,
              any.tagged ==0.8.6.1,
              tagged +deepseq +transformers,
-             any.tagsoup ==0.14.8,
              any.template-haskell ==2.17.0.0,
              any.temporary ==1.3,
              any.terminal-progress-bar ==0.4.1,
              any.terminal-size ==0.3.2.1,
-             any.terminfo ==0.4.1.5,
+             any.terminfo ==0.4.1.4,
-             any.text ==1.2.5.0,
+             any.text ==1.2.4.1,
-             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.th-lift-instances ==0.1.18,
              any.these ==1.1.1.1,
              these +assoc,
              any.time ==1.9.3,
@@ -207,16 +200,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.6,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.7.1,
+             any.transformers-compat ==0.7,
              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-bytestring ==0.3.7.5,
-             any.unix-compat ==0.6,
+             any.unix-compat ==0.5.3,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.19.1,
+             any.unordered-containers ==0.2.14.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -224,15 +215,15 @@ constraints: any.Cabal ==3.6.2.0,
              any.uuid-types ==1.0.5,
              any.vector ==0.12.3.1,
              vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.3,
+             any.versions ==5.0.0,
              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.xor ==0.0.1.0,
-             any.yaml-streamly ==0.12.1,
+             any.yaml-streamly ==0.12.0,
              yaml-streamly +no-examples +no-exe,
-             any.zlib ==0.6.3.0,
+             any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2022-06-04T19:47:01Z
+index-state: hackage.haskell.org 2021-10-24T10:21:56Z

cabal.ghc923.project

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

cabal.ghc923.project.freeze

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

cabal.project

@@ -8,14 +8,14 @@ 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,
+             any.aeson >= 2.0.1.0
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/optparse-applicative
+  tag: 7497a29cb998721a9068d5725d49461f2bba0e7a
 
 package libarchive
   flags: -system-libarchive
@@ -29,7 +29,4 @@ 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

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

cbits/dirutils.h

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

data/config.yaml

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

docs/css/extra.css

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

docs/dev.md

@@ -12,7 +12,8 @@ organised tree-ish in `GHCup.Utils` and `GHCup.Utils.*`.
 Anything dealing with ghcup specific directories is in
 `GHCup.Utils.Dirs`.
 
-Download information on where to fetch bindists from is in the [ghcup-metadata](https://github.com/haskell/ghcup-metadata) repository.
+Download information on where to fetch bindists from is in the appropriate
+yaml files: `data/metadata/ghcup-<yaml-ver>.yaml`.
 
 ## Design decisions
 
@@ -88,33 +89,25 @@ Every subcommand now lives in its own module under [GHCup.OptParse.MyCommand](ht
 
 # Releasing
 
-1. Update version in `ghcup.cabal`
+1. Update version in `ghcup.cabal` and `boostrap-haskell` (`ghver` variable at the top of the script)
 
 2. Update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `GHCupInfo` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version, read from `ghcup.cabal`.
 
 3. Add ChangeLog entry
 
-4. If a new ghcup yaml version is needed, create one at [ghcup-metadata repo](https://github.com/haskell/ghcup-metadata) and push to a temporary release branch, then update the `data/metadata` submodule in ghcup-hs repo to that branch, so CI can pass
+4. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
 
-5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
+5. Download release artifacts and upload them `downloads.haskell.org/~ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u <your-email> SHA256SUMS`)
 
-6. Download release artifacts and upload them `downloads.haskell.org/~ghcup` along with checksum files (also check `scripts/releasing/pull_release_artifacts.sh` and `scripts/releasing/sftp-upload-artifacts.sh`)
+6. Add ghcup release artifacts to ALL yaml files, see [ghcup-metadata repo](https://github.com/haskell/ghcup-metadata)
 
-7. Add ghcup release artifacts to ALL yaml files, see [ghcup-metadata repo](https://github.com/haskell/ghcup-metadata)
+7. Upload the final `ghcup-<ver>.yaml` (and a detached GPG sig of it) to `webhost.haskell.org/ghcup/data/` (for yaml versions <= 0.0.6) as well as [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) (for all versions).
 
-8. Upload the final `ghcup-<ver>.yaml` (and a detached GPG sig of it) to `webhost.haskell.org/ghcup/data/` (for yaml versions <= 0.0.6) as well as [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) (for all versions).
+8. Upload `bootstrap-haskell` and `bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
 
-9. Update version in `scripts/bootstrap/bootstrap-haskell` (`ghver` variable at the top of the script)
+9. Update the top-level ghcup symlinks at `downloads.haskell.org/~ghcup`
 
-10. Upload `scripts/bootstrap/bootstrap-haskell` and `scripts/bootstrap/bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
+10. Post on reddit/discourse/etc. and collect rewards
-
-11. Update the top-level ghcup symlinks at `downloads.haskell.org/~ghcup` (see `scripts/releasing/sftp-symlink-artifacts.sh`)
-
-12. Update the `data/metadata` submodule in ghcup-hs repo to master
-
-13. Do hackage release
-
-14. Post on reddit/discourse/etc. and collect rewards
 
 # Documentation
 

docs/guide.md

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

docs/index.md

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

docs/install.md

@@ -2,7 +2,7 @@
 
 GHCup makes it easy to install specific versions of GHC on GNU/Linux,
 macOS (aka Darwin), FreeBSD and Windows and can also bootstrap a fresh [Haskell developer environment](./install/#supported-tools) from scratch.
-It follows the UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
+It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well). Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
 
 ## Installation
 
@@ -22,114 +22,28 @@ For Windows, run this in a PowerShell session:
 Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true
 ```
 
-There's also a [youtube video](https://www.youtube.com/watch?v=bB4fmQiUYPw) explaining installation on windows.
-
 If you want to know what these scripts do, check out the [source code at the repository](https://gitlab.haskell.org/haskell/ghcup-hs/-/tree/master/scripts/bootstrap). Advanced users may want to perform a [manual installation](#manual-install) and GPG verify the binaries.
 
-### Which versions get installed?
+## First steps
 
-GHCup has two main channels for every tool: **recommended** and **latest**. By default, it installs *recommended*.
+1. To get started with creating a Haskell project, follow the [Getting Started with Haskell and Cabal](https://cabal.readthedocs.io/en/latest/getting-started.html) guide
-
+2. To properly learn Haskell, run through the [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises
-*latest* follows the latest release of every tool, while *recommended* is at the discretion of the GHCup maintainers and based on community adoption (hackage libraries, tools like HLS, stackage support, etc.) and known bugs.
+3. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
-
-Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information.
-
-## Next steps
-
-1. Follow the [First steps guide](../steps) on how to build a "Hello world" program, use `ghc`, run an interactive REPL and create a Haskell project
-2. To understand the difference and overlap of `stack` and `cabal`, read on [here](https://gist.github.com/merijn/8152d561fb8b011f9313c48d876ceb07)
-3. To learn Haskell proper check out the links at [How to learn Haskell proper](../steps#how-to-learn-haskell-proper)
-4. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
 
 ## Uninstallation
 
 On linux, just run `ghcup nuke`, then make sure any ghcup added lines in your `~/.bashrc` (or similar) are removed.
 
-On windows, right click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop and select *Run with PowerShell*.
+On windows, double-click on the `Uninstall Haskell.ps1` PowerShell script on your Desktop.
 
 ## Supported tools
 
 GHCup supports the following tools, which are also known as the **Haskell Toolchain**:
 
-<details> <summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary>
+1. [GHC](https://www.haskell.org/ghc/)
-<table>
+2. [cabal-install](https://cabal.readthedocs.io/en/latest/)
-<thead><tr><th>GHC Version</th><th>Tags</th></tr></thead>
+3. [haskell-language-server](https://haskell-language-server.readthedocs.io/en/latest/)
-<tbody>
+4. [stack](https://docs.haskellstack.org/en/latest/README/)
-<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>
-<tr><td>8.10.7</td><td><span style="color:green">recommended</span>, base-4.14.3.0</td></tr>
-<tr><td>8.10.6</td><td>base-4.14.3.0</td></tr>
-<tr><td>8.10.5</td><td>base-4.14.2.0</td></tr>
-<tr><td>8.10.4</td><td>base-4.14.1.0</td></tr>
-<tr><td>8.10.3</td><td>base-4.14.1.0</td></tr>
-<tr><td>8.10.2</td><td>base-4.14.1.0</td></tr>
-<tr><td>8.10.1</td><td>base-4.14.0.0</td></tr>
-<tr><td>8.8.4</td><td>base-4.13.0.0</td></tr>
-<tr><td>8.8.3</td><td>base-4.13.0.0</td></tr>
-<tr><td>8.8.2</td><td>base-4.13.0.0</td></tr>
-<tr><td>8.8.1</td><td>base-4.13.0.0</td></tr>
-<tr><td>8.6.5</td><td>base-4.12.0.0</td></tr>
-<tr><td>8.6.4</td><td>base-4.12.0.0</td></tr>
-<tr><td>8.6.3</td><td>base-4.12.0.0</td></tr>
-<tr><td>8.6.2</td><td>base-4.12.0.0</td></tr>
-<tr><td>8.6.1</td><td>base-4.12.0.0</td></tr>
-<tr><td>8.4.4</td><td>base-4.11.1.0</td></tr>
-<tr><td>8.4.3</td><td>base-4.11.1.0</td></tr>
-<tr><td>8.4.2</td><td>base-4.11.1.0</td></tr>
-<tr><td>8.4.1</td><td>base-4.11.0.0</td></tr>
-<tr><td>8.2.2</td><td>base-4.10.1.0</td></tr>
-<tr><td>8.0.2</td><td>base-4.9.1.0</td></tr>
-<tr><td>7.10.3</td><td>base-4.8.2.0</td></tr>
-</tbody>
-</table>
-</details>
-
-<details> <summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary>
-<table>
-<thead><tr><th>Cabal Version</th><th>Tags</th></tr></thead>
-<tbody>
-<tr><td>3.6.2.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
-<tr><td>3.6.0.0</td><td></td></tr>
-<tr><td>3.4.1.0</td><td></td></tr>
-<tr><td>3.4.0.0</td><td></td></tr>
-<tr><td>3.2.0.0</td><td></td></tr>
-<tr><td>3.0.0.0</td><td></td></tr>
-<tr><td>2.4.1.0</td><td></td></tr>
-</tbody>
-</table>
-</details>
-
-<details> <summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary>
-<table>
-<thead><tr><th>HLS Version</th><th>Tags</th></tr></thead>
-<tbody>
-<tr><td>1.7.0.0</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
-<tr><td>1.6.1.0</td><td></td></tr>
-<tr><td>1.6.0.0</td><td></td></tr>
-<tr><td>1.5.1</td><td></td></tr>
-<tr><td>1.5.0</td><td></td></tr>
-<tr><td>1.4.0</td><td></td></tr>
-<tr><td>1.3.0</td><td></td></tr>
-<tr><td>1.2.0</td><td></td></tr>
-<tr><td>1.1.0</td><td></td></tr>
-</tbody>
-</table>
-</details>
-
-<details> <summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary>
-<table>
-<thead><tr><th>Stack Version</th><th>Tags</th></tr></thead>
-<tbody>
-<tr><td>2.7.5</td><td><span style="color:blue">latest</span>, <span style="color:green">recommended</span></td></tr>
-<tr><td>2.7.3</td><td></td></tr>
-<tr><td>2.7.1</td><td></td></tr>
-<tr><td>2.5.1</td><td></td></tr>
-</tbody>
-</table>
-</details>
 
 ## Supported platforms
 
@@ -164,15 +78,14 @@ May or may not work, several issues:
 
 Unsupported. GHC may or may not work. Upgrade to WSL2.
 
-### MacOS <10.13
+### MacOS <13
 
-Not supported. Would require separate binaries, since >=10.13 binaries are incompatible.
+Not supported. Would require separate binaries, since >=13 binaries are incompatible.
 Please upgrade.
 
 ### MacOS aarch64
 
-HLS bindists are still experimental. Stack has only unofficial binaries for this platform.
+HLS bindists are still experimental. Stack is theoretically supported, but has no binaries yet.
-There are various issues with GHC itself.
 
 ### FreeBSD
 
@@ -181,14 +94,14 @@ HLS bindists are experimental.
 
 ### Linux ARMv7/AARCH64
 
-Lower availability of bindists. Stack and HLS binaries are experimental.
+Lower availability of bindists. HLS only has experimental ones. Stack not supported currently.
 
 ## Manual install
 
 Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
 and place it into your `PATH` anywhere.
 
-If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`.
+If you want to GPG verify the binaries, import the following key first: `7784930957807690A66EBDBE3786C5262ECB4A3F`.
 
 Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
 

docs/steps.md

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

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.18.0
+version:            0.1.17.3
 license:            LGPL-3.0-only
 license-file:       LICENSE
 copyright:          Julian Ospald 2020
@@ -44,39 +44,40 @@ flag internal-downloader
   manual:      True
 
 flag no-exe
-  description: Don't build any executables
+  description: Don't build any executables 
   default:     False
   manual:      True
 
 library
   exposed-modules:
     GHCup
-    GHCup.Cabal
+    GHCup.Data.Versions
-    GHCup.Download
-    GHCup.Download.Utils
-    GHCup.Errors
     GHCup.GHC
-    GHCup.HLS
+    GHCup.GHC.Rm
-    GHCup.List
+    GHCup.GHC.Unset
+    GHCup.GHC.Set
+    GHCup.GHC.Compile
+    GHCup.GHC.Common
+    GHCup.GHC.Install
+    GHCup.Download
+    GHCup.Download.Common
+    GHCup.Errors
     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.Directories
+    GHCup.System.Process
+    GHCup.System.Directory
+    GHCup.System.Process.Common
+    GHCup.System.Console
+    GHCup.Logger
+    GHCup.MegaParsec
+    GHCup.Prelude
+    GHCup.QQ.String
+    GHCup.QQ.Version
     GHCup.Version
 
   hs-source-dirs:     lib
@@ -108,7 +109,7 @@ library
     , base                  >=4.12       && <5
     , base16-bytestring     >=0.1.1.6    && <1.1
     , binary                ^>=0.8.6.0
-    , bytestring            >=0.10       && <0.12
+    , bytestring            ^>=0.10
     , Cabal                 ^>=3.6.2.0
     , case-insensitive      ^>=1.2.1.0
     , casing                ^>=0.1.4.1
@@ -117,13 +118,12 @@ 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
+    , haskus-utils-variant  >=3.0        && <3.2
     , libarchive            ^>=3.0.3.0
     , lzma-static           ^>=5.2.5.3
-    , megaparsec            >=8.0.0      && <9.3
+    , megaparsec            >=8.0.0      && <9.1
     , mtl                   ^>=2.2
     , optics                ^>=0.4
     , os-release            ^>=1.0.0
@@ -135,7 +135,6 @@ 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
@@ -163,9 +162,9 @@ library
   if os(windows)
     cpp-options:   -DIS_WINDOWS
     other-modules:
-      GHCup.Prelude.File.Windows
+      GHCup.System.Process.Windows
-      GHCup.Prelude.Process.Windows
       GHCup.Prelude.Windows
+      GHCup.System.Console.Windows
 
     build-depends:
       , bzlib
@@ -174,16 +173,14 @@ library
 
   else
     other-modules:
-      GHCup.Prelude.File.Posix
+      GHCup.System.Process.Posix
-      GHCup.Prelude.File.Posix.Foreign
+      GHCup.System.Console.Posix
-      GHCup.Prelude.File.Posix.Traversals
       GHCup.Prelude.Posix
-      GHCup.Prelude.Process.Posix
+      System.Console.Terminal.Common
+      System.Console.Terminal.Posix
 
-    c-sources:     cbits/dirutils.c
     build-depends:
       , bz2              >=0.5.0.5 && <1.1
-      , terminal-size    ^>=0.3.2.1
       , unix             ^>=2.7
       , unix-bytestring  ^>=0.3.7.3
 
@@ -206,7 +203,6 @@ executable ghcup
     GHCup.OptParse.Nuke
     GHCup.OptParse.Prefetch
     GHCup.OptParse.Rm
-    GHCup.OptParse.Run
     GHCup.OptParse.Set
     GHCup.OptParse.ToolRequirements
     GHCup.OptParse.UnSet
@@ -234,33 +230,27 @@ executable ghcup
     , aeson-pretty          ^>=0.8.8
     , async                 ^>=2.2.3
     , base                  >=4.12     && <5
-    , bytestring            >=0.10       && <0.12
+    , bytestring            ^>=0.10
     , 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.0      && <3.2
-    , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
-    , megaparsec            >=8.0.0    && <9.3
+    , megaparsec            >=8.0.0    && <9.1
     , mtl                   ^>=2.2
-    , optparse-applicative  >=0.15.1.0 && <0.18
+    , optparse-applicative-fork  >=0.15.1.0 && <0.17
     , pretty                ^>=1.1.3.1
     , pretty-terminal       ^>=0.1.0.0
-    , process               ^>=1.6.11.0
     , resourcet             ^>=1.2.2
     , safe                  ^>=0.3.18
     , safe-exceptions       ^>=0.1
-    , tagsoup               ^>=0.14
     , template-haskell      >=2.7      && <2.18
-    , temporary             ^>=1.3
     , text                  ^>=1.2.4.0
-    , unordered-containers  ^>=0.2
     , uri-bytestring        ^>=0.3.2.2
     , utf8-string           ^>=1.0
-    , vector                ^>=0.12
     , versions              >=4.0.1    && <5.1
     , yaml-streamly         ^>=0.12.0
 
@@ -274,14 +264,12 @@ executable ghcup
       , brick         ^>=0.64
       , transformers  ^>=0.5
       , unix          ^>=2.7
+      , vector        ^>=0.12
       , vty           >=5.28.2 && <5.34
 
   if os(windows)
     cpp-options: -DIS_WINDOWS
 
-  else
-    build-depends: unix ^>=2.7
-
   if flag(no-exe)
     buildable: False
 
@@ -293,7 +281,6 @@ test-suite ghcup-test
   other-modules:
     GHCup.ArbitraryTypes
     GHCup.Types.JSONSpec
-    GHCup.Utils.FileSpec
     Spec
 
   default-language:   Haskell2010
@@ -311,17 +298,14 @@ test-suite ghcup-test
 
   build-depends:
     , base                      >=4.12    && <5
-    , bytestring            >=0.10       && <0.12
+    , bytestring                ^>=0.10
     , containers                ^>=0.6
-    , directory                 ^>=1.3.6.0
+    , generic-arbitrary         ^>=0.1.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                     ^>=2.7.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

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

lib/GHCup/Directories.hs

@@ -0,0 +1,346 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE ViewPatterns          #-}
+
+{-|
+Module      : GHCup.Directories
+Description : Definition of GHCup directories
+Copyright   : (c) Julian Ospald, 2020
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : portable
+-}
+module GHCup.Directories
+  ( getAllDirs
+  , ghcupBaseDir
+  , ghcupConfigFile
+  , ghcupCacheDir
+  , ghcupGHCBaseDir
+  , ghcupGHCDir
+  , mkGhcupTmpDir
+  , parseGHCupGHCDir
+  , relativeSymlink
+  , withGHCupTmpDir
+  , getConfigFilePath
+  , useXDG
+  , cleanupTrash
+  )
+where
+
+
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.JSON               ( )
+import           GHCup.Types.Optics
+import           GHCup.MegaParsec
+import           GHCup.Logger
+import           GHCup.Prelude
+
+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.Bifunctor
+import           Data.Maybe
+import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
+import           Haskus.Utils.Variant.Excepts
+import           Optics
+import           System.Directory                                                
+import           System.DiskSpace                                                
+import           System.Environment
+import           System.FilePath
+import           System.IO.Temp
+
+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)
+
+
+
+    ------------------------------
+    --[ GHCup base directories ]--
+    ------------------------------
+
+
+-- | ~/.ghcup by default
+--
+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
+-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
+ghcupBaseDir :: IO FilePath
+ghcupBaseDir
+  | isWindows = do
+      bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
+      pure (bdir </> "ghcup")
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".local" </> "share")
+          pure (bdir </> "ghcup")
+        else do
+          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+            Just r  -> pure r
+            Nothing -> liftIO getHomeDirectory
+          pure (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
+  | isWindows = ghcupBaseDir
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".config")
+          pure (bdir </> "ghcup")
+        else do
+          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+            Just r  -> pure r
+            Nothing -> liftIO getHomeDirectory
+          pure (bdir </> ".ghcup")
+
+
+-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
+-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
+-- (which, sadly is not strictly xdg spec).
+ghcupBinDir :: IO FilePath
+ghcupBinDir
+  | isWindows = ghcupBaseDir <&> (</> "bin")
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          lookupEnv "XDG_BIN_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".local" </> "bin")
+        else 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
+  | isWindows = ghcupBaseDir <&> (</> "cache")
+  | 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 (bdir </> "ghcup")
+        else ghcupBaseDir <&> (</> "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
+  | isWindows = ghcupBaseDir <&> (</> "logs")
+  | 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 (bdir </> "ghcup" </> "logs")
+        else ghcupBaseDir <&> (</> "logs")
+
+
+-- | '~/.ghcup/trash'.
+-- Mainly used on windows to improve file removal operations
+ghcupRecycleDir :: IO FilePath
+ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
+
+
+
+getAllDirs :: IO Dirs
+getAllDirs = do
+  baseDir    <- ghcupBaseDir
+  binDir     <- ghcupBinDir
+  cacheDir   <- ghcupCacheDir
+  logsDir    <- ghcupLogsDir
+  confDir    <- ghcupConfigDir
+  recycleDir <- ghcupRecycleDir
+  pure Dirs { .. }
+
+
+
+    -------------------
+    --[ GHCup files ]--
+    -------------------
+
+getConfigFilePath :: (MonadIO m) => m FilePath
+getConfigFilePath = do
+  confDir <- liftIO ghcupConfigDir
+  pure $ confDir </> "config.yaml"
+
+ghcupConfigFile :: (MonadIO m)
+                => Excepts '[JSONError] m UserSettings
+ghcupConfigFile = do
+  filepath <- getConfigFilePath
+  contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
+  case contents of
+      Nothing -> pure defaultUserSettings
+      Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
+
+
+    -------------------------
+    --[ GHCup directories ]--
+    -------------------------
+
+
+-- | ~/.ghcup/ghc by default.
+ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ghcupGHCBaseDir = do
+  Dirs {..}  <- getDirs
+  pure (baseDir </> "ghc")
+
+
+-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
+-- The dir may be of the form
+--   * armv7-unknown-linux-gnueabihf-8.8.3
+--   * 8.8.4
+ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
+            => GHCTargetVersion
+            -> m FilePath
+ghcupGHCDir ver = do
+  ghcbasedir <- ghcupGHCBaseDir
+  let verdir = T.unpack $ tVerToText ver
+  pure (ghcbasedir </> verdir)
+
+
+-- | See 'ghcupToolParser'.
+parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
+parseGHCupGHCDir (T.pack -> fp) =
+  throwEither $ MP.parse ghcTargetVerP "" fp
+
+
+mkGhcupTmpDir :: ( MonadReader env m
+                 , HasDirs env
+                 , MonadUnliftIO m
+                 , HasLog env
+                 , MonadCatch 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
+
+
+withGHCupTmpDir :: ( MonadReader env m
+                   , HasDirs env
+                   , HasLog env
+                   , HasSettings env
+                   , MonadUnliftIO m
+                   , MonadCatch m
+                   , MonadResource m
+                   , MonadThrow m
+                   , MonadMask m
+                   , MonadIO m)
+                => m FilePath
+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
+            $ fp))
+
+
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+useXDG :: IO Bool
+useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
+
+
+relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
+                -> FilePath  -- ^ the symlink destination
+                -> FilePath
+relativeSymlink p1 p2 =
+  let d1      = splitDirectories p1
+      d2      = splitDirectories p2
+      common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
+      cPrefix = drop (length common) d1
+  in  joinPath (replicate (length cPrefix) "..")
+        <> joinPath ([pathSeparator] : drop (length common) d2)
+
+
+cleanupTrash :: ( MonadIO m
+                , MonadMask m
+                , MonadReader env m
+                , HasLog env
+                , HasDirs env
+                , HasSettings env
+                )
+             => m ()
+cleanupTrash = do
+  Dirs { recycleDir } <- getDirs
+  contents <- liftIO $ listDirectory recycleDir
+  if null contents
+  then pure ()
+  else do
+    logWarn ("Removing leftover files in " <> T.pack recycleDir)
+    forM_ contents (\fp -> handleIO (\e ->
+        logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
+      ) $ liftIO $ removePathForcibly (recycleDir </> fp))
+

lib/GHCup/Download.hs

@@ -27,17 +27,16 @@ module GHCup.Download where
 
 #if defined(INTERNAL_DOWNLOADER)
 import           GHCup.Download.IOStreams
-import           GHCup.Download.Utils
+import           GHCup.Download.Common
 #endif
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
+import           GHCup.System.Process
+import           GHCup.Logger
 import           GHCup.Prelude
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger.Internal
-import           GHCup.Prelude.Process
 import           GHCup.Version
 
 import           Control.Applicative
@@ -70,6 +69,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe
+import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
@@ -121,31 +121,34 @@ getDownloadsF = do
   Settings { urlSource } <- lift getSettings
   case urlSource of
     GHCupURL -> liftE $ getBase ghcupURL
-    (OwnSource exts) -> do
+    (OwnSource url) -> liftE $ getBase url
-      ext  <- liftE $ mapM (either pure getBase) exts
-      mergeGhcupInfo ext
     (OwnSpec av) -> pure av
-    (AddSource exts) -> do
+    (AddSource (Left ext)) -> do
       base <- liftE $ getBase ghcupURL
-      ext  <- liftE $ mapM (either pure getBase) exts
+      pure (mergeGhcupInfo base ext)
-      mergeGhcupInfo (base:ext)
+    (AddSource (Right uri)) -> do
+      base <- liftE $ getBase ghcupURL
+      ext  <- liftE $ getBase uri
+      pure (mergeGhcupInfo base ext)
 
- where
+    where
-  mergeGhcupInfo :: MonadFail m
+
-                 => [GHCupInfo]
+  mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-                 -> m GHCupInfo
+                 -> GHCupInfo -- ^ extension overwriting the base
-  mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
+                 -> GHCupInfo
-  mergeGhcupInfo xs@(GHCupInfo{}: _) =
+  mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
-    let newDownloads   = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads   <$> xs)
+    let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
-        newGlobalTools = M.unionsWith (\_ a2 -> a2              ) (_globalTools      <$> xs)
+                                        Just a' -> M.union a' a
-        newToolReqs    = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
+                                        Nothing -> a
-    in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
+                                    ) base
+        newGlobalTools = M.union base2 ext2
+    in GHCupInfo tr newDownloads newGlobalTools
 
 
 yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
 yamlFromCache uri = do
   Dirs{..} <- getDirs
-  pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
+  pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
 
 
 etagsFile :: FilePath -> FilePath
@@ -242,7 +245,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 (fromGHCupPath cacheDir) Nothing True
+    if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
        | e -> do
           accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
           let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -581,7 +584,7 @@ downloadCached dli mfn = do
     True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
+      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
 
 
 downloadCached' :: ( MonadReader env m
@@ -599,7 +602,7 @@ downloadCached' :: ( MonadReader env m
                 -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
 downloadCached' dli mfn mDestDir = do
   Dirs { cacheDir } <- lift getDirs
-  let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
+  let destDir = fromMaybe cacheDir mDestDir
   let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
   let cachfile = destDir </> fn
   fileExists <- liftIO $ doesFileExist cachfile

lib/GHCup/Download/Common.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE TypeFamilies          #-}
 
 
-module GHCup.Download.Utils where
+module GHCup.Download.Common where
 
 
 import           GHCup.Errors

lib/GHCup/Download/IOStreams.hs

@@ -7,7 +7,7 @@
 module GHCup.Download.IOStreams where
 
 
-import           GHCup.Download.Utils
+import           GHCup.Download.Common
 import           GHCup.Errors
 import           GHCup.Types.JSON               ( )
 import           GHCup.Prelude

lib/GHCup/Errors.hs

@@ -27,7 +27,6 @@ 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
@@ -105,15 +104,6 @@ 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
@@ -137,13 +127,10 @@ 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
@@ -158,13 +145,6 @@ 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
@@ -311,26 +291,6 @@ 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 ]--
@@ -347,17 +307,6 @@ 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

@@ -1,625 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE BangPatterns          #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-
-{-|
-Module      : GHCup.HLS
-Description : GHCup installation functions for HLS
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
-module GHCup.HLS where
-
-import           GHCup.Download
-import           GHCup.Errors
-import           GHCup.Types
-import           GHCup.Types.JSON               ( )
-import           GHCup.Types.Optics
-import           GHCup.Utils
-import           GHCup.Prelude
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
-import           GHCup.Prelude.String.QQ
-
-import           Codec.Archive                  ( ArchiveResult )
-import           Control.Applicative
-import           Control.Exception.Safe
-import           Control.Monad
-#if !MIN_VERSION_base(4,13,0)
-import           Control.Monad.Fail             ( MonadFail )
-#endif
-import           Control.Monad.Reader
-import           Control.Monad.Trans.Resource
-                                         hiding ( throwM )
-import           Data.ByteString                ( ByteString )
-import           Data.Either
-import           Data.List
-import           Data.Maybe
-import           Data.String                    ( fromString )
-import           Data.Text                      ( Text )
-import           Data.Versions                hiding ( patch )
-import           Distribution.Types.Version   hiding ( Version )
-import           Distribution.Types.PackageId
-import           Distribution.Types.PackageDescription
-import           Distribution.Types.GenericPackageDescription
-import           Distribution.PackageDescription.Parsec
-import           GHC.IO.Exception
-import           Haskus.Utils.Variant.Excepts
-import           Optics
-import           Prelude                 hiding ( abs
-                                                , writeFile
-                                                )
-import           Safe                    hiding ( at )
-import           System.FilePath
-import           System.IO.Error
-import           Text.Regex.Posix
-import           URI.ByteString
-
-import qualified Data.List.NonEmpty            as NE
-import qualified Data.ByteString               as B
-import qualified Data.Text                     as T
-import qualified Text.Megaparsec               as MP
-import Text.PrettyPrint.HughesPJClass (prettyShow)
-
-
-
-    --------------------
-    --[ 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
-           -> Maybe 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) <- 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)
-
-    -- clone from git
-    Right GitBranch{..} -> do
-      tmpUnpack <- lift mkGhcupTmpDir
-      let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
-      tver <- 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 ]
-
-        let fetch_args =
-                  [ "fetch"
-                  , "--depth"
-                  , "1"
-                  , "--quiet"
-                  , "origin"
-                  , fromString ref ]
-        lEM $ git fetch_args
-
-        lEM $ git [ "checkout", "FETCH_HEAD" ]
-        (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
-        pure . (\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 $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
-
-      pure (tmpUnpack, tver)
-
-  -- the version that's installed may differ from the
-  -- compiled version, so the user can overwrite it
-  let installVer = fromMaybe tver ov
-
-  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
-        logInfo $ 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
-
-
-    -----------------
-    --[ 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
-      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

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

lib/GHCup/Logger.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
 {-|
-Module      : GHCup.Utils.Logger.Internal
+Module      : GHCup.Logger
 Description : logger definition
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -11,13 +12,16 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 
-Breaking import cycles.
+Here we define our main logger.
 -}
-module GHCup.Prelude.Logger.Internal where
+module GHCup.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
+import {-# SOURCE #-} GHCup.System.Directory
+import           GHCup.QQ.String
 
+import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
@@ -25,7 +29,12 @@ 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.Prelude
 import qualified Data.Text                     as T
 
 logInfo :: ( MonadReader env m
@@ -83,7 +92,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' )
@@ -101,3 +110,22 @@ 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/Logger.hs-boot

@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE OverloadedStrings   #-}
+
+module GHCup.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/MegaParsec.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings    #-}
 
 {-|
-Module      : GHCup.Utils.MegaParsec
+Module      : GHCup.MegaParsec
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -10,7 +10,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Prelude.MegaParsec where
+module GHCup.MegaParsec where
 
 import           GHCup.Types
 

lib/GHCup/Platform.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TemplateHaskell       #-}
 
 
 {-|
@@ -23,11 +23,10 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.System.Process
+import           GHCup.Logger
 import           GHCup.Prelude
-import           GHCup.Prelude.Logger
+import           GHCup.QQ.String
-import           GHCup.Prelude.Process
-import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -47,6 +46,7 @@ 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

@@ -19,7 +19,6 @@ 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
@@ -28,23 +27,159 @@ module GHCup.Prelude
   )
 where
 
+import           GHCup.Types
 import           GHCup.Errors
-import           GHCup.Prelude.Internal
+import           GHCup.Types.Optics
-import           GHCup.Types.Optics   (HasLog)
+import {-# SOURCE #-} GHCup.Logger
-import           GHCup.Prelude.Logger (logWarn)
 #if defined(IS_WINDOWS)
-import GHCup.Prelude.Windows
+import           GHCup.Prelude.Windows
 #else
-import GHCup.Prelude.Posix
+import           GHCup.Prelude.Posix
 #endif
 
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
 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.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
+
+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
+import qualified Data.Text.Lazy                as TL
+import qualified Data.Text.Lazy.Builder        as B
+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
+-- >>> import Data.Word8
+-- >>> import qualified Data.Text as T
+-- >>> import qualified Data.Char as C
+-- >>> import Data.List
+-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
+
+
+fS :: IsString a => String -> a
+fS = fromString
+
+fromStrictMaybe :: S.Maybe a -> Maybe a
+fromStrictMaybe = S.maybe Nothing Just
+
+fSM :: S.Maybe a -> Maybe a
+fSM = fromStrictMaybe
+
+toStrictMaybe :: Maybe a -> S.Maybe a
+toStrictMaybe = maybe S.Nothing S.Just
+
+tSM :: Maybe a -> S.Maybe a
+tSM = toStrictMaybe
+
+internalError :: String -> IO a
+internalError = fail . ("Internal error: " <>)
+
+iE :: String -> IO a
+iE = internalError
+
+
+showT :: Show a => a -> Text
+showT = fS . show
+
+-- | Like 'when', but where the test can be monadic.
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM ~b ~t = ifM b t (return ())
+
+-- | Like 'unless', but where the test can be monadic.
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM ~b ~f = ifM b (return ()) f
+
+-- | Like @if@, but where the test can be monadic.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM ~b ~t ~f = do
+  b' <- b
+  if b' then t else f
+
+whileM :: Monad m => m a -> (a -> m Bool) -> m a
+whileM ~action ~f = do
+  a  <- action
+  b' <- f a
+  if b' then whileM action f else pure a
+
+whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
+whileM_ ~action = void . whileM action
+
+guardM :: (Monad m, Alternative m) => m Bool -> m ()
+guardM ~f = guard =<< f
+
+
+handleIO' :: (MonadIO m, MonadCatch m)
+          => IOErrorType
+          -> (IOException -> m a)
+          -> m a
+          -> m a
+handleIO' err handler = handleIO
+  (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
+
+
+(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
+(??) m e = maybe (throwE e) pure m
+
+
+(!?) :: forall e es a m
+      . (Monad m, e :< es)
+     => m (Maybe a)
+     -> e
+     -> Excepts es m a
+(!?) em e = lift em >>= (?? e)
+
+
+lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
+lE = liftE . veitherToExcepts . fromEither
+
+lE' :: forall e' e es a m
+     . (Monad m, e :< es)
+    => (e' -> e)
+    -> Either e' a
+    -> Excepts es m a
+lE' f = liftE . veitherToExcepts . fromEither . first f
+
+lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
+lEM em = lift em >>= lE
+
+lEM' :: forall e' e es a m
+      . (Monad m, e :< es)
+     => (e' -> e)
+     -> m (Either e' a)
+     -> 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)
@@ -54,29 +189,580 @@ catchWarn :: forall es m env . ( Pretty (V es)
                              , Monad m) => Excepts es m () -> Excepts '[] m ()
 catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
 
-
+fromEither :: Either a b -> VEither '[a] b
-runBothE' :: forall e m a b .
+fromEither = either (VLeft . V) VRight
-             ( 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
+liftIOException' :: ( MonadCatch m
-throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
+                    , MonadIO m
-{-# INLINABLE throwSomeE #-}
+                    , Monad m
-throwSomeE = Excepts . pure . VLeft . liftVariant
+                    , e :< es'
+                    , LiftVariant es es'
+                    )
+                 => IOErrorType
+                 -> e
+                 -> Excepts es m a
+                 -> Excepts es' m a
+liftIOException' errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . liftE
+
+
+liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
+                => IOErrorType
+                -> e
+                -> m a
+                -> Excepts es' m a
+liftIOException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . lift
+
+
+-- | Uses safe-exceptions.
+hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
+hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
+
+
+hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
+hideErrorDef errs def =
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
+
+
+hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
+hideErrorDefM errs def =
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
+
+
+-- TODO: does this work?
+hideExcept :: forall e es es' a m
+            . (Monad m, e :< es, LiftVariant (Remove e es) es')
+           => e
+           -> a
+           -> Excepts es m a
+           -> Excepts es' m a
+hideExcept _ a =
+  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
+
+
+hideExcept' :: forall e es es' m
+             . (Monad m, e :< es, LiftVariant (Remove e es) es')
+            => e
+            -> Excepts es m ()
+            -> Excepts es' m ()
+hideExcept' _ =
+  catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
+
+
+reThrowAll :: forall e es es' a m
+            . (Monad m, e :< es')
+           => (V es -> e)
+           -> Excepts es m a
+           -> Excepts es' m a
+reThrowAll f = catchAllE (throwE . f)
+
+
+reThrowAllIO :: forall e es es' a m
+              . (MonadCatch m, Monad m, MonadIO m, e :< es')
+             => (V es -> e)
+             -> (IOException -> e)
+             -> Excepts es m a
+             -> Excepts es' m a
+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
+
+
+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+throwEither a = case a of
+  Left  e -> throwM e
+  Right r -> pure r
+
+
+throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
+throwEither' e eth = case eth of
+  Left  _ -> throwM e
+  Right r -> pure r
+
+throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
+throwMaybe a m = case m of
+  Nothing -> throwM a
+  Just r -> pure r
+
+throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
+throwMaybeM a am = do
+  m <- am
+  throwMaybe a m
+
+
+verToBS :: Version -> ByteString
+verToBS = E.encodeUtf8 . prettyVer
+
+verToS :: Version -> String
+verToS = T.unpack . prettyVer
+
+intToText :: Integral a => a -> T.Text
+intToText = TL.toStrict . B.toLazyText . B.decimal
+
+
+removeLensFieldLabel :: String -> String
+removeLensFieldLabel str' =
+  maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
+
+
+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.
+decUTF8Safe :: ByteString -> Text
+decUTF8Safe = E.decodeUtf8With E.lenientDecode
+
+decUTF8Safe' :: L.ByteString -> Text
+decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
+
+
+-- | Escape a version for use in regex
+escapeVerRex :: Version -> ByteString
+escapeVerRex = B.pack . go . B.unpack . verToBS
+ where
+  go [] = []
+  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 isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else 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 {- 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
+recover action = 
+  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+    [\_ -> Handler (\e -> pure $ isPermissionError e)
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+    ]
+    (\_ -> 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"]
+-- ["1","0","2","0"]
+-- >>> traverseFold Just ["1","2","3","4","5"]
+-- Just "12345"
+--
+-- prop> \t -> traverseFold Just t === Just (mconcat t)
+traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
+traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
+
+-- | Gathering monoidal values
+forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
+forFold = \t -> (`traverseFold` t)
+
+
+-- | Strip @\\r@ and @\\n@ from 'String's
+--
+-- >>> stripNewline "foo\n\n\n"
+-- "foo"
+-- >>> stripNewline "foo\n\n\nfoo"
+-- "foofoo"
+-- >>> stripNewline "foo\r"
+-- "foo"
+-- >>> stripNewline "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
+stripNewline :: String -> String
+stripNewline = filter (`notElem` "\n\r")
+
+
+-- | Strip @\\r@ and @\\n@ from end of 'String'.
+--
+-- >>> stripNewlineEnd "foo\n\n\n"
+-- "foo"
+-- >>> stripNewlineEnd "foo\n\n\nfoo"
+-- "foo\n\n\nfoo"
+-- >>> stripNewlineEnd "foo\r"
+-- "foo"
+-- >>> stripNewlineEnd "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
+stripNewlineEnd :: String -> String
+stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
+
+
+-- | Strip @\\r@ and @\\n@ from 'Text's
+--
+-- >>> stripNewline' "foo\n\n\n"
+-- "foo"
+-- >>> stripNewline' "foo\n\n\nfoo"
+-- "foofoo"
+-- >>> stripNewline' "foo\r"
+-- "foo"
+-- >>> stripNewline' "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
+-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
+stripNewline' :: T.Text -> T.Text
+stripNewline' = T.filter (`notElem` "\n\r")
+
+
+-- | Is the word8 a newline?
+--
+-- >>> isNewLine (c2w '\n')
+-- True
+-- >>> isNewLine (c2w '\r')
+-- True
+--
+-- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)
+isNewLine :: Word8 -> Bool
+isNewLine w
+  | w == _lf = True
+  | w == _cr = True
+  | otherwise = False
+
+
+-- | Split on a PVP suffix.
+--
+-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"
+-- ("ghc-iserv-dyn","9.3.20210706")
+-- >>> splitOnPVP "-" "ghc-iserv-dyn"
+-- ("ghc-iserv-dyn","")
+splitOnPVP :: String -> String -> (String, String)
+splitOnPVP c s = case Split.splitOn c s of
+  []  -> def
+  [_] -> def
+  xs
+    | let l = last xs
+    , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
+    | otherwise -> def
+ where
+  def = (s, "")
+
+
+
+-- | Like 'find', but where the test can be monadic.
+--
+-- >>> findM (Just . C.isUpper) "teST"
+-- Just (Just 'S')
+-- >>> findM (Just . C.isUpper) "test"
+-- Just Nothing
+-- >>> findM (Just . const True) ["x",undefined]
+-- Just (Just "x")
+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
+
+
+-- | Drops the given suffix from a list.
+--   It returns the original sequence if the sequence doesn't end with the given suffix.
+--
+-- >>> dropSuffix "!" "Hello World!"
+-- "Hello World"
+-- >>> dropSuffix "!" "Hello World!!"
+-- "Hello World!"
+-- >>> dropSuffix "!" "Hello World."
+-- "Hello World."
+dropSuffix :: Eq a => [a] -> [a] -> [a]
+dropSuffix a b = fromMaybe b $ stripSuffix a b
+
+-- | Return the prefix of the second list if its suffix
+--   matches the entire first list.
+--
+-- >>> stripSuffix "bar" "foobar"
+-- Just "foo"
+-- >>> stripSuffix ""    "baz"
+-- Just "baz"
+-- >>> stripSuffix "foo" "quux"
+-- Nothing
+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
+stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)
+
+
+-- | Drops the given prefix from a list.
+--   It returns the original sequence if the sequence doesn't start with the given prefix.
+--
+-- >>> dropPrefix "Mr. " "Mr. Men"
+-- "Men"
+-- >>> dropPrefix "Mr. " "Dr. Men"
+-- "Dr. Men"
+dropPrefix :: Eq a => [a] -> [a] -> [a]
+dropPrefix a b = fromMaybe b $ stripPrefix a b
+
+
+
+-- | Break a list into pieces separated by the first
+-- list argument, consuming the delimiter. An empty delimiter is
+-- invalid, and will cause an error to be raised.
+--
+-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
+-- ["a","b","d","e"]
+-- >>> splitOn "aaa"  "aaaXaaaXaaaXaaa"
+-- ["","X","X","X",""]
+-- >>> splitOn "x"    "x"
+-- ["",""]
+-- >>> splitOn "x"    ""
+-- [""]
+--
+-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
+-- prop> \c x -> splitOn [c] x                           == split (==c) x
+splitOn :: Eq a => [a] -> [a] -> [[a]]
+splitOn [] _ = error "splitOn, needle may not be empty"
+splitOn _ [] = [[]]
+splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b
+    where (a,b) = breakOn needle haystack
+
+
+-- | Splits a list into components delimited by separators,
+-- where the predicate returns True for a separator element.  The
+-- resulting components do not contain the separators.  Two adjacent
+-- separators result in an empty component in the output.
+--
+-- >>> split (== 'a') "aabbaca"
+-- ["","","bb","c",""]
+-- >>> split (== 'a') ""
+-- [""]
+-- >>> split (== ':') "::xyz:abc::123::"
+-- ["","","xyz","abc","","123","",""]
+-- >>> split (== ',') "my,list,here"
+-- ["my","list","here"]
+split :: (a -> Bool) -> [a] -> [[a]]
+split _ [] = [[]]
+split f (x:xs)
+  | f x = [] : split f xs
+  | y:ys <- split f xs = (x:y) : ys
+  | otherwise = [[]]
+
+
+-- | Find the first instance of @needle@ in @haystack@.
+-- The first element of the returned tuple
+-- is the prefix of @haystack@ before @needle@ is matched.  The second
+-- is the remainder of @haystack@, starting with the match.
+-- If you want the remainder /without/ the match, use 'stripInfix'.
+--
+-- >>> breakOn "::" "a::b::c"
+-- ("a","::b::c")
+-- >>> breakOn "/" "foobar"
+-- ("foobar","")
+--
+-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
+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/File.hs

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

lib/GHCup/Prelude/File/Posix.hs

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

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

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

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

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

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

lib/GHCup/Prelude/Internal.hs

@@ -1,519 +0,0 @@
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
-
-{-|
-Module      : GHCup.Prelude.Internal
-Description : MegaParsec utilities
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
-
-Stuff that doesn't need GHCup modules, so we can avoid
-recursive imports.
--}
-module GHCup.Prelude.Internal where
-
-
-import           Control.Applicative
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Monad.Reader
-import           Data.Bifunctor
-import           Data.ByteString                ( ByteString )
-import           Data.List                      ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
-import           Data.Maybe
-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           System.IO.Error
-
-import           Control.Retry
-import           GHC.IO.Exception
-
-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.Text                     as T
-import qualified Data.Text.Encoding            as E
-import qualified Data.Text.Encoding.Error      as E
-import qualified Data.Text.Lazy                as TL
-import qualified Data.Text.Lazy.Builder        as B
-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
--- >>> import Data.Word8
--- >>> import qualified Data.Text as T
--- >>> import qualified Data.Char as C
--- >>> import Data.List
--- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
-
-
-fS :: IsString a => String -> a
-fS = fromString
-
-fromStrictMaybe :: S.Maybe a -> Maybe a
-fromStrictMaybe = S.maybe Nothing Just
-
-fSM :: S.Maybe a -> Maybe a
-fSM = fromStrictMaybe
-
-toStrictMaybe :: Maybe a -> S.Maybe a
-toStrictMaybe = maybe S.Nothing S.Just
-
-tSM :: Maybe a -> S.Maybe a
-tSM = toStrictMaybe
-
-internalError :: String -> IO a
-internalError = fail . ("Internal error: " <>)
-
-iE :: String -> IO a
-iE = internalError
-
-
-showT :: Show a => a -> Text
-showT = fS . show
-
--- | Like 'when', but where the test can be monadic.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM ~b ~t = ifM b t (return ())
-
--- | Like 'unless', but where the test can be monadic.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM ~b ~f = ifM b (return ()) f
-
--- | Like @if@, but where the test can be monadic.
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM ~b ~t ~f = do
-  b' <- b
-  if b' then t else f
-
-whileM :: Monad m => m a -> (a -> m Bool) -> m a
-whileM ~action ~f = do
-  a  <- action
-  b' <- f a
-  if b' then whileM action f else pure a
-
-whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
-whileM_ ~action = void . whileM action
-
-guardM :: (Monad m, Alternative m) => m Bool -> m ()
-guardM ~f = guard =<< f
-
-
-handleIO' :: (MonadIO m, MonadCatch m)
-          => IOErrorType
-          -> (IOException -> m a)
-          -> m a
-          -> m a
-handleIO' err handler = handleIO
-  (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
-
-
-(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
-(??) m e = maybe (throwE e) pure m
-
-
-(!?) :: forall e es a m
-      . (Monad m, e :< es)
-     => m (Maybe a)
-     -> e
-     -> Excepts es m a
-(!?) em e = lift em >>= (?? e)
-
-
-lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
-lE = liftE . veitherToExcepts . fromEither
-
-lE' :: forall e' e es a m
-     . (Monad m, e :< es)
-    => (e' -> e)
-    -> Either e' a
-    -> Excepts es m a
-lE' f = liftE . veitherToExcepts . fromEither . first f
-
-lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
-lEM em = lift em >>= lE
-
-lEM' :: forall e' e es a m
-      . (Monad m, e :< es)
-     => (e' -> e)
-     -> m (Either e' a)
-     -> Excepts es m a
-lEM' f em = lift em >>= lE . first f
-
-
-fromEither :: Either a b -> VEither '[a] b
-fromEither = either (VLeft . V) VRight
-
-
-liftIOException' :: ( MonadCatch m
-                    , MonadIO m
-                    , Monad m
-                    , e :< es'
-                    , LiftVariant es es'
-                    )
-                 => IOErrorType
-                 -> e
-                 -> Excepts es m a
-                 -> Excepts es' m a
-liftIOException' errType ex =
-  handleIO
-      (\e ->
-        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
-      )
-    . liftE
-
-
-liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
-                => IOErrorType
-                -> e
-                -> m a
-                -> Excepts es' m a
-liftIOException errType ex =
-  handleIO
-      (\e ->
-        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
-      )
-    . lift
-
-
--- | Uses safe-exceptions.
-hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
-hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
-
-
-hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
-hideErrorDef errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
-
-
-hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
-hideErrorDefM errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
-
-
--- TODO: does this work?
-hideExcept :: forall e es es' a m
-            . (Monad m, e :< es, LiftVariant (Remove e es) es')
-           => e
-           -> a
-           -> Excepts es m a
-           -> Excepts es' m a
-hideExcept _ a =
-  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
-
-
-hideExcept' :: forall e es es' m
-             . (Monad m, e :< es, LiftVariant (Remove e es) es')
-            => e
-            -> Excepts es m ()
-            -> Excepts es' m ()
-hideExcept' _ =
-  catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
-
-
-reThrowAll :: forall e es es' a m
-            . (Monad m, e :< es')
-           => (V es -> e)
-           -> Excepts es m a
-           -> Excepts es' m a
-reThrowAll f = catchAllE (throwE . f)
-
-
-reThrowAllIO :: forall e es es' a m
-              . (MonadCatch m, Monad m, MonadIO m, e :< es')
-             => (V es -> e)
-             -> (IOException -> e)
-             -> Excepts es m a
-             -> Excepts es' m a
-reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
-
-
-throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
-throwEither a = case a of
-  Left  e -> throwM e
-  Right r -> pure r
-
-
-throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
-throwEither' e eth = case eth of
-  Left  _ -> throwM e
-  Right r -> pure r
-
-throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
-throwMaybe a m = case m of
-  Nothing -> throwM a
-  Just r -> pure r
-
-throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
-throwMaybeM a am = do
-  m <- am
-  throwMaybe a m
-
-
-verToBS :: Version -> ByteString
-verToBS = E.encodeUtf8 . prettyVer
-
-verToS :: Version -> String
-verToS = T.unpack . prettyVer
-
-intToText :: Integral a => a -> T.Text
-intToText = TL.toStrict . B.toLazyText . B.decimal
-
-
-
--- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
--- the Unicode replacement character U+FFFD.
-decUTF8Safe :: ByteString -> Text
-decUTF8Safe = E.decodeUtf8With E.lenientDecode
-
-decUTF8Safe' :: L.ByteString -> Text
-decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-
-
--- | Escape a version for use in regex
-escapeVerRex :: Version -> ByteString
-escapeVerRex = B.pack . go . B.unpack . verToBS
- where
-  go [] = []
-  go (x : xs) | x == _period = [_backslash, _period] ++ go xs
-              | otherwise    = x : go xs
-
-
-
-recover :: (MonadIO m, MonadMask m) => m a -> m a
-recover action = 
-  recovering (fullJitterBackoff 25000 <> limitRetries 10)
-    [\_ -> Handler (\e -> pure $ isPermissionError e)
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
-    ]
-    (\_ -> action)
-
-
--- | Gathering monoidal values
---
--- >>> traverseFold (pure . (:["0"])) ["1","2"]
--- ["1","0","2","0"]
--- >>> traverseFold Just ["1","2","3","4","5"]
--- Just "12345"
---
--- prop> \t -> traverseFold Just t === Just (mconcat t)
-traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
-traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-
--- | Gathering monoidal values
-forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
-forFold = \t -> (`traverseFold` t)
-
-
--- | Strip @\\r@ and @\\n@ from 'String's
---
--- >>> stripNewline "foo\n\n\n"
--- "foo"
--- >>> stripNewline "foo\n\n\nfoo"
--- "foofoo"
--- >>> stripNewline "foo\r"
--- "foo"
--- >>> stripNewline "foo"
--- "foo"
---
--- prop> \t -> stripNewline (t <> "\n") === stripNewline t
--- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
-stripNewline :: String -> String
-stripNewline = filter (`notElem` "\n\r")
-
-
--- | Strip @\\r@ and @\\n@ from end of 'String'.
---
--- >>> stripNewlineEnd "foo\n\n\n"
--- "foo"
--- >>> stripNewlineEnd "foo\n\n\nfoo"
--- "foo\n\n\nfoo"
--- >>> stripNewlineEnd "foo\r"
--- "foo"
--- >>> stripNewlineEnd "foo"
--- "foo"
---
--- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
--- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
-stripNewlineEnd :: String -> String
-stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
-
-
--- | Strip @\\r@ and @\\n@ from 'Text's
---
--- >>> stripNewline' "foo\n\n\n"
--- "foo"
--- >>> stripNewline' "foo\n\n\nfoo"
--- "foofoo"
--- >>> stripNewline' "foo\r"
--- "foo"
--- >>> stripNewline' "foo"
--- "foo"
---
--- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
--- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
-stripNewline' :: T.Text -> T.Text
-stripNewline' = T.filter (`notElem` "\n\r")
-
-
--- | Is the word8 a newline?
---
--- >>> isNewLine (c2w '\n')
--- True
--- >>> isNewLine (c2w '\r')
--- True
---
--- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)
-isNewLine :: Word8 -> Bool
-isNewLine w
-  | w == _lf = True
-  | w == _cr = True
-  | otherwise = False
-
-
--- | Split on a PVP suffix.
---
--- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"
--- ("ghc-iserv-dyn","9.3.20210706")
--- >>> splitOnPVP "-" "ghc-iserv-dyn"
--- ("ghc-iserv-dyn","")
-splitOnPVP :: String -> String -> (String, String)
-splitOnPVP c s = case Split.splitOn c s of
-  []  -> def
-  [_] -> def
-  xs
-    | let l = last xs
-    , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
-    | otherwise -> def
- where
-  def = (s, "")
-
-
-
--- | Like 'find', but where the test can be monadic.
---
--- >>> findM (Just . C.isUpper) "teST"
--- Just (Just 'S')
--- >>> findM (Just . C.isUpper) "test"
--- Just Nothing
--- >>> findM (Just . const True) ["x",undefined]
--- Just (Just "x")
-findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
-findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
-
-
--- | Drops the given suffix from a list.
---   It returns the original sequence if the sequence doesn't end with the given suffix.
---
--- >>> dropSuffix "!" "Hello World!"
--- "Hello World"
--- >>> dropSuffix "!" "Hello World!!"
--- "Hello World!"
--- >>> dropSuffix "!" "Hello World."
--- "Hello World."
-dropSuffix :: Eq a => [a] -> [a] -> [a]
-dropSuffix a b = fromMaybe b $ stripSuffix a b
-
--- | Return the prefix of the second list if its suffix
---   matches the entire first list.
---
--- >>> stripSuffix "bar" "foobar"
--- Just "foo"
--- >>> stripSuffix ""    "baz"
--- Just "baz"
--- >>> stripSuffix "foo" "quux"
--- Nothing
-stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
-stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)
-
-
--- | Drops the given prefix from a list.
---   It returns the original sequence if the sequence doesn't start with the given prefix.
---
--- >>> dropPrefix "Mr. " "Mr. Men"
--- "Men"
--- >>> dropPrefix "Mr. " "Dr. Men"
--- "Dr. Men"
-dropPrefix :: Eq a => [a] -> [a] -> [a]
-dropPrefix a b = fromMaybe b $ stripPrefix a b
-
-
-
--- | Break a list into pieces separated by the first
--- list argument, consuming the delimiter. An empty delimiter is
--- invalid, and will cause an error to be raised.
---
--- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
--- ["a","b","d","e"]
--- >>> splitOn "aaa"  "aaaXaaaXaaaXaaa"
--- ["","X","X","X",""]
--- >>> splitOn "x"    "x"
--- ["",""]
--- >>> splitOn "x"    ""
--- [""]
---
--- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
--- prop> \c x -> splitOn [c] x                           == split (==c) x
-splitOn :: Eq a => [a] -> [a] -> [[a]]
-splitOn [] _ = error "splitOn, needle may not be empty"
-splitOn _ [] = [[]]
-splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b
-    where (a,b) = breakOn needle haystack
-
-
--- | Splits a list into components delimited by separators,
--- where the predicate returns True for a separator element.  The
--- resulting components do not contain the separators.  Two adjacent
--- separators result in an empty component in the output.
---
--- >>> split (== 'a') "aabbaca"
--- ["","","bb","c",""]
--- >>> split (== 'a') ""
--- [""]
--- >>> split (== ':') "::xyz:abc::123::"
--- ["","","xyz","abc","","123","",""]
--- >>> split (== ',') "my,list,here"
--- ["my","list","here"]
-split :: (a -> Bool) -> [a] -> [[a]]
-split _ [] = [[]]
-split f (x:xs)
-  | f x = [] : split f xs
-  | y:ys <- split f xs = (x:y) : ys
-  | otherwise = [[]]
-
-
--- | Find the first instance of @needle@ in @haystack@.
--- The first element of the returned tuple
--- is the prefix of @haystack@ before @needle@ is matched.  The second
--- is the remainder of @haystack@, starting with the match.
--- If you want the remainder /without/ the match, use 'stripInfix'.
---
--- >>> breakOn "::" "a::b::c"
--- ("a","::b::c")
--- >>> breakOn "/" "foobar"
--- ("foobar","")
---
--- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
-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

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

lib/GHCup/Prelude/Posix.hs

@@ -1,19 +1,20 @@
 module GHCup.Prelude.Posix where
 
+import System.Directory
+import System.Posix.Files
 
--- | Enables ANSI support on windows, does nothing on unix.
---
--- Returns 'Left str' on errors and 'Right bool' on success, where
--- 'bool' markes whether ansi support was already enabled.
---
--- This function never crashes.
---
--- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
-enableAnsiSupport :: IO (Either String Bool)
-enableAnsiSupport = pure (Right True)
 
 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/Prelude/Process.hs

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

lib/GHCup/Prelude/Windows.hs

@@ -1,53 +1,17 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE OverloadedStrings     #-}
-
 module GHCup.Prelude.Windows where
 
-
+import qualified System.Win32.File             as Win32
-import           Control.Exception.Safe
-import           Control.Monad
-#if !MIN_VERSION_base(4,13,0)
-import           Control.Monad.Fail             ( MonadFail )
-#endif
-import           Data.Bits
-
-import           System.Win32.Console
-import           System.Win32.File     hiding ( copyFile )
-import           System.Win32.Types
-
-
-
-
--- | Enables ANSI support on windows, does nothing on unix.
---
--- Returns 'Left str' on errors and 'Right bool' on success, where
--- 'bool' markes whether ansi support was already enabled.
---
--- This function never crashes.
---
--- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
-enableAnsiSupport :: IO (Either String Bool)
-enableAnsiSupport = handleIO (pure . Left . displayException) $ do
-  -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
-  -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
-  h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
-    fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
-  when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
-
-  -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
-  m <- getConsoleMode h
-
-  -- VT processing not already enabled?
-  if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
-  -- https://docs.microsoft.com/en-us/windows/console/setconsolemode
-  then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
-    >> pure (Right False)
-  else pure (Right True)
 
 
 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/QQ/String.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 {-|
-Module      : GHCup.Utils.String.QQ
+Module      : GHCup.QQ.String
 Description : String quasi quoters
 Copyright   : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
 License     : LGPL-3.0
@@ -30,7 +30,7 @@ Any instance of the IsString type is permitted.
 (For GHC versions 6, write "[$s||]" instead of "[s||]".)
 
 -}
-module GHCup.Prelude.String.QQ
+module GHCup.QQ.String
   ( s
   )
 where

lib/GHCup/QQ/Version.hs

@@ -4,11 +4,11 @@
 {-# LANGUAGE DeriveLift         #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TemplateHaskell    #-}
 
 
 {-|
-Module      : GHCup.Utils.Version.QQ
+Module      : GHCup.QQ.Version
 Description : Version quasi-quoters
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -16,7 +16,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Prelude.Version.QQ where
+module GHCup.QQ.Version where
 
 import           Data.Data
 import           Data.Text                      ( Text )

lib/GHCup/Requirements.hs

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

lib/GHCup/Stack.hs

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

lib/GHCup/System/Console.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+
+module GHCup.System.Console (
+#if IS_WINDOWS
+  module GHCup.System.Console.Windows
+#else
+  module GHCup.System.Console.Posix
+#endif
+) where
+
+
+#if IS_WINDOWS
+import GHCup.System.Console.Windows
+#else
+import GHCup.System.Console.Posix
+#endif

lib/GHCup/System/Console/Posix.hs

@@ -0,0 +1,14 @@
+module GHCup.System.Console.Posix where
+
+
+-- | Enables ANSI support on windows, does nothing on unix.
+--
+-- Returns 'Left str' on errors and 'Right bool' on success, where
+-- 'bool' markes whether ansi support was already enabled.
+--
+-- This function never crashes.
+--
+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
+enableAnsiSupport :: IO (Either String Bool)
+enableAnsiSupport = pure (Right True)
+

lib/GHCup/System/Console/Windows.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module GHCup.System.Console.Windows where
+
+
+import           Control.Exception.Safe
+import           Control.Monad
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Data.Bits
+
+import           System.Win32.Console
+import           System.Win32.File     hiding ( copyFile )
+import           System.Win32.Types
+
+
+
+
+-- | Enables ANSI support on windows, does nothing on unix.
+--
+-- Returns 'Left str' on errors and 'Right bool' on success, where
+-- 'bool' markes whether ansi support was already enabled.
+--
+-- This function never crashes.
+--
+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
+enableAnsiSupport :: IO (Either String Bool)
+enableAnsiSupport = handleIO (pure . Left . displayException) $ do
+  -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
+  -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
+  h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
+    fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
+  when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
+
+  -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
+  m <- getConsoleMode h
+
+  -- VT processing not already enabled?
+  if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
+  -- https://docs.microsoft.com/en-us/windows/console/setconsolemode
+  then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
+    >> pure (Right False)
+  else pure (Right True)
+

lib/GHCup/System/Directory.hs

@@ -1,33 +1,26 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
 
-module GHCup.Prelude.File.Search (
+module GHCup.System.Directory where
-  module GHCup.Prelude.File.Search
-  , ProcessError(..)
-  , CapturedProcess(..)
-  ) where
 
-import           GHCup.Types(ProcessError(..), CapturedProcess(..))
+import           GHCup.Prelude
 
 import           Control.Monad.Reader
 import           Data.Maybe
 import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
-import           System.Directory hiding ( removeDirectory
+import           System.Directory
-                                         , removeDirectoryRecursive
-                                         , removePathForcibly
-                                         , findFiles
-                                         )
 import           System.FilePath
 import           Text.Regex.Posix
 
-
 import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
-import Control.Exception.Safe (handleIO)
+
-import System.Directory.Internal.Prelude (ioeGetErrorType)
+
+
 
 
 
@@ -39,7 +32,7 @@ searchPath paths needle = go paths
  where
   go [] = pure Nothing
   go (x : xs) =
-    handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e)
+    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
       $ do
           contents <- listDirectory x
           findM (isMatch x) contents >>= \case
@@ -53,12 +46,6 @@ 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.
@@ -86,26 +73,15 @@ isInPath p = do
   else pure False
 
 
--- | Follows the first match in case of Regex.
-expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
-expandFilePath = go ""
- where
-  go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]
-  go p [] = pure [p]
-  go p (x:xs) = do
-    case x of
-      Left s -> go (p </> s) xs
-      Right regex -> do
-        fps <- findFiles p regex
-        res <- forM fps $ \fp -> go (p </> fp) xs
-        pure $ mconcat res
-
-
 findFiles :: FilePath -> Regex -> IO [FilePath]
 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
@@ -113,3 +89,5 @@ 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/System/Directory.hs-boot

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

lib/GHCup/System/Process.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+
+module GHCup.System.Process (
+  module GHCup.System.Process.Common,
+#if IS_WINDOWS
+  module GHCup.System.Process.Windows
+#else
+  module GHCup.System.Process.Posix
+#endif
+) where
+
+
+#if IS_WINDOWS
+import GHCup.System.Process.Windows
+#else
+import GHCup.System.Process.Posix
+#endif
+
+import GHCup.System.Process.Common

lib/GHCup/System/Process/Common.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell  #-}
+
+module GHCup.System.Process.Common where
+
+
+import           GHC.IO.Exception
+import           Optics                  hiding ((<|), (|>))
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+
+import qualified Data.ByteString.Lazy          as BL
+
+
+
+data ProcessError = NonZeroExit Int FilePath [String]
+                  | PTerminated FilePath [String]
+                  | PStopped FilePath [String]
+                  | NoSuchPid FilePath [String]
+                  deriving Show
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
+  pPrint (PTerminated exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
+  pPrint (PStopped exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
+  pPrint (NoSuchPid exe args) =
+    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: BL.ByteString
+  , _stdErr   :: BL.ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess

lib/GHCup/System/Process/Posix.hs

@@ -1,31 +1,29 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE DataKinds  #-}
-{-# LANGUAGE MultiWayIf  #-}
-{-# LANGUAGE CApiFFI #-}
 
 {-|
-Module      : GHCup.Utils.File.Posix
+Module      : GHCup.System.Process.Posix
-Description : Process handling for unix
+Description : File and unix APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : POSIX
--}
-module GHCup.Prelude.Process.Posix where
 
-import           GHCup.Utils.Dirs
+This module handles file and executable handling.
-import           GHCup.Prelude.File
+Some of these functions use sophisticated logging.
-import           GHCup.Prelude.File.Posix
+-}
+module GHCup.System.Process.Posix where
+
 import           GHCup.Prelude
-import           GHCup.Prelude.Logger
+import           GHCup.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
-import qualified Control.Exception              as E
+import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.Reader
@@ -37,10 +35,12 @@ import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
 import           GHC.IO.Exception
-import           System.IO                      ( stderr )
+import           System.Console.Terminal.Common
-import           System.IO.Error      hiding    ( catchIOError )
+import           System.IO.Error
 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
@@ -51,7 +51,7 @@ import qualified Data.Sequence                 as Sq
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified System.Posix.Process          as SPP
-import qualified System.Console.Terminal.Size  as TP
+import qualified System.Console.Terminal.Posix as TP
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified "unix-bytestring" System.Posix.IO.ByteString
@@ -73,7 +73,6 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
 
 execLogged :: ( MonadReader env m
               , HasSettings env
-              , HasLog env
               , HasDirs env
               , MonadIO m
               , MonadThrow m)
@@ -86,8 +85,7 @@ execLogged :: ( MonadReader env m
 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)
@@ -143,14 +141,14 @@ execLogged exe args chdir lfile env = do
   printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
   printToRegion fileFd fdIn size pState no_color = do
     -- init region
-    forM_ [1..size] $ \_ -> BS.hPut stderr "\n"
+    forM_ [1..size] $ \_ -> BS.putStr "\n"
 
     void $ flip runStateT mempty
       $ do
         handle
           (\(ex :: SomeException) -> do
             ps <- liftIO $ takeMVar pState
-            when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))
+            when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen))
             throw ex
           ) $ readTilEOF lineAction fdIn
 
@@ -182,10 +180,10 @@ execLogged exe args chdir lfile env = do
       modify (swapRegs bs')
       liftIO TP.size >>= \case
         Nothing -> pure ()
-        Just (TP.Window _ w) -> do
+        Just (Window _ w) -> do
           regs <- get
           liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
-              BS.hPut stderr
+              BS.putStr
               . overwriteNthLine (size - i)
               . trim w
               . blue
@@ -262,7 +260,7 @@ captureOutStreams action = do
 
         -- execute the action
         a <- action
-        void $ E.evaluate a
+        void $ evaluate a
 
       -- close everything we don't need
       closeFd childStdoutWrite
@@ -360,3 +358,42 @@ 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/System/Process/Windows.hs

@@ -1,23 +1,26 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE DataKinds  #-}
 
 {-|
-Module      : GHCup.Utils.Process.Windows
+Module      : GHCup.System.Process.Windows
-Description : Process handling for windows
+Description : File and windows APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : Windows
--}
-module GHCup.Prelude.Process.Windows where
 
-import           GHCup.Utils.Dirs
+This module handles file and executable handling.
-import           GHCup.Prelude.File.Search
+Some of these functions use sophisticated logging.
-import           GHCup.Prelude.Logger.Internal
+-}
+module GHCup.System.Process.Windows where
+
+import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
+import           GHCup.Directories
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.System.Directory
+import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.DeepSeq
@@ -28,17 +31,16 @@ 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
 import qualified Data.Map.Strict               as Map
-import qualified Data.Text                     as T
-
 
 
 
@@ -148,7 +150,6 @@ executeOut path args chdir = do
 
 execLogged :: ( MonadReader env m
               , HasDirs env
-              , HasLog env
               , HasSettings env
               , MonadIO m
               , MonadThrow m)
@@ -160,9 +161,8 @@ execLogged :: ( MonadReader env m
            -> m (Either ProcessError ())
 execLogged exe args chdir lfile env = do
   Dirs {..} <- getDirs
-  logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
+  let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
-  let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
+      stderrLogfile = logsDir </> lfile <> ".stderr.log"
-      stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
   cp <- createProcessWithMingwPath ((proc exe args)
     { cwd = chdir
     , env = env
@@ -193,10 +193,9 @@ execLogged exe args chdir lfile env = do
           then pure ()
           else do
             void $ BS.appendFile logFile some
-            -- subprocess stdout also goes to stderr for logging
+            void $ BS.hPut stdout some
-            void $ BS.hPut stderr some
             go
-
+        
 
 -- | Thin wrapper around `executeFile`.
 exec :: MonadIO m
@@ -225,15 +224,20 @@ 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 </> "mingw64" </> "bin"
+  let mingWPaths = [msys2Dir </> "usr" </> "bin"
-                   ,msys2Dir </> "usr" </> "bin"
+                   ,msys2Dir </> "mingw64" </> "bin"]
-                   ]
       paths = ["PATH", "Path"]
       curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
       newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
@@ -248,5 +252,16 @@ ghcupMsys2Dir =
     Just fp -> pure fp
     Nothing -> do
       baseDir <- liftIO ghcupBaseDir
-      pure (fromGHCupPath baseDir </> "msys64")
+      pure (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/Types.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 {-|
@@ -26,22 +25,17 @@ 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 (..) )
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           GHC.IO.Exception               ( ExitCode )
+import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
-import           Optics                         ( makeLenses )
-import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
 import           URI.ByteString
 #if defined(BRICK)
 import           Graphics.Vty                   ( Key(..) )
 #endif
 
-import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Text                     as T
 import qualified GHC.Generics                  as GHC
 
@@ -288,9 +282,9 @@ instance Pretty TarDir where
 
 -- | Where to fetch GHCupDownloads from.
 data URLSource = GHCupURL
-               | OwnSource [Either GHCupInfo URI] -- ^ complete source list
+               | OwnSource URI
                | OwnSpec GHCupInfo
-               | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
+               | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
                deriving (GHC.Generic, Show)
 
 instance NFData URLSource
@@ -440,14 +434,12 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
 instance NFData Settings
 
 data Dirs = Dirs
-  { baseDir    :: GHCupPath
+  { baseDir  :: FilePath
-  , binDir     :: FilePath
+  , binDir   :: FilePath
-  , cacheDir   :: GHCupPath
+  , cacheDir :: FilePath
-  , logsDir    :: GHCupPath
+  , logsDir  :: FilePath
-  , confDir    :: GHCupPath
+  , confDir  :: FilePath
-  , dbDir      :: GHCupPath
+  , recycleDir :: FilePath -- mainly used on windows
-  , recycleDir :: GHCupPath -- mainly used on windows
-  , tmpDir     :: GHCupPath
   }
   deriving (Show, GHC.Generic)
 
@@ -492,10 +484,6 @@ data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
             | SetGHC_XYZ  -- ^ ghc-x.y.z
             deriving (Eq, Show)
 
-data SetHLS = SetHLSOnly  -- ^ unversioned 'hls'
-            | SetHLS_XYZ  -- ^ haskell-language-server-a.b.c~x.y.z, where a.b.c is GHC version and x.y.z is HLS version
-            deriving (Eq, Show)
-
 
 data PlatformResult = PlatformResult
   { _platform      :: Platform
@@ -608,56 +596,3 @@ data LoggerConfig = LoggerConfig
 
 instance NFData LoggerConfig where
   rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)
-
-data ProcessError = NonZeroExit Int FilePath [String]
-                  | PTerminated FilePath [String]
-                  | PStopped FilePath [String]
-                  | NoSuchPid FilePath [String]
-                  deriving Show
-
-instance Pretty ProcessError where
-  pPrint (NonZeroExit e exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
-  pPrint (PTerminated exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
-  pPrint (PStopped exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
-  pPrint (NoSuchPid exe args) =
-    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
-data CapturedProcess = CapturedProcess
-  { _exitCode :: ExitCode
-  , _stdOut   :: BL.ByteString
-  , _stdErr   :: BL.ByteString
-  }
-  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

@@ -22,8 +22,10 @@ Portability : portable
 module GHCup.Types.JSON where
 
 import           GHCup.Types
-import           GHCup.Types.JSON.Utils
+import           GHCup.MegaParsec
-import           GHCup.Prelude.MegaParsec
+import           GHCup.Prelude
+import           GHCup.Logger             () -- TH is broken shite and needs GHCup.Logger for linking, although we don't depend on the file.
+                                                   -- This is due to the boot file.
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)
@@ -38,7 +40,6 @@ import           Text.Casing
 
 import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
-import qualified Data.Text.Encoding.Error      as E
 import qualified Text.Megaparsec               as MP
 import qualified Text.Megaparsec.Char          as MPC
 
@@ -77,8 +78,7 @@ instance FromJSON Tag where
     x -> pure (UnknownTag x)
 
 instance ToJSON URI where
-  toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
+  toJSON = toJSON . decUTF8Safe . serializeURIRef'
-
 
 instance FromJSON URI where
   parseJSON = withText "URL" $ \t ->
@@ -315,43 +315,10 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
-deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
+deriveJSON 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
-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
 
+deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
+deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key

lib/GHCup/Types/JSON/Utils.hs

@@ -1,17 +0,0 @@
-{-|
-Module      : GHCup.Types.JSON.Utils
-Description : Utils for TH splices
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
-
-module GHCup.Types.JSON.Utils where
-
-import qualified Data.Text                     as T
-
-removeLensFieldLabel :: String -> String
-removeLensFieldLabel str' =
-  maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

lib/GHCup/Utils.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE CPP                   #-}
-{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE ViewPatterns          #-}
 
@@ -20,35 +20,37 @@ This module contains GHCup helpers specific to
 installation and introspection of files/versions etc.
 -}
 module GHCup.Utils
-  ( module GHCup.Utils.Dirs
+  ( module GHCup.Directories
   , module GHCup.Utils
 #if defined(IS_WINDOWS)
-  , module GHCup.Prelude.Windows
+  , module GHCup.System.Console.Windows
 #else
-  , module GHCup.Prelude.Posix
+  , module GHCup.System.Console.Posix
 #endif
   )
 where
 
 
 #if defined(IS_WINDOWS)
-import GHCup.Prelude.Windows
+import GHCup.System.Console.Windows
 #else
-import GHCup.Prelude.Posix
+import GHCup.System.Console.Posix
 #endif
+import {-# SOURCE #-} GHCup.GHC.Common
+import {-# SOURCE #-} GHCup.GHC.Set
+import           GHCup.Data.Versions
 import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
-import           GHCup.Version
+import           GHCup.Logger
+import           GHCup.MegaParsec
 import           GHCup.Prelude
-import           GHCup.Prelude.File
+import           GHCup.QQ.String
-import           GHCup.Prelude.Logger.Internal
+import           GHCup.System.Directory
-import           GHCup.Prelude.MegaParsec
+import           GHCup.System.Process
-import           GHCup.Prelude.Process
-import           GHCup.Prelude.String.QQ
 
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
@@ -69,16 +71,17 @@ import           Data.List
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.Maybe
 import           Data.Text                      ( Text )
-import           Data.Versions         hiding   ( patch )
+import           Data.Versions
 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           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Codec.Compression.BZip        as BZip
 import qualified Codec.Compression.GZip        as GZip
@@ -89,9 +92,6 @@ 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
@@ -109,7 +109,7 @@ import GHC.IO (evaluate)
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
 -- >>> import Optics
--- >>> import GHCup.Prelude.Version.QQ
+-- >>> import GHCup.QQ.Version
 -- >>> import qualified Data.Text.Encoding as E
 -- >>> import Control.Monad.Reader
 -- >>> import Haskus.Utils.Variant.Excepts
@@ -125,218 +125,6 @@ import GHC.IO (evaluate)
 
 
 
-    ------------------------
-    --[ Symlink handling ]--
-    ------------------------
-
-
--- | Create a relative symlink destination for the binary directory,
--- given a target toolpath.
-binarySymLinkDestination :: ( MonadThrow m
-                            , MonadIO m
-                            )
-                         => FilePath -- ^ binary dir
-                         -> FilePath -- ^ the full toolpath
-                         -> m FilePath
-binarySymLinkDestination binDir toolPath = do
-  toolPath' <- liftIO $ canonicalizePath toolPath
-  binDir' <- liftIO $ canonicalizePath binDir
-  pure (relativeSymlink binDir' toolPath')
-
-
--- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
-rmMinorGHCSymlinks :: ( MonadReader env m
-                      , HasDirs env
-                      , MonadIO m
-                      , HasLog env
-                      , MonadThrow m
-                      , MonadFail m
-                      , MonadMask m
-                      )
-                   => GHCTargetVersion
-                   -> Excepts '[NotInstalled] m ()
-rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
-  Dirs {..}  <- lift getDirs
-
-  files                         <- liftE $ ghcToolFiles tv
-  forM_ files $ \f -> do
-    let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
-    let fullF = binDir </> f_xyz
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
-
-
--- | Removes the set ghc version for the given target, if any.
-rmPlainGHC :: ( MonadReader env m
-              , HasDirs env
-              , HasLog env
-              , MonadThrow m
-              , MonadFail m
-              , MonadIO m
-              , MonadMask m
-              )
-           => Maybe Text -- ^ target
-           -> Excepts '[NotInstalled] m ()
-rmPlainGHC target = do
-  Dirs {..}  <- lift getDirs
-  mtv                           <- lift $ ghcSet target
-  forM_ mtv $ \tv -> do
-    files <- liftE $ ghcToolFiles tv
-    forM_ files $ \f -> do
-      let fullF = binDir </> f <> exeExt
-      lift $ logDebug ("rm -f " <> T.pack fullF)
-      lift $ hideError doesNotExistErrorType $ rmLink fullF
-    -- old ghcup
-    let hdc_file = binDir </> "haddock-ghc" <> exeExt
-    lift $ logDebug ("rm -f " <> T.pack hdc_file)
-    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
-
-
--- | Remove the major GHC symlink, e.g. ghc-8.6.
-rmMajorGHCSymlinks :: ( MonadReader env m
-                      , HasDirs env
-                      , MonadIO m
-                      , HasLog env
-                      , MonadThrow m
-                      , MonadFail m
-                      , MonadMask m
-                      )
-                   => GHCTargetVersion
-                   -> Excepts '[NotInstalled] m ()
-rmMajorGHCSymlinks tv@GHCTargetVersion{..} = do
-  Dirs {..}  <- lift getDirs
-  (mj, mi) <- getMajorMinorV _tvVersion
-  let v' = intToText mj <> "." <> intToText mi
-
-  files                         <- liftE $ ghcToolFiles tv
-  forM_ files $ \f -> do
-    let f_xy = f <> "-" <> T.unpack v' <> exeExt
-    let fullF = binDir </> f_xy
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
-
-
--- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'
--- and 'haskell-language-server-wrapper-1.6.1.0'.
-rmMinorHLSSymlinks :: ( MonadReader env m
-                      , HasDirs env
-                      , MonadIO m
-                      , HasLog env
-                      , MonadThrow m
-                      , MonadFail m
-                      , MonadMask m
-                      )
-                   => Version
-                   -> Excepts '[NotInstalled] m ()
-rmMinorHLSSymlinks ver = do
-  Dirs {..}  <- lift getDirs
-
-  hlsBins <- hlsAllBinaries ver
-  forM_ hlsBins $ \f -> do
-    let fullF = binDir </> f
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    -- on unix, this may be either a file (legacy) or a symlink
-    -- on windows, this is always a file... hence 'rmFile'
-    -- works consistently across platforms
-    lift $ rmFile fullF
-
--- | Removes the set HLS version, if any.
-rmPlainHLS :: ( MonadReader env m
-              , HasDirs env
-              , HasLog env
-              , MonadThrow m
-              , MonadFail m
-              , MonadIO m
-              , MonadMask m
-              )
-           => Excepts '[NotInstalled] m ()
-rmPlainHLS = do
-  Dirs {..}  <- lift getDirs
-
-  -- delete 'haskell-language-server-8.10.7'
-  hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f)))
-    $ liftIO $ handleIO (\_ -> pure []) $ findFiles
-      binDir
-      (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
-  forM_ hlsBins $ \f -> do
-    let fullF = binDir </> f
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    if isWindows
-    then lift $ rmLink fullF
-    else lift $ rmFile fullF
-
-  -- 'haskell-language-server-wrapper'
-  let hlswrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
-  lift $ logDebug ("rm -f " <> T.pack hlswrapper)
-  if isWindows
-  then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper
-  else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper
-
-
-
-    -----------------------------------
-    --[ Set/Installed introspection ]--
-    -----------------------------------
-
-
--- | Whether the given GHC versin is installed.
-ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
-ghcInstalled ver = do
-  ghcdir <- ghcupGHCDir ver
-  liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
-
-
--- | Whether the given GHC version is installed from source.
-ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
-ghcSrcInstalled ver = do
-  ghcdir <- ghcupGHCDir ver
-  liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
-
-
--- | Whether the given GHC version is set as the current.
-ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
-       => Maybe Text   -- ^ the target of the GHC version, if any
-                       --  (e.g. armv7-unknown-linux-gnueabihf)
-       -> m (Maybe GHCTargetVersion)
-ghcSet mtarget = do
-  Dirs {..}  <- getDirs
-  let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
-  let ghcBin = binDir </> ghc <> exeExt
-
-  -- link destination is of the form ../ghc/<ver>/bin/ghc
-  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
-  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    link <- liftIO $ getLinkTarget ghcBin
-    Just <$> ghcLinkVersion link
- where
-  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
-  ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
-   where
-    parser =
-        (do
-           _    <- parseUntil1 ghcSubPath
-           _    <- ghcSubPath
-           r    <- parseUntil1 pathSep
-           rest <- MP.getInput
-           MP.setInput r
-           x <- ghcTargetVerP
-           MP.setInput rest
-           pure x
-         )
-        <* MP.some pathSep
-        <* MP.takeRest
-        <* MP.eof
-    ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep
-
--- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
--- If a dir cannot be parsed, returns left.
-getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
-getInstalledGHCs = do
-  ghcdir <- ghcupGHCBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir)
-  forM fs $ \f -> case parseGHCupGHCDir f of
-    Right r -> pure $ Right r
-    Left  _ -> pure $ Left f
 
 
 -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
@@ -404,10 +192,10 @@ cabalSet = do
   cabalParse = MP.chunk "cabal-" *> version'
   -- parses any path component ending with path separator,
   -- e.g. "foo/"
-  stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
+  stripPathComponet = parseUntil1 pathSep *> pathSep
   -- parses an absolute path up until the last path separator,
   -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-  stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
+  stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
   -- parses a relative path up until the last path separator,
   -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
   stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -415,8 +203,7 @@ cabalSet = do
 
 
 -- | Get all installed hls, by matching on
--- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
+-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
--- as well as @~\/.ghcup\/hls\/<\hlsver\>@
 getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
                  => m [Either FilePath Version]
 getInstalledHLSs = do
@@ -427,7 +214,7 @@ getInstalledHLSs = do
                    execBlank
                    ([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
     )
-  legacy <- forM bins $ \f ->
+  forM bins $ \f ->
     case
           version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
       of
@@ -435,14 +222,6 @@ getInstalledHLSs = do
         Just (Left  _) -> pure $ Left f
         Nothing        -> pure $ Left f
 
-  hlsdir <- ghcupHLSBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir)
-  new <- forM fs $ \f -> case parseGHCupHLSDir f of
-    Right r -> pure $ Right r
-    Left  _ -> pure $ Left f
-  pure (nub (new <> legacy))
-
-
 -- | Get all installed stacks, by matching on
 -- @~\/.ghcup\/bin/stack-<\stackver\>@.
 getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
@@ -498,10 +277,10 @@ stackSet = do
     cabalParse = MP.chunk "stack-" *> version'
     -- parses any path component ending with path separator,
     -- e.g. "foo/"
-    stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
+    stripPathComponet = parseUntil1 pathSep *> pathSep
     -- parses an absolute path up until the last path separator,
     -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-    stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
+    stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
     -- parses a relative path up until the last path separator,
     -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
     stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -518,10 +297,6 @@ hlsInstalled ver = do
   vers <- fmap rights getInstalledHLSs
   pure $ elem ver vers
 
-isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
-isLegacyHLS ver = do
-  bdir <- ghcupHLSDir ver
-  not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir)
 
 
 -- Return the currently set hls version, if any.
@@ -549,10 +324,10 @@ hlsSet = do
     cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
     -- parses any path component ending with path separator,
     -- e.g. "foo/"
-    stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
+    stripPathComponet = parseUntil1 pathSep *> pathSep
     -- parses an absolute path up until the last path separator,
     -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-    stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
+    stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
     -- parses a relative path up until the last path separator,
     -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
     stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -593,7 +368,7 @@ hlsGHCVersions' v' = do
   pure . sortBy (flip compare) . rights $ vers
 
 
--- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
+-- | Get all server binaries for an hls version, if any.
 hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
                   => Version
                   -> Maybe Version   -- ^ optional GHC version
@@ -614,44 +389,6 @@ hlsServerBinaries ver mghcVer = do
       )
     )
 
--- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
--- Returns the full path.
-hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
-                          => Version
-                          -> Maybe Version   -- ^ optional GHC version
-                          -> m [FilePath]
-hlsInternalServerScripts ver mghcVer = do
-  dir <- ghcupHLSDir ver
-  let bdir = fromGHCupPath dir </> "bin"
-  fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
-    <$> liftIO (listDirectory bdir)
-
--- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.
--- Returns the full path.
-hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
-                          => Version
-                          -> Maybe Version   -- ^ optional GHC version
-                          -> m [FilePath]
-hlsInternalServerBinaries ver mghcVer = do
-  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)
-    <$> liftIO (listDirectory bdir)
-
--- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/
--- directory, if any.
--- Returns the full path.
-hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
-                      => Version
-                      -> Version   -- ^ GHC version
-                      -> m [FilePath]
-hlsInternalServerLibs ver ghcVer = do
-  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)
-
 
 -- | Get the wrapper binary for an hls version, if any.
 hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
@@ -682,82 +419,25 @@ hlsAllBinaries ver = do
   pure (maybeToList wrapper ++ hls)
 
 
+-- | Get the active symlinks for hls.
+hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
+hlsSymlinks = do
+  Dirs {..}  <- getDirs
+  oldSyms                       <- liftIO $ handleIO (\_ -> pure []) $ findFiles
+    binDir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^haskell-language-server-.*$|] :: ByteString)
+    )
+  filterM
+    ( liftIO
+    . pathIsLink
+    . (binDir </>)
+    )
+    oldSyms
 
 
 
-    -----------------------------------------
-    --[ Major version introspection (X.Y) ]--
-    -----------------------------------------
-
-
--- | Extract (major, minor) from any version.
-getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
-getMajorMinorV Version {..} = case _vChunks of
-  ((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
-  _ -> throwM $ ParseError "Could not parse X.Y from version"
-
-
-matchMajor :: Version -> Int -> Int -> Bool
-matchMajor v' major' minor' = case getMajorMinorV v' of
-  Just (x, y) -> x == major' && y == minor'
-  Nothing     -> False
-
--- | Match PVP prefix.
---
--- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
--- True
--- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
--- True
--- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
--- False
--- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
--- True
-matchPVPrefix :: PVP -> PVP -> Bool
-matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
-
-toL :: PVP -> [Int]
-toL (PVP inner) = fmap fromIntegral $ NE.toList inner
-
-
--- | Get the latest installed full GHC version that satisfies the given (possibly partial)
--- PVP version.
-getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
-             => PVP
-             -> Maybe Text -- ^ the target triple
-             -> m (Maybe GHCTargetVersion)
-getGHCForPVP pvpIn mt = do
-  ghcs <- rights <$> getInstalledGHCs
-  -- we're permissive here... failed parse just means we have no match anyway
-  let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
-        (pvp_, rest) <- versionToPVP _tvVersion
-        pure (pvp_, rest, _tvTarget)
-
-  getGHCForPVP' pvpIn ghcs' mt
-
--- | Like 'getGHCForPVP', except with explicit input parameter.
---
--- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
--- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
--- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
--- "Just 8.8.4"
--- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
--- "Just 8.10.4"
-getGHCForPVP' :: MonadThrow m
-             => PVP
-             -> [(PVP, Text, Maybe Text)] -- ^ installed GHCs
-             -> Maybe Text          -- ^ the target triple
-             -> m (Maybe GHCTargetVersion)
-getGHCForPVP' pvpIn ghcs' mt = do
-  let mResult = lastMay
-                  . sortBy (\(x, _, _) (y, _, _) -> compare x y)
-                  . filter
-                      (\(pvp_, _, target) ->
-                        target == mt && matchPVPrefix pvp_ pvpIn
-                      )
-                  $ ghcs'
-  forM mResult $ \(pvp_, rest, target) -> do
-    ver' <- pvpToVersion pvp_ rest
-    pure (GHCTargetVersion target ver')
 
 
 -- | Get the latest available ghc for the given PVP version, which
@@ -812,7 +492,7 @@ unpackToDir dfp av = do
       (untar . GZip.decompress =<< rf av)
     | ".tar.xz" `isSuffixOf` fn -> do
       filecontents <- liftE $ rf av
-      let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents
+      let decompressed = Lzma.decompress filecontents
       liftE $ untar decompressed
     | ".tar.bz2" `isSuffixOf` fn ->
       liftE (untar . BZip.decompress =<< rf av)
@@ -841,7 +521,7 @@ getArchiveFiles av = do
       (entries . GZip.decompress =<< rf av)
     | ".tar.xz" `isSuffixOf` fn -> do
       filecontents <- liftE $ rf av
-      let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents
+      let decompressed = Lzma.decompress filecontents
       liftE $ entries decompressed
     | ".tar.bz2" `isSuffixOf` fn ->
       liftE (entries . BZip.decompress =<< rf av)
@@ -851,21 +531,21 @@ getArchiveFiles av = do
 
 
 intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
-           => GHCupPath       -- ^ unpacked tar dir
+           => FilePath       -- ^ unpacked tar dir
            -> TarDir         -- ^ how to descend
-           -> Excepts '[TarDirDoesNotExist] m GHCupPath
+           -> Excepts '[TarDirDoesNotExist] m FilePath
 intoSubdir bdir tardir = case tardir of
   RealDir pr -> do
-    whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr))
+    whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
           (throwE $ TarDirDoesNotExist tardir)
-    pure (bdir `appendGHCupPath` pr)
+    pure (bdir </> pr)
   RegexDir r -> do
     let rs = split (`elem` pathSeparators) r
     foldlM
       (\y x ->
-        (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
+        (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
           []      -> throwE $ TarDirDoesNotExist tardir
-          (p : _) -> pure (y `appendGHCupPath` p)) . sort
+          (p : _) -> pure (y </> p)) . sort
       )
       bdir
       rs
@@ -906,48 +586,8 @@ getLatestBaseVersion av pvpVer =
     --[ Other ]--
     -------------
 
--- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
-ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
-                  => GHCTargetVersion
-                  -> m FilePath
-ghcInternalBinDir ver = do
-  ghcdir <- fromGHCupPath <$> ghcupGHCDir ver
-  pure (ghcdir </> "bin")
 
 
--- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@
--- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
---
--- Returns unversioned relative files without extension, e.g.:
---
---   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
-ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
-             => GHCTargetVersion
-             -> Excepts '[NotInstalled] m [FilePath]
-ghcToolFiles ver = do
-  bindir <- ghcInternalBinDir ver
-
-  -- fail if ghc is not installed
-  whenM (fmap not $ ghcInstalled ver)
-        (throwE (NotInstalled GHC ver))
-
-  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
-  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
-
- where
-
-  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
-  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
-
-  getUniqueTools :: [[(FilePath, String)]] -> [String]
-  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
-
-  blackListedTools :: [String]
-  blackListedTools = ["haddock-ghc"]
-
-  isNotAnyInfix :: [String] -> String -> Bool
-  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
 -- this GHC was built from source. It contains the build config.
@@ -960,7 +600,6 @@ make :: ( MonadThrow m
         , MonadIO m
         , MonadReader env m
         , HasDirs env
-        , HasLog env
         , HasSettings env
         )
      => [String]
@@ -983,65 +622,28 @@ makeOut args workdir = do
   executeOut mymake args workdir
 
 
--- | Try to apply patches in order. The order is determined by
+-- | Try to apply patches in order. Fails with 'PatchFailed'
--- a quilt series file (in the patch directory) if one exists,
+-- on first failure.
--- else the patches are applied in lexicographical order.
--- Fails with 'PatchFailed' on first failure.
 applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
              => FilePath   -- ^ dir containing patches
              -> FilePath   -- ^ dir to apply patches in
              -> Excepts '[PatchFailed] m ()
 applyPatches pdir ddir = do
-  let lexicographical = (fmap . fmap) (pdir </>) $ sort <$> findFiles
+  patches <- (fmap . fmap) (pdir </>) $ liftIO $ findFiles
-        pdir
+      pdir
-        (makeRegexOpts compExtended
+      (makeRegexOpts compExtended
-                       execBlank
+                     execBlank
-                       ([s|.+\.(patch|diff)$|] :: ByteString)
+                     ([s|.+\.(patch|diff)$|] :: ByteString)
-        )
+      )
-  let quilt = map (pdir </>) . lines <$> readFile (pdir </> "series")
+  forM_ (sort patches) $ \patch' -> do
-
+    lift $ logInfo $ "Applying patch " <> T.pack patch'
-  patches <- liftIO $ quilt `catchIO` (\e ->
+    fmap (either (const Nothing) Just)
-    if isDoesNotExistError e || isPermissionError e then
+         (exec
-      lexicographical 
+           "patch"
-    else throwIO e)
+           ["-p1", "-i", patch']
-  forM_ patches $ \patch' -> applyPatch patch' ddir
+           (Just ddir)
-
+           Nothing)
-
+      !? PatchFailed
-applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
-           => FilePath   -- ^ Patch
-           -> FilePath   -- ^ dir to apply patches in
-           -> Excepts '[PatchFailed] m ()
-applyPatch patch ddir = do
-  lift $ logInfo $ "Applying patch " <> T.pack patch
-  fmap (either (const Nothing) Just)
-       (exec
-         "patch"
-         ["-p1", "-s", "-f", "-i", patch]
-         (Just ddir)
-         Nothing)
-    !? 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
@@ -1057,8 +659,6 @@ 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
@@ -1069,6 +669,7 @@ 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
@@ -1079,12 +680,15 @@ runBuildAction :: ( MonadReader env m
                   , MonadFail m
                   , MonadCatch m
                   )
-               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
+               -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts e m a
-runBuildAction bdir action = do
+runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
+        forM_ instdir $ \dir ->
+          hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
           $ rmBDir bdir
   v <-
@@ -1106,7 +710,7 @@ cleanUpOnError :: ( MonadReader env m
                   , MonadFail m
                   , MonadCatch m
                   )
-               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
                -> Excepts e m a
                -> Excepts e m a
 cleanUpOnError bdir action = do
@@ -1115,33 +719,13 @@ 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) => GHCupPath -> m ()
+rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
 rmBDir dir = withRunInIO (\run -> run $
            liftIO $ handleIO (\e -> run $ logWarn $
-               "Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e))
+               "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
            $ hideError doesNotExistErrorType
            $ rmPathForcibly dir)
 
@@ -1159,6 +743,97 @@ getVersionInfo v' tool =
     )
 
 
+-- | The file extension for executables.
+exeExt :: String
+exeExt
+  | isWindows = ".exe"
+  | otherwise = ""
+
+-- | The file extension for executables.
+exeExt' :: ByteString
+exeExt'
+  | isWindows = ".exe"
+  | otherwise = ""
+
+
+
+
+-- | On unix, we can use symlinks, so we just get the
+-- symbolic link target.
+--
+-- On windows, we have to emulate symlinks via shims,
+-- see 'createLink'.
+getLinkTarget :: FilePath -> IO FilePath
+getLinkTarget fp
+  | isWindows = do
+      content <- readFile (dropExtension fp <.> "shim")
+      [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
+      pure $ stripNewline $ dropPrefix "path = " p
+  | otherwise = getSymbolicLinkTarget fp
+
+
+-- | Checks whether the path is a link.
+pathIsLink :: FilePath -> IO Bool
+pathIsLink fp
+  | isWindows = doesPathExist (dropExtension fp <.> "shim")
+  | otherwise = pathIsSymbolicLink fp
+
+
+rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
+rmLink fp
+  | isWindows = do
+      hideError doesNotExistErrorType . recycleFile $ fp
+      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
+  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp
+
+
+-- | Creates a symbolic link on unix and a fake symlink on windows for
+-- executables, which:
+--     1. is a shim exe
+--     2. has a corresponding .shim file in the same directory that
+--        contains the target
+--
+-- This overwrites previously existing files.
+--
+-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
+createLink :: ( MonadMask m
+              , MonadThrow m
+              , HasLog env
+              , MonadIO m
+              , MonadReader env m
+              , HasDirs env
+              , MonadUnliftIO m
+              , MonadFail m
+              )
+           => FilePath      -- ^ path to the target executable
+           -> FilePath      -- ^ path to be created
+           -> m ()
+createLink link exe
+  | isWindows = do
+      dirs <- getDirs
+      let shimGen = cacheDir dirs </> "gs.exe"
+
+      let shim = dropExtension exe <.> "shim"
+          -- For hardlinks, link needs to be absolute.
+          -- If link is relative, it's relative to the target exe.
+          -- Note that (</>) drops lhs when rhs is absolute.
+          fullLink = takeDirectory exe </> link
+          shimContents = "path = " <> fullLink
+
+      logDebug $ "rm -f " <> T.pack exe
+      rmLink exe
+
+      logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
+      liftIO $ copyFile shimGen exe
+      liftIO $ writeFile shim shimContents
+  | otherwise = do
+      logDebug $ "rm -f " <> T.pack exe
+      hideError doesNotExistErrorType $ recycleFile exe
+
+      logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
+      liftIO $ createFileLink link exe
+
+
 ensureGlobalTools :: ( MonadMask m
                      , MonadThrow m
                      , HasLog env
@@ -1180,8 +855,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 (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
+          lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
-          lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
+          lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
           liftE @'[GPGError, DigestError , DownloadFailed] $ dl
         ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
   | otherwise = pure ()
@@ -1189,66 +864,29 @@ ensureGlobalTools
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
-  createDirRecursive' (fromGHCupPath baseDir)
+  createDirRecursive' baseDir
-  createDirRecursive' (fromGHCupPath baseDir </> "ghc")
+  createDirRecursive' (baseDir </> "ghc")
-  createDirRecursive' (fromGHCupPath baseDir </> "hls")
   createDirRecursive' binDir
-  createDirRecursive' (fromGHCupPath cacheDir)
+  createDirRecursive' cacheDir
-  createDirRecursive' (fromGHCupPath logsDir)
+  createDirRecursive' logsDir
-  createDirRecursive' (fromGHCupPath confDir)
+  createDirRecursive' confDir
-  createDirRecursive' (fromGHCupPath trashDir)
+  createDirRecursive' trashDir
-  createDirRecursive' (fromGHCupPath dbDir)
-  createDirRecursive' (fromGHCupPath tmpDir)
   pure ()
 
 
 -- | For ghc without arch triple, this is:
 --
---    - ghc
+--    - ghc-<ver> (e.g. ghc-8.10.4)
 --
 -- For ghc with arch triple:
 --
---    - <triple>-ghc (e.g. arm-linux-gnueabihf-ghc)
+--    - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)
 ghcBinaryName :: GHCTargetVersion -> String
-ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)
+ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
-ghcBinaryName (GHCTargetVersion Nothing  _) = T.unpack ("ghc" <> T.pack exeExt)
+ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
 
 
--- | Does basic checks for isolated installs
--- Isolated Directory:
---   1. if it doesn't exist -> proceed
---   2. if it exists and is empty -> proceed
---   3. if it exists and is non-empty -> panic and leave the house
-installDestSanityCheck :: ( MonadIO m
-                          , MonadCatch m
-                          , MonadMask m
-                          ) =>
-                          InstallDirResolved ->
-                          Excepts '[DirNotEmpty] m ()
-installDestSanityCheck (IsolateDirResolved isoDir) = do
-  hideErrorDef [doesNotExistErrorType] () $ do
-    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.
@@ -1273,5 +911,7 @@ warnAboutHlsCompatibility = do
         "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 ()
+
+

lib/GHCup/Utils.hs-boot

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

lib/GHCup/Utils/Dirs.hs

@@ -1,539 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE ViewPatterns          #-}
-{-# LANGUAGE QuasiQuotes           #-}
-
-{-|
-Module      : GHCup.Utils.Dirs
-Description : Definition of GHCup directories
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
-module GHCup.Utils.Dirs
-  ( getAllDirs
-  , ghcupBaseDir
-  , ghcupConfigFile
-  , ghcupCacheDir
-  , ghcupGHCBaseDir
-  , ghcupGHCDir
-  , ghcupHLSBaseDir
-  , ghcupHLSDir
-  , mkGhcupTmpDir
-  , parseGHCupGHCDir
-  , parseGHCupHLSDir
-  , relativeSymlink
-  , withGHCupTmpDir
-  , 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
-
-
-import           GHCup.Errors
-import           GHCup.Types
-import           GHCup.Types.JSON               ( )
-import           GHCup.Types.Optics
-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           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 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 ]--
-    ------------------------------
-
-
--- | ~/.ghcup by default
---
--- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
-ghcupBaseDir :: IO GHCupPath
-ghcupBaseDir
-  | isWindows = do
-      bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
-      pure (GHCupPath (bdir </> "ghcup"))
-  | otherwise = do
-      xdg <- useXDG
-      if xdg
-        then do
-          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
-            Just r  -> pure r
-            Nothing -> do
-              home <- liftIO getHomeDirectory
-              pure (home </> ".local" </> "share")
-          pure (GHCupPath (bdir </> "ghcup"))
-        else do
-          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-            Just r  -> pure r
-            Nothing -> liftIO getHomeDirectory
-          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 GHCupPath
-ghcupConfigDir
-  | isWindows = ghcupBaseDir
-  | otherwise = do
-      xdg <- useXDG
-      if xdg
-        then do
-          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
-            Just r  -> pure r
-            Nothing -> do
-              home <- liftIO getHomeDirectory
-              pure (home </> ".config")
-          pure (GHCupPath (bdir </> "ghcup"))
-        else do
-          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-            Just r  -> pure r
-            Nothing -> liftIO getHomeDirectory
-          pure (GHCupPath (bdir </> ".ghcup"))
-
-
--- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
--- (which, sadly is not strictly xdg spec).
-ghcupBinDir :: IO FilePath
-ghcupBinDir
-  | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
-  | otherwise = do
-      xdg <- useXDG
-      if xdg
-        then do
-          lookupEnv "XDG_BIN_HOME" >>= \case
-            Just r  -> pure r
-            Nothing -> do
-              home <- liftIO getHomeDirectory
-              pure (home </> ".local" </> "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 GHCupPath
-ghcupCacheDir
-  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
-  | 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"))
-        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 GHCupPath
-ghcupLogsDir
-  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
-  | 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" </> "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 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
-  baseDir    <- ghcupBaseDir
-  binDir     <- ghcupBinDir
-  cacheDir   <- ghcupCacheDir
-  logsDir    <- ghcupLogsDir
-  confDir    <- ghcupConfigDir
-  recycleDir <- ghcupRecycleDir
-  tmpDir     <- ghcupTMPDir
-  dbDir      <- ghcupDbDir
-  pure Dirs { .. }
-
-
-
-    -------------------
-    --[ GHCup files ]--
-    -------------------
-
-getConfigFilePath :: (MonadIO m) => m FilePath
-getConfigFilePath = do
-  confDir <- liftIO ghcupConfigDir
-  pure $ fromGHCupPath confDir </> "config.yaml"
-
-ghcupConfigFile :: (MonadIO m)
-                => Excepts '[JSONError] m UserSettings
-ghcupConfigFile = do
-  filepath <- getConfigFilePath
-  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' -> liftE
-        . veitherToExcepts @_ @'[JSONError]
-        . either (VLeft . V) VRight
-        . first (JSONDecodeError . displayException)
-        . Y.decodeEither'
-        $ contents'
-
-
-    -------------------------
-    --[ GHCup directories ]--
-    -------------------------
-
-
--- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
-ghcupGHCBaseDir = do
-  Dirs {..}  <- getDirs
-  pure (baseDir `appendGHCupPath` "ghc")
-
-
--- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
--- The dir may be of the form
---   * armv7-unknown-linux-gnueabihf-8.8.3
---   * 8.8.4
-ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
-            => GHCTargetVersion
-            -> m GHCupPath
-ghcupGHCDir ver = do
-  ghcbasedir <- ghcupGHCBaseDir
-  let verdir = T.unpack $ tVerToText ver
-  pure (ghcbasedir `appendGHCupPath` verdir)
-
-
--- | See 'ghcupToolParser'.
-parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
-parseGHCupGHCDir (T.pack -> fp) =
-  throwEither $ MP.parse ghcTargetVerP "" fp
-
-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 GHCupPath
-ghcupHLSBaseDir = do
-  Dirs {..}  <- getDirs
-  pure (baseDir `appendGHCupPath` "hls")
-
--- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
-ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
-            => Version
-            -> m GHCupPath
-ghcupHLSDir ver = do
-  basedir <- ghcupHLSBaseDir
-  let verdir = T.unpack $ prettyVer ver
-  pure (basedir `appendGHCupPath` verdir)
-
-
-mkGhcupTmpDir :: ( MonadReader env m
-                 , HasDirs env
-                 , MonadUnliftIO m
-                 , HasLog env
-                 , MonadCatch m
-                 , MonadThrow m
-                 , MonadMask m
-                 , MonadIO m)
-              => m GHCupPath
-mkGhcupTmpDir = GHCupPath <$> do
-  Dirs { tmpDir } <- getDirs
-  liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
-
-
-withGHCupTmpDir :: ( MonadReader env m
-                   , HasDirs env
-                   , HasLog env
-                   , HasSettings env
-                   , MonadUnliftIO m
-                   , MonadCatch m
-                   , MonadResource m
-                   , MonadThrow m
-                   , MonadMask m
-                   , MonadIO m)
-                => m GHCupPath
-withGHCupTmpDir = snd <$> withRunInIO (\run ->
-  run
-    $ allocate
-        (run mkGhcupTmpDir)
-        (\fp ->
-            handleIO (\e -> run
-                $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
-            . removePathForcibly
-            $ fp))
-
-
-
-
-    --------------
-    --[ Others ]--
-    --------------
-
-
-useXDG :: IO Bool
-useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
-
-
--- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks.
-relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
-                -> FilePath  -- ^ the symlink destination
-                -> FilePath
-relativeSymlink p1 p2
-  | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
-  | otherwise =
-    let d1      = splitDirectories p1
-        d2      = splitDirectories p2
-        common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
-        cPrefix = drop (length common) d1
-    in  joinPath (replicate (length cPrefix) "..")
-          <> joinPath ([pathSeparator] : drop (length common) d2)
-
-
-cleanupTrash :: ( MonadIO m
-                , MonadMask m
-                , MonadReader env m
-                , HasLog env
-                , HasDirs env
-                , HasSettings env
-                )
-             => m ()
-cleanupTrash = do
-  Dirs { recycleDir } <- getDirs
-  contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
-  if null contents
-  then pure ()
-  else do
-    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 `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
-
-
-
-